From cfb7685a7fe726d792f63090f538296006766c5f Mon Sep 17 00:00:00 2001
From: Martin Kroeker <martin@ruby.chemie.uni-freiburg.de>
Date: Wed, 19 Mar 2025 22:36:56 +0100
Subject: [PATCH 01/17] Add cblas_?gemmtr aliases of cblas_?gemmt
---
cblas.h | 8 ++++++++
1 file changed, 8 insertions(+)
diff --git a/cblas.h b/cblas.h
index 83686f7433..f0630c98d1 100644
--- a/cblas.h
+++ b/cblas.h
@@ -316,6 +316,14 @@ void cblas_cgemmt(OPENBLAS_CONST enum CBLAS_ORDER Order, OPENBLAS_CONST enum CBL
OPENBLAS_CONST void *alpha, OPENBLAS_CONST void *A, OPENBLAS_CONST blasint lda, OPENBLAS_CONST void *B, OPENBLAS_CONST blasint ldb, OPENBLAS_CONST void *beta, void *C, OPENBLAS_CONST blasint ldc);
void cblas_zgemmt(OPENBLAS_CONST enum CBLAS_ORDER Order, OPENBLAS_CONST enum CBLAS_UPLO Uplo, OPENBLAS_CONST enum CBLAS_TRANSPOSE TransA, OPENBLAS_CONST enum CBLAS_TRANSPOSE TransB, OPENBLAS_CONST blasint M, OPENBLAS_CONST blasint K,
OPENBLAS_CONST void *alpha, OPENBLAS_CONST void *A, OPENBLAS_CONST blasint lda, OPENBLAS_CONST void *B, OPENBLAS_CONST blasint ldb, OPENBLAS_CONST void *beta, void *C, OPENBLAS_CONST blasint ldc);
+void cblas_sgemmtr(OPENBLAS_CONST enum CBLAS_ORDER Order, OPENBLAS_CONST enum CBLAS_UPLO Uplo, OPENBLAS_CONST enum CBLAS_TRANSPOSE TransA, OPENBLAS_CONST enum CBLAS_TRANSPOSE TransB, OPENBLAS_CONST blasint M, OPENBLAS_CONST blasint K,
+ OPENBLAS_CONST float alpha, OPENBLAS_CONST float *A, OPENBLAS_CONST blasint lda, OPENBLAS_CONST float *B, OPENBLAS_CONST blasint ldb, OPENBLAS_CONST float beta, float *C, OPENBLAS_CONST blasint ldc);
+void cblas_dgemmtr(OPENBLAS_CONST enum CBLAS_ORDER Order, OPENBLAS_CONST enum CBLAS_UPLO Uplo, OPENBLAS_CONST enum CBLAS_TRANSPOSE TransA, OPENBLAS_CONST enum CBLAS_TRANSPOSE TransB, OPENBLAS_CONST blasint M, OPENBLAS_CONST blasint K,
+ OPENBLAS_CONST double alpha, OPENBLAS_CONST double *A, OPENBLAS_CONST blasint lda, OPENBLAS_CONST double *B, OPENBLAS_CONST blasint ldb, OPENBLAS_CONST double beta, double *C, OPENBLAS_CONST blasint ldc);
+void cblas_cgemmtr(OPENBLAS_CONST enum CBLAS_ORDER Order, OPENBLAS_CONST enum CBLAS_UPLO Uplo, OPENBLAS_CONST enum CBLAS_TRANSPOSE TransA, OPENBLAS_CONST enum CBLAS_TRANSPOSE TransB, OPENBLAS_CONST blasint M, OPENBLAS_CONST blasint K,
+ OPENBLAS_CONST void *alpha, OPENBLAS_CONST void *A, OPENBLAS_CONST blasint lda, OPENBLAS_CONST void *B, OPENBLAS_CONST blasint ldb, OPENBLAS_CONST void *beta, void *C, OPENBLAS_CONST blasint ldc);
+void cblas_zgemmtr(OPENBLAS_CONST enum CBLAS_ORDER Order, OPENBLAS_CONST enum CBLAS_UPLO Uplo, OPENBLAS_CONST enum CBLAS_TRANSPOSE TransA, OPENBLAS_CONST enum CBLAS_TRANSPOSE TransB, OPENBLAS_CONST blasint M, OPENBLAS_CONST blasint K,
+ OPENBLAS_CONST void *alpha, OPENBLAS_CONST void *A, OPENBLAS_CONST blasint lda, OPENBLAS_CONST void *B, OPENBLAS_CONST blasint ldb, OPENBLAS_CONST void *beta, void *C, OPENBLAS_CONST blasint ldc);
void cblas_ssymm(OPENBLAS_CONST enum CBLAS_ORDER Order, OPENBLAS_CONST enum CBLAS_SIDE Side, OPENBLAS_CONST enum CBLAS_UPLO Uplo, OPENBLAS_CONST blasint M, OPENBLAS_CONST blasint N,
OPENBLAS_CONST float alpha, OPENBLAS_CONST float *A, OPENBLAS_CONST blasint lda, OPENBLAS_CONST float *B, OPENBLAS_CONST blasint ldb, OPENBLAS_CONST float beta, float *C, OPENBLAS_CONST blasint ldc);
From 088f3b4355a998a332cca33fc9a9785fa2d46f8a Mon Sep 17 00:00:00 2001
From: Martin Kroeker <martin@ruby.chemie.uni-freiburg.de>
Date: Wed, 19 Mar 2025 22:41:20 +0100
Subject: [PATCH 02/17] Update CBLAS3 tests from Reference-LAPACK to add
GEMMT(R) testing
---
ctest/c_cblas3.c | 240 ++++++++++----
ctest/c_cblat3.f | 756 +++++++++++++++++++++++++++++++++++++++------
ctest/c_dblas3.c | 230 ++++++++++----
ctest/c_dblat3.f | 665 +++++++++++++++++++++++++++++++++------
ctest/c_sblas3.c | 226 ++++++++++----
ctest/c_sblat3.f | 650 +++++++++++++++++++++++++++++++++-----
ctest/c_zblas3.c | 307 ++++++++++++------
ctest/c_zblat3.f | 752 ++++++++++++++++++++++++++++++++++++++------
ctest/cblas_test.h | 658 ++++++++++-----------------------------
ctest/cin3 | 5 +-
ctest/din3 | 19 +-
ctest/sin3 | 19 +-
ctest/zin3 | 25 +-
13 files changed, 3366 insertions(+), 1186 deletions(-)
diff --git a/ctest/c_cblas3.c b/ctest/c_cblas3.c
index 9f48c49b14..ef673103b6 100644
--- a/ctest/c_cblas3.c
+++ b/ctest/c_cblas3.c
@@ -5,26 +5,29 @@
* Modified by T. H. Do, 4/15/98, SGI/CRAY Research.
*/
#include <stdlib.h>
-#include "common.h"
+#include "cblas.h"
#include "cblas_test.h"
-
#define TEST_COL_MJR 0
#define TEST_ROW_MJR 1
#define UNDEFINED -1
-void F77_cgemm(int *order, char *transpa, char *transpb, int *m, int *n,
+void F77_cgemm(int *layout, char *transpa, char *transpb, int *m, int *n,
int *k, CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, int *lda,
CBLAS_TEST_COMPLEX *b, int *ldb, CBLAS_TEST_COMPLEX *beta,
- CBLAS_TEST_COMPLEX *c, int *ldc ) {
+ CBLAS_TEST_COMPLEX *c, int *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN transpa_len, FORTRAN_STRLEN transpb_len
+#endif
+) {
CBLAS_TEST_COMPLEX *A, *B, *C;
int i,j,LDA, LDB, LDC;
- enum CBLAS_TRANSPOSE transa, transb;
+ CBLAS_TRANSPOSE transa, transb;
get_transpose_type(transpa, &transa);
get_transpose_type(transpb, &transb);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (transa == CblasNoTrans) {
LDA = *k+1;
A=(CBLAS_TEST_COMPLEX*)malloc((*m)*LDA*sizeof(CBLAS_TEST_COMPLEX));
@@ -81,7 +84,7 @@ void F77_cgemm(int *order, char *transpa, char *transpb, int *m, int *n,
free(B);
free(C);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_cgemm( CblasColMajor, transa, transb, *m, *n, *k, alpha, a, *lda,
b, *ldb, beta, c, *ldc );
else
@@ -89,20 +92,104 @@ void F77_cgemm(int *order, char *transpa, char *transpb, int *m, int *n,
b, *ldb, beta, c, *ldc );
}
-void F77_chemm(int *order, char *rtlf, char *uplow, int *m, int *n,
+void F77_cgemmtr(int *layout, char *uplop, char *transpa, char *transpb, int *n,
+ int *k, CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, int *lda,
+ CBLAS_TEST_COMPLEX *b, int *ldb, CBLAS_TEST_COMPLEX *beta,
+ CBLAS_TEST_COMPLEX *c, int *ldc ) {
+
+ CBLAS_TEST_COMPLEX *A, *B, *C;
+ int i,j,LDA, LDB, LDC;
+ CBLAS_TRANSPOSE transa, transb;
+ CBLAS_UPLO uplo;
+
+ get_transpose_type(transpa, &transa);
+ get_transpose_type(transpb, &transb);
+ get_uplo_type(uplop, &uplo);
+
+ if (*layout == TEST_ROW_MJR) {
+ if (transa == CblasNoTrans) {
+ LDA = *k+1;
+ A=(CBLAS_TEST_COMPLEX*)malloc((*n)*LDA*sizeof(CBLAS_TEST_COMPLEX));
+ for( i=0; i<*n; i++ )
+ for( j=0; j<*k; j++ ) {
+ A[i*LDA+j].real=a[j*(*lda)+i].real;
+ A[i*LDA+j].imag=a[j*(*lda)+i].imag;
+ }
+ }
+ else {
+ LDA = *n+1;
+ A=(CBLAS_TEST_COMPLEX* )malloc(LDA*(*k)*sizeof(CBLAS_TEST_COMPLEX));
+ for( i=0; i<*k; i++ )
+ for( j=0; j<*n; j++ ) {
+ A[i*LDA+j].real=a[j*(*lda)+i].real;
+ A[i*LDA+j].imag=a[j*(*lda)+i].imag;
+ }
+ }
+
+ if (transb == CblasNoTrans) {
+ LDB = *n+1;
+ B=(CBLAS_TEST_COMPLEX* )malloc((*k)*LDB*sizeof(CBLAS_TEST_COMPLEX) );
+ for( i=0; i<*k; i++ )
+ for( j=0; j<*n; j++ ) {
+ B[i*LDB+j].real=b[j*(*ldb)+i].real;
+ B[i*LDB+j].imag=b[j*(*ldb)+i].imag;
+ }
+ }
+ else {
+ LDB = *k+1;
+ B=(CBLAS_TEST_COMPLEX* )malloc(LDB*(*n)*sizeof(CBLAS_TEST_COMPLEX));
+ for( i=0; i<*n; i++ )
+ for( j=0; j<*k; j++ ) {
+ B[i*LDB+j].real=b[j*(*ldb)+i].real;
+ B[i*LDB+j].imag=b[j*(*ldb)+i].imag;
+ }
+ }
+
+ LDC = *n+1;
+ C=(CBLAS_TEST_COMPLEX* )malloc((*n)*LDC*sizeof(CBLAS_TEST_COMPLEX));
+ for( j=0; j<*n; j++ )
+ for( i=0; i<*n; i++ ) {
+ C[i*LDC+j].real=c[j*(*ldc)+i].real;
+ C[i*LDC+j].imag=c[j*(*ldc)+i].imag;
+ }
+ cblas_cgemmtr( CblasRowMajor, uplo, transa, transb, *n, *k, alpha, A, LDA,
+ B, LDB, beta, C, LDC );
+ for( j=0; j<*n; j++ )
+ for( i=0; i<*n; i++ ) {
+ c[j*(*ldc)+i].real=C[i*LDC+j].real;
+ c[j*(*ldc)+i].imag=C[i*LDC+j].imag;
+ }
+ free(A);
+ free(B);
+ free(C);
+ }
+ else if (*layout == TEST_COL_MJR)
+ cblas_cgemmtr( CblasColMajor, uplo, transa, transb, *n, *k, alpha, a, *lda,
+ b, *ldb, beta, c, *ldc );
+ else
+ cblas_cgemmtr( UNDEFINED, uplo, transa, transb, *n, *k, alpha, a, *lda,
+ b, *ldb, beta, c, *ldc );
+}
+
+
+void F77_chemm(int *layout, char *rtlf, char *uplow, int *m, int *n,
CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, int *lda,
- CBLAS_TEST_COMPLEX *b, int *ldb, CBLAS_TEST_COMPLEX *beta,
- CBLAS_TEST_COMPLEX *c, int *ldc ) {
+ CBLAS_TEST_COMPLEX *b, int *ldb, CBLAS_TEST_COMPLEX *beta,
+ CBLAS_TEST_COMPLEX *c, int *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len
+#endif
+) {
CBLAS_TEST_COMPLEX *A, *B, *C;
int i,j,LDA, LDB, LDC;
- enum CBLAS_UPLO uplo;
- enum CBLAS_SIDE side;
+ CBLAS_UPLO uplo;
+ CBLAS_SIDE side;
get_uplo_type(uplow,&uplo);
get_side_type(rtlf,&side);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (side == CblasLeft) {
LDA = *m+1;
A= (CBLAS_TEST_COMPLEX* )malloc((*m)*LDA*sizeof(CBLAS_TEST_COMPLEX));
@@ -146,27 +233,31 @@ void F77_chemm(int *order, char *rtlf, char *uplow, int *m, int *n,
free(B);
free(C);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_chemm( CblasColMajor, side, uplo, *m, *n, alpha, a, *lda, b, *ldb,
beta, c, *ldc );
else
cblas_chemm( UNDEFINED, side, uplo, *m, *n, alpha, a, *lda, b, *ldb,
beta, c, *ldc );
}
-void F77_csymm(int *order, char *rtlf, char *uplow, int *m, int *n,
+void F77_csymm(int *layout, char *rtlf, char *uplow, int *m, int *n,
CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, int *lda,
- CBLAS_TEST_COMPLEX *b, int *ldb, CBLAS_TEST_COMPLEX *beta,
- CBLAS_TEST_COMPLEX *c, int *ldc ) {
+ CBLAS_TEST_COMPLEX *b, int *ldb, CBLAS_TEST_COMPLEX *beta,
+ CBLAS_TEST_COMPLEX *c, int *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len
+#endif
+) {
CBLAS_TEST_COMPLEX *A, *B, *C;
int i,j,LDA, LDB, LDC;
- enum CBLAS_UPLO uplo;
- enum CBLAS_SIDE side;
+ CBLAS_UPLO uplo;
+ CBLAS_SIDE side;
get_uplo_type(uplow,&uplo);
get_side_type(rtlf,&side);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (side == CblasLeft) {
LDA = *m+1;
A=(CBLAS_TEST_COMPLEX* )malloc((*m)*LDA*sizeof(CBLAS_TEST_COMPLEX));
@@ -200,7 +291,7 @@ void F77_csymm(int *order, char *rtlf, char *uplow, int *m, int *n,
free(B);
free(C);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_csymm( CblasColMajor, side, uplo, *m, *n, alpha, a, *lda, b, *ldb,
beta, c, *ldc );
else
@@ -208,19 +299,23 @@ void F77_csymm(int *order, char *rtlf, char *uplow, int *m, int *n,
beta, c, *ldc );
}
-void F77_cherk(int *order, char *uplow, char *transp, int *n, int *k,
+void F77_cherk(int *layout, char *uplow, char *transp, int *n, int *k,
float *alpha, CBLAS_TEST_COMPLEX *a, int *lda,
- float *beta, CBLAS_TEST_COMPLEX *c, int *ldc ) {
+ float *beta, CBLAS_TEST_COMPLEX *c, int *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len
+#endif
+) {
int i,j,LDA,LDC;
CBLAS_TEST_COMPLEX *A, *C;
- enum CBLAS_UPLO uplo;
- enum CBLAS_TRANSPOSE trans;
+ CBLAS_UPLO uplo;
+ CBLAS_TRANSPOSE trans;
get_uplo_type(uplow,&uplo);
get_transpose_type(transp,&trans);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (trans == CblasNoTrans) {
LDA = *k+1;
A=(CBLAS_TEST_COMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_COMPLEX ) );
@@ -256,7 +351,7 @@ void F77_cherk(int *order, char *uplow, char *transp, int *n, int *k,
free(A);
free(C);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_cherk(CblasColMajor, uplo, trans, *n, *k, *alpha, a, *lda, *beta,
c, *ldc );
else
@@ -264,19 +359,23 @@ void F77_cherk(int *order, char *uplow, char *transp, int *n, int *k,
c, *ldc );
}
-void F77_csyrk(int *order, char *uplow, char *transp, int *n, int *k,
+void F77_csyrk(int *layout, char *uplow, char *transp, int *n, int *k,
CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, int *lda,
- CBLAS_TEST_COMPLEX *beta, CBLAS_TEST_COMPLEX *c, int *ldc ) {
+ CBLAS_TEST_COMPLEX *beta, CBLAS_TEST_COMPLEX *c, int *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len
+#endif
+) {
int i,j,LDA,LDC;
CBLAS_TEST_COMPLEX *A, *C;
- enum CBLAS_UPLO uplo;
- enum CBLAS_TRANSPOSE trans;
+ CBLAS_UPLO uplo;
+ CBLAS_TRANSPOSE trans;
get_uplo_type(uplow,&uplo);
get_transpose_type(transp,&trans);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (trans == CblasNoTrans) {
LDA = *k+1;
A=(CBLAS_TEST_COMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_COMPLEX));
@@ -312,26 +411,30 @@ void F77_csyrk(int *order, char *uplow, char *transp, int *n, int *k,
free(A);
free(C);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_csyrk(CblasColMajor, uplo, trans, *n, *k, alpha, a, *lda, beta,
c, *ldc );
else
cblas_csyrk(UNDEFINED, uplo, trans, *n, *k, alpha, a, *lda, beta,
c, *ldc );
}
-void F77_cher2k(int *order, char *uplow, char *transp, int *n, int *k,
+void F77_cher2k(int *layout, char *uplow, char *transp, int *n, int *k,
CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, int *lda,
CBLAS_TEST_COMPLEX *b, int *ldb, float *beta,
- CBLAS_TEST_COMPLEX *c, int *ldc ) {
+ CBLAS_TEST_COMPLEX *c, int *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len
+#endif
+) {
int i,j,LDA,LDB,LDC;
CBLAS_TEST_COMPLEX *A, *B, *C;
- enum CBLAS_UPLO uplo;
- enum CBLAS_TRANSPOSE trans;
+ CBLAS_UPLO uplo;
+ CBLAS_TRANSPOSE trans;
get_uplo_type(uplow,&uplo);
get_transpose_type(transp,&trans);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (trans == CblasNoTrans) {
LDA = *k+1;
LDB = *k+1;
@@ -376,26 +479,30 @@ void F77_cher2k(int *order, char *uplow, char *transp, int *n, int *k,
free(B);
free(C);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_cher2k(CblasColMajor, uplo, trans, *n, *k, alpha, a, *lda,
b, *ldb, *beta, c, *ldc );
else
cblas_cher2k(UNDEFINED, uplo, trans, *n, *k, alpha, a, *lda,
b, *ldb, *beta, c, *ldc );
}
-void F77_csyr2k(int *order, char *uplow, char *transp, int *n, int *k,
+void F77_csyr2k(int *layout, char *uplow, char *transp, int *n, int *k,
CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, int *lda,
CBLAS_TEST_COMPLEX *b, int *ldb, CBLAS_TEST_COMPLEX *beta,
- CBLAS_TEST_COMPLEX *c, int *ldc ) {
+ CBLAS_TEST_COMPLEX *c, int *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len
+#endif
+) {
int i,j,LDA,LDB,LDC;
CBLAS_TEST_COMPLEX *A, *B, *C;
- enum CBLAS_UPLO uplo;
- enum CBLAS_TRANSPOSE trans;
+ CBLAS_UPLO uplo;
+ CBLAS_TRANSPOSE trans;
get_uplo_type(uplow,&uplo);
get_transpose_type(transp,&trans);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (trans == CblasNoTrans) {
LDA = *k+1;
LDB = *k+1;
@@ -440,29 +547,33 @@ void F77_csyr2k(int *order, char *uplow, char *transp, int *n, int *k,
free(B);
free(C);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_csyr2k(CblasColMajor, uplo, trans, *n, *k, alpha, a, *lda,
b, *ldb, beta, c, *ldc );
else
cblas_csyr2k(UNDEFINED, uplo, trans, *n, *k, alpha, a, *lda,
b, *ldb, beta, c, *ldc );
}
-void F77_ctrmm(int *order, char *rtlf, char *uplow, char *transp, char *diagn,
+void F77_ctrmm(int *layout, char *rtlf, char *uplow, char *transp, char *diagn,
int *m, int *n, CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a,
- int *lda, CBLAS_TEST_COMPLEX *b, int *ldb) {
+ int *lda, CBLAS_TEST_COMPLEX *b, int *ldb
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
int i,j,LDA,LDB;
CBLAS_TEST_COMPLEX *A, *B;
- enum CBLAS_SIDE side;
- enum CBLAS_DIAG diag;
- enum CBLAS_UPLO uplo;
- enum CBLAS_TRANSPOSE trans;
+ CBLAS_SIDE side;
+ CBLAS_DIAG diag;
+ CBLAS_UPLO uplo;
+ CBLAS_TRANSPOSE trans;
get_uplo_type(uplow,&uplo);
get_transpose_type(transp,&trans);
get_diag_type(diagn,&diag);
get_side_type(rtlf,&side);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (side == CblasLeft) {
LDA = *m+1;
A=(CBLAS_TEST_COMPLEX* )malloc((*m)*LDA*sizeof(CBLAS_TEST_COMPLEX));
@@ -498,7 +609,7 @@ void F77_ctrmm(int *order, char *rtlf, char *uplow, char *transp, char *diagn,
free(A);
free(B);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_ctrmm(CblasColMajor, side, uplo, trans, diag, *m, *n, alpha,
a, *lda, b, *ldb);
else
@@ -506,22 +617,26 @@ void F77_ctrmm(int *order, char *rtlf, char *uplow, char *transp, char *diagn,
a, *lda, b, *ldb);
}
-void F77_ctrsm(int *order, char *rtlf, char *uplow, char *transp, char *diagn,
+void F77_ctrsm(int *layout, char *rtlf, char *uplow, char *transp, char *diagn,
int *m, int *n, CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a,
- int *lda, CBLAS_TEST_COMPLEX *b, int *ldb) {
+ int *lda, CBLAS_TEST_COMPLEX *b, int *ldb
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
int i,j,LDA,LDB;
CBLAS_TEST_COMPLEX *A, *B;
- enum CBLAS_SIDE side;
- enum CBLAS_DIAG diag;
- enum CBLAS_UPLO uplo;
- enum CBLAS_TRANSPOSE trans;
+ CBLAS_SIDE side;
+ CBLAS_DIAG diag;
+ CBLAS_UPLO uplo;
+ CBLAS_TRANSPOSE trans;
get_uplo_type(uplow,&uplo);
get_transpose_type(transp,&trans);
get_diag_type(diagn,&diag);
get_side_type(rtlf,&side);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (side == CblasLeft) {
LDA = *m+1;
A=(CBLAS_TEST_COMPLEX* )malloc( (*m)*LDA*sizeof(CBLAS_TEST_COMPLEX ) );
@@ -557,13 +672,10 @@ void F77_ctrsm(int *order, char *rtlf, char *uplow, char *transp, char *diagn,
free(A);
free(B);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_ctrsm(CblasColMajor, side, uplo, trans, diag, *m, *n, alpha,
a, *lda, b, *ldb);
else
cblas_ctrsm(UNDEFINED, side, uplo, trans, diag, *m, *n, alpha,
a, *lda, b, *ldb);
}
-
-
-
diff --git a/ctest/c_cblat3.f b/ctest/c_cblat3.f
index f713b2dd0a..07be55c929 100644
--- a/ctest/c_cblat3.f
+++ b/ctest/c_cblat3.f
@@ -3,14 +3,14 @@ PROGRAM CBLAT3
* Test program for the COMPLEX Level 3 Blas.
*
* The program must be driven by a short data file. The first 13 records
-* of the file are read using list-directed input, the last 9 records
-* are read using the format ( A12, L2 ). An annotated example of a data
+* of the file are read using list-directed input, the last 10 records
+* are read using the format ( A13, L2 ). An annotated example of a data
* file can be obtained by deleting the first 3 characters from the
-* following 22 lines:
+* following 23 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 ERROR STOP ON FAILURES.
+* 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
@@ -20,15 +20,16 @@ PROGRAM CBLAT3
* (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.
+* 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.
+* cblas_cgemmtr T PUT F FOR NO TEST. SAME COLUMNS.
*
* See:
*
@@ -49,7 +50,7 @@ PROGRAM CBLAT3
INTEGER NIN, NOUT
PARAMETER ( NIN = 5, NOUT = 6 )
INTEGER NSUBS
- PARAMETER ( NSUBS = 9 )
+ PARAMETER ( NSUBS = 10 )
COMPLEX ZERO, ONE
PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) )
REAL RZERO, RHALF, RONE
@@ -65,7 +66,7 @@ PROGRAM CBLAT3
LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
$ TSTERR, CORDER, RORDER
CHARACTER*1 TRANSA, TRANSB
- CHARACTER*12 SNAMET
+ CHARACTER*13 SNAMET
CHARACTER*32 SNAPS
* .. Local Arrays ..
COMPLEX AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ),
@@ -77,19 +78,19 @@ PROGRAM CBLAT3
REAL G( NMAX )
INTEGER IDIM( NIDMAX )
LOGICAL LTEST( NSUBS )
- CHARACTER*12 SNAMES( NSUBS )
+ CHARACTER*13 SNAMES( NSUBS )
* .. External Functions ..
REAL SDIFF
LOGICAL LCE
EXTERNAL SDIFF, LCE
* .. External Subroutines ..
- EXTERNAL CCHK1, CCHK2, CCHK3, CCHK4, CCHK5, CMMCH
+ EXTERNAL CCHK1, CCHK2, CCHK3, CCHK4, CCHK5, CCHK6, CMMCH
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
- CHARACTER*12 SRNAMT
+ CHARACTER*13 SRNAMT
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
COMMON /SRNAMC/SRNAMT
@@ -97,7 +98,7 @@ PROGRAM CBLAT3
DATA SNAMES/'cblas_cgemm ', 'cblas_chemm ',
$ 'cblas_csymm ', 'cblas_ctrmm ', 'cblas_ctrsm ',
$ 'cblas_cherk ', 'cblas_csyrk ', 'cblas_cher2k',
- $ 'cblas_csyr2k'/
+ $ 'cblas_csyr2k', 'cblas_cgemmtr' /
* .. Executable Statements ..
*
NOUTC = NOUT
@@ -194,7 +195,7 @@ PROGRAM CBLAT3
$ GO TO 50
40 CONTINUE
WRITE( NOUT, FMT = 9990 )SNAMET
- ERROR STOP
+ STOP
50 LTEST( I ) = LTESTT
GO TO 30
*
@@ -237,7 +238,7 @@ PROGRAM CBLAT3
SAME = LCE( CC, CT, N )
IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
- ERROR STOP
+ STOP
END IF
TRANSB = 'C'
CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
@@ -246,7 +247,7 @@ PROGRAM CBLAT3
SAME = LCE( CC, CT, N )
IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
- ERROR STOP
+ STOP
END IF
DO 120 J = 1, N
AB( J, NMAX + 1 ) = N - J + 1
@@ -264,7 +265,7 @@ PROGRAM CBLAT3
SAME = LCE( CC, CT, N )
IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
- ERROR STOP
+ STOP
END IF
TRANSB = 'C'
CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
@@ -273,7 +274,7 @@ PROGRAM CBLAT3
SAME = LCE( CC, CT, N )
IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
- ERROR STOP
+ STOP
END IF
*
* Test each subroutine in turn.
@@ -295,7 +296,7 @@ PROGRAM CBLAT3
OK = .TRUE.
FATAL = .FALSE.
GO TO ( 140, 150, 150, 160, 160, 170, 170,
- $ 180, 180 )ISNUM
+ $ 180, 180, 185 )ISNUM
* Test CGEMM, 01.
140 IF (CORDER) THEN
CALL CCHK1(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
@@ -329,13 +330,13 @@ PROGRAM CBLAT3
CALL CCHK3(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB,
$ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C,
- $ 0 )
+ $ 0 )
END IF
IF (RORDER) THEN
CALL CCHK3(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB,
$ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C,
- $ 1 )
+ $ 1 )
END IF
GO TO 190
* Test CHERK, 06, CSYRK, 07.
@@ -357,15 +358,30 @@ PROGRAM CBLAT3
CALL CCHK5(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
$ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W,
- $ 0 )
+ $ 0 )
END IF
IF (RORDER) THEN
CALL CCHK5(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
$ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W,
- $ 1 )
+ $ 1 )
END IF
GO TO 190
+* Test CGEMMTR, 10.
+ 185 IF (CORDER) THEN
+ CALL CCHK6(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
+ $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
+ $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
+ $ CC, CS, CT, G, 0 )
+ END IF
+ IF (RORDER) THEN
+ CALL CCHK6(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
+ $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
+ $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
+ $ CC, CS, CT, G, 1 )
+ END IF
+ GO TO 190
+
*
190 IF( FATAL.AND.SFATAL )
$ GO TO 210
@@ -385,9 +401,7 @@ PROGRAM CBLAT3
IF( TRACE )
$ CLOSE ( NTRA )
CLOSE ( NOUT )
- IF( FATAL ) THEN
- ERROR STOP
- END IF
+ STOP
*
10002 FORMAT( ' COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED' )
10001 FORMAT(' ROW-MAJOR DATA LAYOUT IS TESTED' )
@@ -407,7 +421,7 @@ PROGRAM CBLAT3
$ 7( '(', F4.1, ',', F4.1, ') ', : ) )
9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
$ /' ******* TESTS ABANDONED *******' )
- 9990 FORMAT(' SUBPROGRAM NAME ', A12,' NOT RECOGNIZED', /' ******* T',
+ 9990 FORMAT(' SUBPROGRAM NAME ', A13,' NOT RECOGNIZED', /' ******* T',
$ 'ESTS ABANDONED *******' )
9989 FORMAT(' ERROR IN CMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
$ 'ATED WRONGLY.', /' CMMCH WAS CALLED WITH TRANSA = ', A1,
@@ -415,8 +429,8 @@ PROGRAM CBLAT3
$ ' ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ',
$ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ',
$ '*******' )
- 9988 FORMAT( A12,L2 )
- 9987 FORMAT( 1X, A12,' WAS NOT TESTED' )
+ 9988 FORMAT( A13,L2 )
+ 9987 FORMAT( 1X, A13,' WAS NOT TESTED' )
9986 FORMAT( /' END OF TESTS' )
9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
@@ -448,7 +462,7 @@ SUBROUTINE CCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
REAL EPS, THRESH
INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
LOGICAL FATAL, REWI, TRACE
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
* .. Array Arguments ..
COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), B( NMAX, NMAX ),
@@ -696,22 +710,22 @@ SUBROUTINE CCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
130 CONTINUE
RETURN
*
-10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
+10003 FORMAT( ' ', A13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
+10002 FORMAT( ' ', A13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
+10001 FORMAT( ' ', A13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
-10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
+10000 FORMAT( ' ', A13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
- 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
-C 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',',
-C $ 3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3,
-C $ ',(', F4.1, ',', F4.1, '), C,', I3, ').' )
+ 9996 FORMAT( ' ******* ', A13,' FAILED ON CALL NUMBER:' )
+ 9995 FORMAT( 1X, I6, ': ', A13,'(''', A1, ''',''', A1, ''',',
+ $ 3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3,
+ $ ',(', F4.1, ',', F4.1, '), C,', I3, ').' )
9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
@@ -724,7 +738,7 @@ SUBROUTINE CPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, M, N,
INTEGER NOUT, NC, IORDER, M, N, K, LDA, LDB, LDC
COMPLEX ALPHA, BETA
CHARACTER*1 TRANSA, TRANSB
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
CHARACTER*14 CRC, CTA,CTB
IF (TRANSA.EQ.'N')THEN
@@ -749,7 +763,7 @@ SUBROUTINE CPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, M, N,
WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CTA,CTB
WRITE(NOUT, FMT = 9994)M, N, K, ALPHA, LDA, LDB, BETA, LDC
- 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',')
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', A14, ',', A14, ',', A14, ',')
9994 FORMAT( 10X, 3( I3, ',' ) ,' (', F4.1,',',F4.1,') , A,',
$ I3, ', B,', I3, ', (', F4.1,',',F4.1,') , C,', I3, ').' )
END
@@ -778,7 +792,7 @@ SUBROUTINE CCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
REAL EPS, THRESH
INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
LOGICAL FATAL, REWI, TRACE
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
* .. Array Arguments ..
COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), B( NMAX, NMAX ),
@@ -1022,22 +1036,22 @@ SUBROUTINE CCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
120 CONTINUE
RETURN
*
-10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
+10003 FORMAT( ' ', A13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
+10002 FORMAT( ' ', A13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
+10001 FORMAT( ' ', A13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
-10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
+10000 FORMAT( ' ', A13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
- 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
-C 9995 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
-C $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1,
-C $ ',', F4.1, '), C,', I3, ') .' )
+ 9996 FORMAT( ' ******* ', A13,' FAILED ON CALL NUMBER:' )
+ 9995 FORMAT(1X, I6, ': ', A13,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
+ $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1,
+ $ ',', F4.1, '), C,', I3, ') .' )
9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
@@ -1050,7 +1064,7 @@ SUBROUTINE CPRCN2(NOUT, NC, SNAME, IORDER, SIDE, UPLO, M, N,
INTEGER NOUT, NC, IORDER, M, N, LDA, LDB, LDC
COMPLEX ALPHA, BETA
CHARACTER*1 SIDE, UPLO
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
CHARACTER*14 CRC, CS,CU
IF (SIDE.EQ.'L')THEN
@@ -1071,7 +1085,7 @@ SUBROUTINE CPRCN2(NOUT, NC, SNAME, IORDER, SIDE, UPLO, M, N,
WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CS,CU
WRITE(NOUT, FMT = 9994)M, N, ALPHA, LDA, LDB, BETA, LDC
- 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',')
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', A14, ',', A14, ',', A14, ',')
9994 FORMAT( 10X, 2( I3, ',' ),' (',F4.1,',',F4.1, '), A,', I3,
$ ', B,', I3, ', (',F4.1,',',F4.1, '), ', 'C,', I3, ').' )
END
@@ -1099,7 +1113,7 @@ SUBROUTINE CCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
REAL EPS, THRESH
INTEGER NALF, NIDIM, NMAX, NOUT, NTRA, IORDER
LOGICAL FATAL, REWI, TRACE
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
* .. Array Arguments ..
COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), B( NMAX, NMAX ),
@@ -1374,22 +1388,22 @@ SUBROUTINE CCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
160 CONTINUE
RETURN
*
-10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
+10003 FORMAT( ' ', A13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
+10002 FORMAT( ' ', A13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
+10001 FORMAT( ' ', A13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
-10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
+10000 FORMAT( ' ', A13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
- 9996 FORMAT(' ******* ', A12,' FAILED ON CALL NUMBER:' )
-C 9995 FORMAT(1X, I6, ': ', A12,'(', 4( '''', A1, ''',' ), 2( I3, ',' ),
-C $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ') ',
-C $ ' .' )
+ 9996 FORMAT(' ******* ', A13,' FAILED ON CALL NUMBER:' )
+ 9995 FORMAT(1X, I6, ': ', A13,'(', 4( '''', A1, ''',' ), 2( I3, ',' ),
+ $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ') ',
+ $ ' .' )
9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
@@ -1402,7 +1416,7 @@ SUBROUTINE CPRCN3(NOUT, NC, SNAME, IORDER, SIDE, UPLO, TRANSA,
INTEGER NOUT, NC, IORDER, M, N, LDA, LDB
COMPLEX ALPHA
CHARACTER*1 SIDE, UPLO, TRANSA, DIAG
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
CHARACTER*14 CRC, CS, CU, CA, CD
IF (SIDE.EQ.'L')THEN
@@ -1435,7 +1449,7 @@ SUBROUTINE CPRCN3(NOUT, NC, SNAME, IORDER, SIDE, UPLO, TRANSA,
WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CS,CU
WRITE(NOUT, FMT = 9994)CA, CD, M, N, ALPHA, LDA, LDB
- 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',')
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', A14, ',', A14, ',', A14, ',')
9994 FORMAT( 10X, 2( A14, ',') , 2( I3, ',' ), ' (', F4.1, ',',
$ F4.1, '), A,', I3, ', B,', I3, ').' )
END
@@ -1464,7 +1478,7 @@ SUBROUTINE CCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
REAL EPS, THRESH
INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
LOGICAL FATAL, REWI, TRACE
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
* .. Array Arguments ..
COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), B( NMAX, NMAX ),
@@ -1505,8 +1519,6 @@ SUBROUTINE CCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
NC = 0
RESET = .TRUE.
ERRMAX = RZERO
- RALS = RONE
- RBETS = RONE
*
DO 100 IN = 1, NIDIM
N = IDIM( IN )
@@ -1758,26 +1770,26 @@ SUBROUTINE CCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
130 CONTINUE
RETURN
*
-10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
+10003 FORMAT( ' ', A13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
+10002 FORMAT( ' ', A13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
+10001 FORMAT( ' ', A13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
-10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
+10000 FORMAT( ' ', A13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
- 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
+ 9996 FORMAT( ' ******* ', A13,' FAILED ON CALL NUMBER:' )
9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
-C 9994 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
-C $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') ',
-C $ ' .' )
-C 9993 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
-C $ '(', F4.1, ',', F4.1, ') , A,', I3, ',(', F4.1, ',', F4.1,
-C $ '), C,', I3, ') .' )
+ 9994 FORMAT(1X, I6, ': ', A13,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
+ $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') ',
+ $ ' .' )
+ 9993 FORMAT(1X, I6, ': ', A13,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
+ $ '(', F4.1, ',', F4.1, ') , A,', I3, ',(', F4.1, ',', F4.1,
+ $ '), C,', I3, ') .' )
9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
@@ -1790,7 +1802,7 @@ SUBROUTINE CPRCN4(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
INTEGER NOUT, NC, IORDER, N, K, LDA, LDC
COMPLEX ALPHA, BETA
CHARACTER*1 UPLO, TRANSA
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
CHARACTER*14 CRC, CU, CA
IF (UPLO.EQ.'U')THEN
@@ -1813,7 +1825,7 @@ SUBROUTINE CPRCN4(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA
WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, BETA, LDC
- 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') )
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', 3( A14, ',') )
9994 FORMAT( 10X, 2( I3, ',' ), ' (', F4.1, ',', F4.1 ,'), A,',
$ I3, ', (', F4.1,',', F4.1, '), C,', I3, ').' )
END
@@ -1824,7 +1836,7 @@ SUBROUTINE CPRCN6(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
INTEGER NOUT, NC, IORDER, N, K, LDA, LDC
REAL ALPHA, BETA
CHARACTER*1 UPLO, TRANSA
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
CHARACTER*14 CRC, CU, CA
IF (UPLO.EQ.'U')THEN
@@ -1847,7 +1859,7 @@ SUBROUTINE CPRCN6(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA
WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, BETA, LDC
- 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') )
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', 3( A14, ',') )
9994 FORMAT( 10X, 2( I3, ',' ),
$ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ').' )
END
@@ -1876,7 +1888,7 @@ SUBROUTINE CCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
REAL EPS, THRESH
INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
LOGICAL FATAL, REWI, TRACE
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
* .. Array Arguments ..
COMPLEX AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ),
$ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ),
@@ -2211,26 +2223,26 @@ SUBROUTINE CCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
160 CONTINUE
RETURN
*
-10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
+10003 FORMAT( ' ', A13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
+10002 FORMAT( ' ', A13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
+10001 FORMAT( ' ', A13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
-10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
+10000 FORMAT( ' ', A13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
- 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
+ 9996 FORMAT( ' ******* ', A13,' FAILED ON CALL NUMBER:' )
9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
-C 9994 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
-C $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',', F4.1,
-C $ ', C,', I3, ') .' )
-C 9993 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
-C $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1,
-C $ ',', F4.1, '), C,', I3, ') .' )
+ 9994 FORMAT(1X, I6, ': ', A13,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
+ $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',', F4.1,
+ $ ', C,', I3, ') .' )
+ 9993 FORMAT(1X, I6, ': ', A13,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
+ $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1,
+ $ ',', F4.1, '), C,', I3, ') .' )
9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
@@ -2243,7 +2255,7 @@ SUBROUTINE CPRCN5(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
INTEGER NOUT, NC, IORDER, N, K, LDA, LDB, LDC
COMPLEX ALPHA, BETA
CHARACTER*1 UPLO, TRANSA
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
CHARACTER*14 CRC, CU, CA
IF (UPLO.EQ.'U')THEN
@@ -2266,7 +2278,7 @@ SUBROUTINE CPRCN5(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA
WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, LDB, BETA, LDC
- 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') )
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', 3( A14, ',') )
9994 FORMAT( 10X, 2( I3, ',' ), ' (', F4.1, ',', F4.1, '), A,',
$ I3, ', B', I3, ', (', F4.1, ',', F4.1, '), C,', I3, ').' )
END
@@ -2278,7 +2290,7 @@ SUBROUTINE CPRCN7(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
COMPLEX ALPHA
REAL BETA
CHARACTER*1 UPLO, TRANSA
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
CHARACTER*14 CRC, CU, CA
IF (UPLO.EQ.'U')THEN
@@ -2301,7 +2313,7 @@ SUBROUTINE CPRCN7(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA
WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, LDB, BETA, LDC
- 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') )
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', 3( A14, ',') )
9994 FORMAT( 10X, 2( I3, ',' ), ' (', F4.1, ',', F4.1, '), A,',
$ I3, ', B', I3, ',', F4.1, ', C,', I3, ').' )
END
@@ -2706,7 +2718,7 @@ LOGICAL FUNCTION LCERES( TYPE, UPLO, M, N, AA, AS, LDA )
50 CONTINUE
END IF
*
-C 60 CONTINUE
+ 60 CONTINUE
LCERES = .TRUE.
GO TO 80
70 CONTINUE
@@ -2789,3 +2801,541 @@ REAL FUNCTION SDIFF( X, Y )
* End of SDIFF.
*
END
+
+ SUBROUTINE CCHK6( 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 )
+ IMPLICIT NONE
+*
+* Tests CGEMMTR.
+*
+* Auxiliary routine for test program for Level 3 Blas.
+*
+* -- Written on 24-June-2024.
+* Martin Koehler, Max Planck Institute Magdeburg
+*
+* .. Parameters ..
+ COMPLEX ZERO
+ PARAMETER ( ZERO = ( 0.0, 0.0 ) )
+ REAL RZERO
+ PARAMETER ( RZERO = 0.0 )
+* .. Scalar Arguments ..
+ REAL EPS, THRESH
+ INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
+ LOGICAL FATAL, REWI, TRACE
+ CHARACTER*13 SNAME
+* .. Array Arguments ..
+ COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
+ $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
+ $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
+ $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
+ $ CS( NMAX*NMAX ), CT( NMAX )
+ REAL G( NMAX )
+ INTEGER IDIM( NIDIM )
+* .. Local Scalars ..
+ COMPLEX ALPHA, ALS, BETA, BLS
+ REAL ERR, ERRMAX
+ INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA,
+ $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS,
+ $ MA, MB, N, NA, NARGS, NB, NC, NS, IS
+ LOGICAL NULL, RESET, SAME, TRANA, TRANB
+ CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB, UPLO, UPLOS
+ CHARACTER*3 ICH
+ CHARACTER*2 ISHAPE
+* .. Local Arrays ..
+ LOGICAL ISAME( 13 )
+* .. External Functions ..
+ LOGICAL LCE, LCERES
+ EXTERNAL LCE, LCERES
+* .. External Subroutines ..
+ EXTERNAL CCGEMMTR, CMAKE, CMMTCH, CPRCN8
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* .. Scalars in Common ..
+ INTEGER INFOT, NOUTC
+ LOGICAL LERR, OK
+* .. Common blocks ..
+ COMMON /INFOC/INFOT, NOUTC, OK, LERR
+* .. Data statements ..
+ DATA ICH/'NTC'/
+ DATA ISHAPE/'UL'/
+* .. Executable Statements ..
+*
+ NARGS = 13
+ NC = 0
+ RESET = .TRUE.
+ ERRMAX = RZERO
+*
+ DO 100 IN = 1, NIDIM
+ N = IDIM( IN )
+* Set LDC to 1 more than minimum value if room.
+ LDC = N
+ IF( LDC.LT.NMAX )
+ $ LDC = LDC + 1
+* Skip tests if not enough room.
+ IF( LDC.GT.NMAX )
+ $ GO TO 100
+ LCC = LDC*N
+ NULL = N.LE.0.
+*
+ DO 90 IK = 1, NIDIM
+ K = IDIM( IK )
+*
+ DO 80 ICA = 1, 3
+ TRANSA = ICH( ICA: ICA )
+ TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
+*
+ IF( TRANA )THEN
+ MA = K
+ NA = N
+ ELSE
+ MA = N
+ NA = K
+ END IF
+* Set LDA to 1 more than minimum value if room.
+ LDA = MA
+ IF( LDA.LT.NMAX )
+ $ LDA = LDA + 1
+* Skip tests if not enough room.
+ IF( LDA.GT.NMAX )
+ $ GO TO 80
+ LAA = LDA*NA
+*
+* Generate the matrix A.
+*
+ CALL CMAKE( 'ge', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
+ $ RESET, ZERO )
+*
+ DO 70 ICB = 1, 3
+ TRANSB = ICH( ICB: ICB )
+ TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
+*
+ IF( TRANB )THEN
+ MB = N
+ NB = K
+ ELSE
+ MB = K
+ NB = N
+ END IF
+* Set LDB to 1 more than minimum value if room.
+ LDB = MB
+ IF( LDB.LT.NMAX )
+ $ LDB = LDB + 1
+* Skip tests if not enough room.
+ IF( LDB.GT.NMAX )
+ $ GO TO 70
+ LBB = LDB*NB
+*
+* Generate the matrix B.
+*
+ CALL CMAKE( 'ge', ' ', ' ', MB, NB, B, NMAX, BB,
+ $ LDB, RESET, ZERO )
+*
+ DO 60 IA = 1, NALF
+ ALPHA = ALF( IA )
+*
+ DO 50 IB = 1, NBET
+ BETA = BET( IB )
+ DO 45 IS = 1, 2
+ UPLO = ISHAPE(IS:IS)
+*
+* Generate the matrix C.
+*
+ CALL CMAKE( 'ge', UPLO, ' ', N, N, C, NMAX,
+ $ CC, LDC, RESET, ZERO )
+*
+ NC = NC + 1
+*
+* Save every datum before calling the
+* subroutine.
+*
+ UPLOS = UPLO
+ TRANAS = TRANSA
+ TRANBS = TRANSB
+ NS = N
+ KS = K
+ ALS = ALPHA
+ DO 10 I = 1, LAA
+ AS( I ) = AA( I )
+ 10 CONTINUE
+ LDAS = LDA
+ DO 20 I = 1, LBB
+ BS( I ) = BB( I )
+ 20 CONTINUE
+ LDBS = LDB
+ BLS = BETA
+ DO 30 I = 1, LCC
+ CS( I ) = CC( I )
+ 30 CONTINUE
+ LDCS = LDC
+*
+* Call the subroutine.
+*
+ IF( TRACE )
+ $ CALL CPRCN8(NTRA, NC, SNAME, IORDER, UPLO,
+ $ TRANSA, TRANSB, N, K, ALPHA, LDA,
+ $ LDB, BETA, LDC)
+ IF( REWI )
+ $ REWIND NTRA
+ CALL CCGEMMTR(IORDER, UPLO, TRANSA, TRANSB,
+ $ N, K, ALPHA, AA, LDA, BB, LDB,
+ $ BETA, CC, LDC )
+*
+* Check if error-exit was taken incorrectly.
+*
+ IF( .NOT.OK )THEN
+ WRITE( NOUT, FMT = 9994 )
+ FATAL = .TRUE.
+ GO TO 120
+ END IF
+*
+* See what data changed inside subroutines.
+*
+ ISAME( 1 ) = UPLO .EQ. UPLOS
+ ISAME( 2 ) = TRANSA.EQ.TRANAS
+ ISAME( 3 ) = TRANSB.EQ.TRANBS
+ ISAME( 4 ) = NS.EQ.N
+ ISAME( 5 ) = KS.EQ.K
+ ISAME( 6 ) = ALS.EQ.ALPHA
+ ISAME( 7 ) = LCE( AS, AA, LAA )
+ ISAME( 8 ) = LDAS.EQ.LDA
+ ISAME( 9 ) = LCE( BS, BB, LBB )
+ ISAME( 10 ) = LDBS.EQ.LDB
+ ISAME( 11 ) = BLS.EQ.BETA
+ IF( NULL )THEN
+ ISAME( 12 ) = LCE( CS, CC, LCC )
+ ELSE
+ ISAME( 12 ) = LCERES( 'ge', ' ', N, N, CS,
+ $ CC, LDC )
+ END IF
+ ISAME( 13 ) = LDCS.EQ.LDC
+*
+* If data was incorrectly changed, report
+* and return.
+*
+ SAME = .TRUE.
+ DO 40 I = 1, NARGS
+ SAME = SAME.AND.ISAME( I )
+ IF( .NOT.ISAME( I ) )
+ $ WRITE( NOUT, FMT = 9998 )I
+ 40 CONTINUE
+ IF( .NOT.SAME )THEN
+ FATAL = .TRUE.
+ GO TO 120
+ END IF
+*
+ IF( .NOT.NULL )THEN
+*
+* Check the result.
+*
+ CALL CMMTCH( UPLO, TRANSA, TRANSB, N, K,
+ $ ALPHA, A, NMAX, B, NMAX, BETA,
+ $ C, NMAX, CT, G, CC, LDC, EPS,
+ $ ERR, FATAL, NOUT, .TRUE. )
+ ERRMAX = MAX( ERRMAX, ERR )
+* If got really bad answer, report and
+* return.
+ IF( FATAL )
+ $ GO TO 120
+ END IF
+*
+ 45 CONTINUE
+*
+ 50 CONTINUE
+*
+ 60 CONTINUE
+*
+ 70 CONTINUE
+*
+ 80 CONTINUE
+*
+ 90 CONTINUE
+*
+ 100 CONTINUE
+*
+*
+* Report result.
+*
+ IF( ERRMAX.LT.THRESH )THEN
+ IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC
+ IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC
+ ELSE
+ IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
+ IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
+ END IF
+ GO TO 130
+*
+ 120 CONTINUE
+ WRITE( NOUT, FMT = 9996 )SNAME
+ CALL CPRCN8(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, TRANSB,
+ $ N, K, ALPHA, LDA, LDB, BETA, LDC)
+*
+ 130 CONTINUE
+ RETURN
+*
+10003 FORMAT( ' ', A13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
+ $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
+ $ 'RATIO ', F8.2, ' - SUSPECT *******' )
+10002 FORMAT( ' ', A13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
+ $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
+ $ 'RATIO ', F8.2, ' - SUSPECT *******' )
+10001 FORMAT( ' ', A13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
+ $ ' (', I6, ' CALL', 'S)' )
+10000 FORMAT( ' ', A13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
+ $ ' (', I6, ' CALL', 'S)' )
+ 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
+ $ 'ANGED INCORRECTLY *******' )
+ 9996 FORMAT( ' ******* ', A13,' FAILED ON CALL NUMBER:' )
+ 9995 FORMAT( 1X, I6, ': ', A13,'(''', A1, ''',''', A1, ''',',
+ $ 3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3,
+ $ ',(', F4.1, ',', F4.1, '), C,', I3, ').' )
+ 9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
+ $ '******' )
+*
+* End of CCHK6.
+*
+ END
+
+ SUBROUTINE CPRCN8(NOUT, NC, SNAME, IORDER, UPLO,
+ $ TRANSA, TRANSB, N,
+ $ K, ALPHA, LDA, LDB, BETA, LDC)
+ INTEGER NOUT, NC, IORDER, N, K, LDA, LDB, LDC
+ COMPLEX ALPHA, BETA
+ CHARACTER*1 TRANSA, TRANSB, UPLO
+ CHARACTER*13 SNAME
+ CHARACTER*14 CRC, CTA,CTB,CUPLO
+
+ IF (UPLO.EQ.'U') THEN
+ CUPLO = 'CblasUpper'
+ ELSE
+ CUPLO = 'CblasLower'
+ END IF
+ IF (TRANSA.EQ.'N')THEN
+ CTA = ' CblasNoTrans'
+ ELSE IF (TRANSA.EQ.'T')THEN
+ CTA = ' CblasTrans'
+ ELSE
+ CTA = 'CblasConjTrans'
+ END IF
+ IF (TRANSB.EQ.'N')THEN
+ CTB = ' CblasNoTrans'
+ ELSE IF (TRANSB.EQ.'T')THEN
+ CTB = ' CblasTrans'
+ ELSE
+ CTB = 'CblasConjTrans'
+ END IF
+ IF (IORDER.EQ.1)THEN
+ CRC = ' CblasRowMajor'
+ ELSE
+ CRC = ' CblasColMajor'
+ END IF
+ WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CUPLO, CTA,CTB
+ WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, LDB, BETA, LDC
+
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', A14, ',', A14, ',', A14, ',',
+ $ A14, ',')
+ 9994 FORMAT( 10X, 2( I3, ',' ) ,' (', F4.1,',',F4.1,') , A,',
+ $ I3, ', B,', I3, ', (', F4.1,',',F4.1,') , C,', I3, ').' )
+ END
+
+ SUBROUTINE CMMTCH(UPLO, TRANSA, TRANSB, N, KK, ALPHA, A, LDA,
+ $ B, LDB,
+ $ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL,
+ $ NOUT, MV )
+ IMPLICIT NONE
+*
+* Checks the results of the computational tests for GEMMTR.
+*
+* Auxiliary routine for test program for Level 3 Blas.
+*
+* -- Written on 24-June-2024.
+* Martin Koehler, Max Planck Institute, Magdeburg
+*
+* .. Parameters ..
+ COMPLEX ZERO
+ PARAMETER ( ZERO = ( 0.0, 0.0 ) )
+ REAL RZERO, RONE
+ PARAMETER ( RZERO = 0.0, RONE = 1.0 )
+* .. Scalar Arguments ..
+ COMPLEX ALPHA, BETA
+ REAL EPS, ERR
+ INTEGER KK, LDA, LDB, LDC, LDCC, N, NOUT
+ LOGICAL FATAL, MV
+ CHARACTER*1 TRANSA, TRANSB, UPLO
+* .. Array Arguments ..
+ COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ),
+ $ CC( LDCC, * ), CT( * )
+ REAL G( * )
+* .. Local Scalars ..
+ COMPLEX CL
+ REAL ERRI
+ INTEGER I, J, K, ISTART, ISTOP
+ LOGICAL CTRANA, CTRANB, TRANA, TRANB, UPPER
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, AIMAG, CONJG, MAX, REAL, SQRT
+* .. Statement Functions ..
+ REAL ABS1
+* .. Statement Function definitions ..
+ ABS1( CL ) = ABS( REAL( CL ) ) + ABS( AIMAG( CL ) )
+* .. Executable Statements ..
+
+ UPPER = UPLO.EQ.'U'
+ TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
+ TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
+ CTRANA = TRANSA.EQ.'C'
+ CTRANB = TRANSB.EQ.'C'
+
+ ISTART = 1
+ ISTOP = N
+*
+* Compute expected result, one column at a time, in CT using data
+* in A, B and C.
+* Compute gauges in G.
+*
+ DO 220 J = 1, N
+*
+ IF (UPPER) THEN
+ ISTART = 1
+ ISTOP = J
+ ELSE
+ ISTART = J
+ ISTOP = N
+ END IF
+ DO 10 I = ISTART, ISTOP
+ CT( I ) = ZERO
+ G( I ) = RZERO
+ 10 CONTINUE
+ IF( .NOT.TRANA.AND..NOT.TRANB )THEN
+ DO 30 K = 1, KK
+ DO 20 I = ISTART, ISTOP
+ CT( I ) = CT( I ) + A( I, K )*B( K, J )
+ G( I ) = G( I ) + ABS1( A( I, K ) )*ABS1( B( K, J ) )
+ 20 CONTINUE
+ 30 CONTINUE
+ ELSE IF( TRANA.AND..NOT.TRANB )THEN
+ IF( CTRANA )THEN
+ DO 50 K = 1, KK
+ DO 40 I = ISTART, ISTOP
+ CT( I ) = CT( I ) + CONJG( A( K, I ) )*B( K, J )
+ G( I ) = G( I ) + ABS1( A( K, I ) )*
+ $ ABS1( B( K, J ) )
+ 40 CONTINUE
+ 50 CONTINUE
+ ELSE
+ DO 70 K = 1, KK
+ DO 60 I = ISTART, ISTOP
+ CT( I ) = CT( I ) + A( K, I )*B( K, J )
+ G( I ) = G( I ) + ABS1( A( K, I ) )*
+ $ ABS1( B( K, J ) )
+ 60 CONTINUE
+ 70 CONTINUE
+ END IF
+ ELSE IF( .NOT.TRANA.AND.TRANB )THEN
+ IF( CTRANB )THEN
+ DO 90 K = 1, KK
+ DO 80 I = ISTART, ISTOP
+ CT( I ) = CT( I ) + A( I, K )*CONJG( B( J, K ) )
+ G( I ) = G( I ) + ABS1( A( I, K ) )*
+ $ ABS1( B( J, K ) )
+ 80 CONTINUE
+ 90 CONTINUE
+ ELSE
+ DO 110 K = 1, KK
+ DO 100 I = ISTART, ISTOP
+ CT( I ) = CT( I ) + A( I, K )*B( J, K )
+ G( I ) = G( I ) + ABS1( A( I, K ) )*
+ $ ABS1( B( J, K ) )
+ 100 CONTINUE
+ 110 CONTINUE
+ END IF
+ ELSE IF( TRANA.AND.TRANB )THEN
+ IF( CTRANA )THEN
+ IF( CTRANB )THEN
+ DO 130 K = 1, KK
+ DO 120 I = ISTART, ISTOP
+ CT( I ) = CT( I ) + CONJG( A( K, I ) )*
+ $ CONJG( B( J, K ) )
+ G( I ) = G( I ) + ABS1( A( K, I ) )*
+ $ ABS1( B( J, K ) )
+ 120 CONTINUE
+ 130 CONTINUE
+ ELSE
+ DO 150 K = 1, KK
+ DO 140 I = ISTART, ISTOP
+ CT( I ) = CT( I ) + CONJG( A( K, I ) )*B( J, K )
+ G( I ) = G( I ) + ABS1( A( K, I ) )*
+ $ ABS1( B( J, K ) )
+ 140 CONTINUE
+ 150 CONTINUE
+ END IF
+ ELSE
+ IF( CTRANB )THEN
+ DO 170 K = 1, KK
+ DO 160 I = ISTART, ISTOP
+ CT( I ) = CT( I ) + A( K, I )*CONJG( B( J, K ) )
+ G( I ) = G( I ) + ABS1( A( K, I ) )*
+ $ ABS1( B( J, K ) )
+ 160 CONTINUE
+ 170 CONTINUE
+ ELSE
+ DO 190 K = 1, KK
+ DO 180 I = ISTART, ISTOP
+ CT( I ) = CT( I ) + A( K, I )*B( J, K )
+ G( I ) = G( I ) + ABS1( A( K, I ) )*
+ $ ABS1( B( J, K ) )
+ 180 CONTINUE
+ 190 CONTINUE
+ END IF
+ END IF
+ END IF
+ DO 200 I = ISTART, ISTOP
+ CT( I ) = ALPHA*CT( I ) + BETA*C( I, J )
+ G( I ) = ABS1( ALPHA )*G( I ) +
+ $ ABS1( BETA )*ABS1( C( I, J ) )
+ 200 CONTINUE
+*
+* Compute the error ratio for this result.
+*
+ ERR = ZERO
+ DO 210 I = ISTART, ISTOP
+ ERRI = ABS1( CT( I ) - CC( I, J ) )/EPS
+ IF( G( I ).NE.RZERO )
+ $ ERRI = ERRI/G( I )
+ ERR = MAX( ERR, ERRI )
+ IF( ERR*SQRT( EPS ).GE.RONE )
+ $ GO TO 230
+ 210 CONTINUE
+*
+ 220 CONTINUE
+*
+* If the loop completes, all results are at least half accurate.
+ GO TO 250
+*
+* Report fatal error.
+*
+ 230 FATAL = .TRUE.
+ WRITE( NOUT, FMT = 9999 )
+ DO 240 I = ISTART, ISTOP
+ IF( MV )THEN
+ WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J )
+ ELSE
+ WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I )
+ END IF
+ 240 CONTINUE
+ IF( N.GT.1 )
+ $ WRITE( NOUT, FMT = 9997 )J
+*
+ 250 CONTINUE
+ RETURN
+*
+ 9999 FORMAT(' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
+ $ 'F ACCURATE *******', /' EXPECTED RE',
+ $ 'SULT COMPUTED RESULT' )
+ 9998 FORMAT( 1X, I7, 2( ' (', G15.6, ',', G15.6, ')' ) )
+ 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
+*
+* End of CMMTCH.
+*
+ END
+
diff --git a/ctest/c_dblas3.c b/ctest/c_dblas3.c
index 936dea8d9c..702ead3389 100644
--- a/ctest/c_dblas3.c
+++ b/ctest/c_dblas3.c
@@ -5,55 +5,58 @@
* Modified by T. H. Do, 2/19/98, SGI/CRAY Research.
*/
#include <stdlib.h>
-#include "common.h"
+#include "cblas.h"
#include "cblas_test.h"
-
#define TEST_COL_MJR 0
#define TEST_ROW_MJR 1
#define UNDEFINED -1
-void F77_dgemm(int *order, char *transpa, char *transpb, int *m, int *n,
+void F77_dgemm(int *layout, char *transpa, char *transpb, int *m, int *n,
int *k, double *alpha, double *a, int *lda, double *b, int *ldb,
- double *beta, double *c, int *ldc ) {
+ double *beta, double *c, int *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN transpa_len, FORTRAN_STRLEN transpb_len
+#endif
+) {
double *A, *B, *C;
int i,j,LDA, LDB, LDC;
- enum CBLAS_TRANSPOSE transa, transb;
+ CBLAS_TRANSPOSE transa, transb;
get_transpose_type(transpa, &transa);
get_transpose_type(transpb, &transb);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (transa == CblasNoTrans) {
LDA = *k+1;
- A = (double *)malloc( (*m)*(size_t)LDA*sizeof( double ) );
+ A = (double *)malloc( (*m)*LDA*sizeof( double ) );
for( i=0; i<*m; i++ )
for( j=0; j<*k; j++ )
A[i*LDA+j]=a[j*(*lda)+i];
}
else {
LDA = *m+1;
- A = ( double* )malloc( (size_t)LDA*(*k)*sizeof( double ) );
+ A = ( double* )malloc( LDA*(*k)*sizeof( double ) );
for( i=0; i<*k; i++ )
for( j=0; j<*m; j++ )
A[i*LDA+j]=a[j*(*lda)+i];
}
if (transb == CblasNoTrans) {
LDB = *n+1;
- B = ( double* )malloc( (*k)*(size_t)LDB*sizeof( double ) );
+ B = ( double* )malloc( (*k)*LDB*sizeof( double ) );
for( i=0; i<*k; i++ )
for( j=0; j<*n; j++ )
B[i*LDB+j]=b[j*(*ldb)+i];
}
else {
LDB = *k+1;
- B = ( double* )malloc( (size_t)LDB*(*n)*sizeof( double ) );
+ B = ( double* )malloc( LDB*(*n)*sizeof( double ) );
for( i=0; i<*n; i++ )
for( j=0; j<*k; j++ )
B[i*LDB+j]=b[j*(*ldb)+i];
}
LDC = *n+1;
- C = ( double* )malloc( (*m)*(size_t)LDC*sizeof( double ) );
+ C = ( double* )malloc( (*m)*LDC*sizeof( double ) );
for( j=0; j<*n; j++ )
for( i=0; i<*m; i++ )
C[i*LDC+j]=c[j*(*ldc)+i];
@@ -67,47 +70,130 @@ void F77_dgemm(int *order, char *transpa, char *transpb, int *m, int *n,
free(B);
free(C);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_dgemm( CblasColMajor, transa, transb, *m, *n, *k, *alpha, a, *lda,
b, *ldb, *beta, c, *ldc );
else
cblas_dgemm( UNDEFINED, transa, transb, *m, *n, *k, *alpha, a, *lda,
b, *ldb, *beta, c, *ldc );
}
-void F77_dsymm(int *order, char *rtlf, char *uplow, int *m, int *n,
+
+void F77_dgemmtr(int *layout, char *uplop, char *transpa, char *transpb, int *n,
+ int *k, double *alpha, double *a, int *lda,
+ double *b, int *ldb, double *beta,
+ double *c, int *ldc ) {
+
+ double *A, *B, *C;
+ int i,j,LDA, LDB, LDC;
+ CBLAS_TRANSPOSE transa, transb;
+ CBLAS_UPLO uplo;
+
+ get_transpose_type(transpa, &transa);
+ get_transpose_type(transpb, &transb);
+ get_uplo_type(uplop, &uplo);
+
+ if (*layout == TEST_ROW_MJR) {
+ if (transa == CblasNoTrans) {
+ LDA = *k+1;
+ A=(double*)malloc((*n)*LDA*sizeof(double));
+ for( i=0; i<*n; i++ )
+ for( j=0; j<*k; j++ ) {
+ A[i*LDA+j]=a[j*(*lda)+i];
+ }
+ }
+ else {
+ LDA = *n+1;
+ A=(double* )malloc(LDA*(*k)*sizeof(double));
+ for( i=0; i<*k; i++ )
+ for( j=0; j<*n; j++ ) {
+ A[i*LDA+j]=a[j*(*lda)+i];
+ }
+ }
+
+ if (transb == CblasNoTrans) {
+ LDB = *n+1;
+ B=(double* )malloc((*k)*LDB*sizeof(double) );
+ for( i=0; i<*k; i++ )
+ for( j=0; j<*n; j++ ) {
+ B[i*LDB+j]=b[j*(*ldb)+i];
+ }
+ }
+ else {
+ LDB = *k+1;
+ B=(double* )malloc(LDB*(*n)*sizeof(double));
+ for( i=0; i<*n; i++ )
+ for( j=0; j<*k; j++ ) {
+ B[i*LDB+j]=b[j*(*ldb)+i];
+ }
+ }
+
+ LDC = *n+1;
+ C=(double* )malloc((*n)*LDC*sizeof(double));
+ for( j=0; j<*n; j++ )
+ for( i=0; i<*n; i++ ) {
+ C[i*LDC+j]=c[j*(*ldc)+i];
+ }
+ cblas_dgemmtr( CblasRowMajor, uplo, transa, transb, *n, *k, *alpha, A, LDA,
+ B, LDB, *beta, C, LDC );
+ for( j=0; j<*n; j++ )
+ for( i=0; i<*n; i++ ) {
+ c[j*(*ldc)+i]=C[i*LDC+j];
+ }
+ free(A);
+ free(B);
+ free(C);
+ }
+ else if (*layout == TEST_COL_MJR){
+ cblas_dgemmtr( CblasColMajor, uplo, transa, transb, *n, *k, *alpha, a, *lda,
+ b, *ldb, *beta, c, *ldc );
+ }
+ else
+ cblas_dgemmtr( UNDEFINED, uplo, transa, transb, *n, *k, *alpha, a, *lda,
+ b, *ldb, *beta, c, *ldc );
+}
+
+
+
+
+
+void F77_dsymm(int *layout, char *rtlf, char *uplow, int *m, int *n,
double *alpha, double *a, int *lda, double *b, int *ldb,
- double *beta, double *c, int *ldc ) {
+ double *beta, double *c, int *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len
+#endif
+) {
double *A, *B, *C;
int i,j,LDA, LDB, LDC;
- enum CBLAS_UPLO uplo;
- enum CBLAS_SIDE side;
+ CBLAS_UPLO uplo;
+ CBLAS_SIDE side;
get_uplo_type(uplow,&uplo);
get_side_type(rtlf,&side);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (side == CblasLeft) {
LDA = *m+1;
- A = ( double* )malloc( (*m)*(size_t)LDA*sizeof( double ) );
+ A = ( double* )malloc( (*m)*LDA*sizeof( double ) );
for( i=0; i<*m; i++ )
for( j=0; j<*m; j++ )
A[i*LDA+j]=a[j*(*lda)+i];
}
else{
LDA = *n+1;
- A = ( double* )malloc( (*n)*(size_t)LDA*sizeof( double ) );
+ A = ( double* )malloc( (*n)*LDA*sizeof( double ) );
for( i=0; i<*n; i++ )
for( j=0; j<*n; j++ )
A[i*LDA+j]=a[j*(*lda)+i];
}
LDB = *n+1;
- B = ( double* )malloc( (*m)*(size_t)LDB*sizeof( double ) );
+ B = ( double* )malloc( (*m)*LDB*sizeof( double ) );
for( i=0; i<*m; i++ )
for( j=0; j<*n; j++ )
B[i*LDB+j]=b[j*(*ldb)+i];
LDC = *n+1;
- C = ( double* )malloc( (*m)*(size_t)LDC*sizeof( double ) );
+ C = ( double* )malloc( (*m)*LDC*sizeof( double ) );
for( j=0; j<*n; j++ )
for( i=0; i<*m; i++ )
C[i*LDC+j]=c[j*(*ldc)+i];
@@ -120,7 +206,7 @@ void F77_dsymm(int *order, char *rtlf, char *uplow, int *m, int *n,
free(B);
free(C);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_dsymm( CblasColMajor, side, uplo, *m, *n, *alpha, a, *lda, b, *ldb,
*beta, c, *ldc );
else
@@ -128,35 +214,39 @@ void F77_dsymm(int *order, char *rtlf, char *uplow, int *m, int *n,
*beta, c, *ldc );
}
-void F77_dsyrk(int *order, char *uplow, char *transp, int *n, int *k,
+void F77_dsyrk(int *layout, char *uplow, char *transp, int *n, int *k,
double *alpha, double *a, int *lda,
- double *beta, double *c, int *ldc ) {
+ double *beta, double *c, int *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len
+#endif
+) {
int i,j,LDA,LDC;
double *A, *C;
- enum CBLAS_UPLO uplo;
- enum CBLAS_TRANSPOSE trans;
+ CBLAS_UPLO uplo;
+ CBLAS_TRANSPOSE trans;
get_uplo_type(uplow,&uplo);
get_transpose_type(transp,&trans);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (trans == CblasNoTrans) {
LDA = *k+1;
- A = ( double* )malloc( (*n)*(size_t)LDA*sizeof( double ) );
+ A = ( double* )malloc( (*n)*LDA*sizeof( double ) );
for( i=0; i<*n; i++ )
for( j=0; j<*k; j++ )
A[i*LDA+j]=a[j*(*lda)+i];
}
else{
LDA = *n+1;
- A = ( double* )malloc( (*k)*(size_t)LDA*sizeof( double ) );
+ A = ( double* )malloc( (*k)*LDA*sizeof( double ) );
for( i=0; i<*k; i++ )
for( j=0; j<*n; j++ )
A[i*LDA+j]=a[j*(*lda)+i];
}
LDC = *n+1;
- C = ( double* )malloc( (*n)*(size_t)LDC*sizeof( double ) );
+ C = ( double* )malloc( (*n)*LDC*sizeof( double ) );
for( i=0; i<*n; i++ )
for( j=0; j<*n; j++ )
C[i*LDC+j]=c[j*(*ldc)+i];
@@ -168,7 +258,7 @@ void F77_dsyrk(int *order, char *uplow, char *transp, int *n, int *k,
free(A);
free(C);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_dsyrk(CblasColMajor, uplo, trans, *n, *k, *alpha, a, *lda, *beta,
c, *ldc );
else
@@ -176,23 +266,27 @@ void F77_dsyrk(int *order, char *uplow, char *transp, int *n, int *k,
c, *ldc );
}
-void F77_dsyr2k(int *order, char *uplow, char *transp, int *n, int *k,
+void F77_dsyr2k(int *layout, char *uplow, char *transp, int *n, int *k,
double *alpha, double *a, int *lda, double *b, int *ldb,
- double *beta, double *c, int *ldc ) {
+ double *beta, double *c, int *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len
+#endif
+) {
int i,j,LDA,LDB,LDC;
double *A, *B, *C;
- enum CBLAS_UPLO uplo;
- enum CBLAS_TRANSPOSE trans;
+ CBLAS_UPLO uplo;
+ CBLAS_TRANSPOSE trans;
get_uplo_type(uplow,&uplo);
get_transpose_type(transp,&trans);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (trans == CblasNoTrans) {
LDA = *k+1;
LDB = *k+1;
- A = ( double* )malloc( (*n)*(size_t)LDA*sizeof( double ) );
- B = ( double* )malloc( (*n)*(size_t)LDB*sizeof( double ) );
+ A = ( double* )malloc( (*n)*LDA*sizeof( double ) );
+ B = ( double* )malloc( (*n)*LDB*sizeof( double ) );
for( i=0; i<*n; i++ )
for( j=0; j<*k; j++ ) {
A[i*LDA+j]=a[j*(*lda)+i];
@@ -202,8 +296,8 @@ void F77_dsyr2k(int *order, char *uplow, char *transp, int *n, int *k,
else {
LDA = *n+1;
LDB = *n+1;
- A = ( double* )malloc( (size_t)LDA*(*k)*sizeof( double ) );
- B = ( double* )malloc( (size_t)LDB*(*k)*sizeof( double ) );
+ A = ( double* )malloc( LDA*(*k)*sizeof( double ) );
+ B = ( double* )malloc( LDB*(*k)*sizeof( double ) );
for( i=0; i<*k; i++ )
for( j=0; j<*n; j++ ){
A[i*LDA+j]=a[j*(*lda)+i];
@@ -211,7 +305,7 @@ void F77_dsyr2k(int *order, char *uplow, char *transp, int *n, int *k,
}
}
LDC = *n+1;
- C = ( double* )malloc( (*n)*(size_t)LDC*sizeof( double ) );
+ C = ( double* )malloc( (*n)*LDC*sizeof( double ) );
for( i=0; i<*n; i++ )
for( j=0; j<*n; j++ )
C[i*LDC+j]=c[j*(*ldc)+i];
@@ -224,45 +318,49 @@ void F77_dsyr2k(int *order, char *uplow, char *transp, int *n, int *k,
free(B);
free(C);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_dsyr2k(CblasColMajor, uplo, trans, *n, *k, *alpha, a, *lda,
b, *ldb, *beta, c, *ldc );
else
cblas_dsyr2k(UNDEFINED, uplo, trans, *n, *k, *alpha, a, *lda,
b, *ldb, *beta, c, *ldc );
}
-void F77_dtrmm(int *order, char *rtlf, char *uplow, char *transp, char *diagn,
+void F77_dtrmm(int *layout, char *rtlf, char *uplow, char *transp, char *diagn,
int *m, int *n, double *alpha, double *a, int *lda, double *b,
- int *ldb) {
+ int *ldb
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diag_len
+#endif
+) {
int i,j,LDA,LDB;
double *A, *B;
- enum CBLAS_SIDE side;
- enum CBLAS_DIAG diag;
- enum CBLAS_UPLO uplo;
- enum CBLAS_TRANSPOSE trans;
+ CBLAS_SIDE side;
+ CBLAS_DIAG diag;
+ CBLAS_UPLO uplo;
+ CBLAS_TRANSPOSE trans;
get_uplo_type(uplow,&uplo);
get_transpose_type(transp,&trans);
get_diag_type(diagn,&diag);
get_side_type(rtlf,&side);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (side == CblasLeft) {
LDA = *m+1;
- A = ( double* )malloc( (*m)*(size_t)LDA*sizeof( double ) );
+ A = ( double* )malloc( (*m)*LDA*sizeof( double ) );
for( i=0; i<*m; i++ )
for( j=0; j<*m; j++ )
A[i*LDA+j]=a[j*(*lda)+i];
}
else{
LDA = *n+1;
- A = ( double* )malloc( (*n)*(size_t)LDA*sizeof( double ) );
+ A = ( double* )malloc( (*n)*LDA*sizeof( double ) );
for( i=0; i<*n; i++ )
for( j=0; j<*n; j++ )
A[i*LDA+j]=a[j*(*lda)+i];
}
LDB = *n+1;
- B = ( double* )malloc( (*m)*(size_t)LDB*sizeof( double ) );
+ B = ( double* )malloc( (*m)*LDB*sizeof( double ) );
for( i=0; i<*m; i++ )
for( j=0; j<*n; j++ )
B[i*LDB+j]=b[j*(*ldb)+i];
@@ -274,7 +372,7 @@ void F77_dtrmm(int *order, char *rtlf, char *uplow, char *transp, char *diagn,
free(A);
free(B);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_dtrmm(CblasColMajor, side, uplo, trans, diag, *m, *n, *alpha,
a, *lda, b, *ldb);
else
@@ -282,38 +380,42 @@ void F77_dtrmm(int *order, char *rtlf, char *uplow, char *transp, char *diagn,
a, *lda, b, *ldb);
}
-void F77_dtrsm(int *order, char *rtlf, char *uplow, char *transp, char *diagn,
+void F77_dtrsm(int *layout, char *rtlf, char *uplow, char *transp, char *diagn,
int *m, int *n, double *alpha, double *a, int *lda, double *b,
- int *ldb) {
+ int *ldb
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
int i,j,LDA,LDB;
double *A, *B;
- enum CBLAS_SIDE side;
- enum CBLAS_DIAG diag;
- enum CBLAS_UPLO uplo;
- enum CBLAS_TRANSPOSE trans;
+ CBLAS_SIDE side;
+ CBLAS_DIAG diag;
+ CBLAS_UPLO uplo;
+ CBLAS_TRANSPOSE trans;
get_uplo_type(uplow,&uplo);
get_transpose_type(transp,&trans);
get_diag_type(diagn,&diag);
get_side_type(rtlf,&side);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (side == CblasLeft) {
LDA = *m+1;
- A = ( double* )malloc( (*m)*(size_t)LDA*sizeof( double ) );
+ A = ( double* )malloc( (*m)*LDA*sizeof( double ) );
for( i=0; i<*m; i++ )
for( j=0; j<*m; j++ )
A[i*LDA+j]=a[j*(*lda)+i];
}
else{
LDA = *n+1;
- A = ( double* )malloc( (*n)*(size_t)LDA*sizeof( double ) );
+ A = ( double* )malloc( (*n)*LDA*sizeof( double ) );
for( i=0; i<*n; i++ )
for( j=0; j<*n; j++ )
A[i*LDA+j]=a[j*(*lda)+i];
}
LDB = *n+1;
- B = ( double* )malloc( (*m)*(size_t)LDB*sizeof( double ) );
+ B = ( double* )malloc( (*m)*LDB*sizeof( double ) );
for( i=0; i<*m; i++ )
for( j=0; j<*n; j++ )
B[i*LDB+j]=b[j*(*ldb)+i];
@@ -325,7 +427,7 @@ void F77_dtrsm(int *order, char *rtlf, char *uplow, char *transp, char *diagn,
free(A);
free(B);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_dtrsm(CblasColMajor, side, uplo, trans, diag, *m, *n, *alpha,
a, *lda, b, *ldb);
else
diff --git a/ctest/c_dblat3.f b/ctest/c_dblat3.f
index cbd95b8544..e88a77dc7b 100644
--- a/ctest/c_dblat3.f
+++ b/ctest/c_dblat3.f
@@ -4,13 +4,13 @@ PROGRAM DBLAT3
*
* 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
+* are read using the format ( A13, 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 ERROR STOP ON FAILURES.
+* 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
@@ -20,12 +20,13 @@ PROGRAM DBLAT3
* 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.
+* 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.
+* cblas_dgemmtr T PUT F FOR NO TEST. SAME COLUMNS.
*
* See:
*
@@ -46,7 +47,7 @@ PROGRAM DBLAT3
INTEGER NIN, NOUT
PARAMETER ( NIN = 5, NOUT = 6 )
INTEGER NSUBS
- PARAMETER ( NSUBS = 6 )
+ PARAMETER ( NSUBS = 7 )
DOUBLE PRECISION ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
INTEGER NMAX
@@ -56,11 +57,11 @@ PROGRAM DBLAT3
* .. Local Scalars ..
DOUBLE PRECISION EPS, ERR, THRESH
INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NTRA,
- $ LAYOUT
+ $ LAYOUT
LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
$ TSTERR, CORDER, RORDER
CHARACTER*1 TRANSA, TRANSB
- CHARACTER*12 SNAMET
+ CHARACTER*13 SNAMET
CHARACTER*32 SNAPS
* .. Local Arrays ..
DOUBLE PRECISION AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ),
@@ -71,27 +72,27 @@ PROGRAM DBLAT3
$ G( NMAX ), W( 2*NMAX )
INTEGER IDIM( NIDMAX )
LOGICAL LTEST( NSUBS )
- CHARACTER*12 SNAMES( NSUBS )
+ CHARACTER*13 SNAMES( NSUBS )
* .. External Functions ..
DOUBLE PRECISION DDIFF
LOGICAL LDE
EXTERNAL DDIFF, LDE
* .. External Subroutines ..
EXTERNAL DCHK1, DCHK2, DCHK3, DCHK4, DCHK5, CD3CHKE,
- $ DMMCH
+ $ DMMCH
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL OK
- CHARACTER*12 SRNAMT
+ CHARACTER*13 SRNAMT
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK
COMMON /SRNAMC/SRNAMT
* .. Data statements ..
DATA SNAMES/'cblas_dgemm ', 'cblas_dsymm ',
$ 'cblas_dtrmm ', 'cblas_dtrsm ','cblas_dsyrk ',
- $ 'cblas_dsyr2k'/
+ $ 'cblas_dsyr2k', 'cblas_dgemmtr'/
* .. Executable Statements ..
*
* Read name and unit number for summary output file and open file.
@@ -189,7 +190,7 @@ PROGRAM DBLAT3
$ GO TO 50
40 CONTINUE
WRITE( NOUT, FMT = 9990 )SNAMET
- ERROR STOP
+ STOP
50 LTEST( I ) = LTESTT
GO TO 30
*
@@ -232,7 +233,7 @@ PROGRAM DBLAT3
SAME = LDE( CC, CT, N )
IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
- ERROR STOP
+ STOP
END IF
TRANSB = 'T'
CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
@@ -241,7 +242,7 @@ PROGRAM DBLAT3
SAME = LDE( CC, CT, N )
IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
- ERROR STOP
+ STOP
END IF
DO 120 J = 1, N
AB( J, NMAX + 1 ) = N - J + 1
@@ -259,7 +260,7 @@ PROGRAM DBLAT3
SAME = LDE( CC, CT, N )
IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
- ERROR STOP
+ STOP
END IF
TRANSB = 'T'
CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
@@ -268,7 +269,7 @@ PROGRAM DBLAT3
SAME = LDE( CC, CT, N )
IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
- ERROR STOP
+ STOP
END IF
*
* Test each subroutine in turn.
@@ -289,7 +290,7 @@ PROGRAM DBLAT3
INFOT = 0
OK = .TRUE.
FATAL = .FALSE.
- GO TO ( 140, 150, 160, 160, 170, 180 )ISNUM
+ GO TO ( 140, 150, 160, 160, 170, 180, 185 )ISNUM
* Test DGEMM, 01.
140 IF (CORDER) THEN
CALL DCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
@@ -323,13 +324,13 @@ PROGRAM DBLAT3
CALL DCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB,
$ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C,
- $ 0 )
+ $ 0 )
END IF
IF (RORDER) THEN
CALL DCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB,
$ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C,
- $ 1 )
+ $ 1 )
END IF
GO TO 190
* Test DSYRK, 05.
@@ -351,15 +352,30 @@ PROGRAM DBLAT3
CALL DCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
$ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W,
- $ 0 )
+ $ 0 )
END IF
IF (RORDER) THEN
CALL DCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
$ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W,
- $ 1 )
+ $ 1 )
END IF
GO TO 190
+* Test DGEMMTR, 07.
+ 185 IF (CORDER) THEN
+ CALL DCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
+ $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
+ $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W,
+ $ 0 )
+ END IF
+ IF (RORDER) THEN
+ CALL DCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
+ $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
+ $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W,
+ $ 1 )
+ END IF
+ GO TO 190
+
*
190 IF( FATAL.AND.SFATAL )
$ GO TO 210
@@ -379,9 +395,7 @@ PROGRAM DBLAT3
IF( TRACE )
$ CLOSE ( NTRA )
CLOSE ( NOUT )
- IF( FATAL ) THEN
- ERROR STOP
- END IF
+ STOP
*
10002 FORMAT( ' COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED' )
10001 FORMAT( ' ROW-MAJOR DATA LAYOUT IS TESTED' )
@@ -399,7 +413,7 @@ PROGRAM DBLAT3
9992 FORMAT( ' FOR BETA ', 7F6.1 )
9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
$ /' ******* TESTS ABANDONED *******' )
- 9990 FORMAT( ' SUBPROGRAM NAME ', A12,' NOT RECOGNIZED', /' ******* T',
+ 9990 FORMAT( ' SUBPROGRAM NAME ', A13,' NOT RECOGNIZED', /' ******* T',
$ 'ESTS ABANDONED *******' )
9989 FORMAT( ' ERROR IN DMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
$ 'ATED WRONGLY.', /' DMMCH WAS CALLED WITH TRANSA = ', A1,
@@ -407,8 +421,8 @@ PROGRAM DBLAT3
$ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ',
$ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ',
$ '*******' )
- 9988 FORMAT( A12,L2 )
- 9987 FORMAT( 1X, A12,' WAS NOT TESTED' )
+ 9988 FORMAT( A13,L2 )
+ 9987 FORMAT( 1X, A13,' WAS NOT TESTED' )
9986 FORMAT( /' END OF TESTS' )
9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
@@ -437,7 +451,7 @@ SUBROUTINE DCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
DOUBLE PRECISION EPS, THRESH
INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
LOGICAL FATAL, REWI, TRACE
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
* .. Array Arguments ..
DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), B( NMAX, NMAX ),
@@ -590,7 +604,7 @@ SUBROUTINE DCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$ REWIND NTRA
CALL CDGEMM( IORDER, TRANSA, TRANSB, M, N,
$ K, ALPHA, AA, LDA, BB, LDB,
- $ BETA, CC, LDC )
+ $ BETA, CC, LDC )
*
* Check if error-exit was taken incorrectly.
*
@@ -683,22 +697,22 @@ SUBROUTINE DCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
130 CONTINUE
RETURN
*
-10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
+10003 FORMAT( ' ', A13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
+10002 FORMAT( ' ', A13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
+10001 FORMAT( ' ', A13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
-10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
+10000 FORMAT( ' ', A13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
- 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
-C 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',',
-C $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ',
-C $ 'C,', I3, ').' )
+ 9996 FORMAT( ' ******* ', A13,' FAILED ON CALL NUMBER:' )
+ 9995 FORMAT( 1X, I6, ': ', A13,'(''', A1, ''',''', A1, ''',',
+ $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ',
+ $ 'C,', I3, ').' )
9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
@@ -710,7 +724,7 @@ SUBROUTINE DPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, M, N,
INTEGER NOUT, NC, IORDER, M, N, K, LDA, LDB, LDC
DOUBLE PRECISION ALPHA, BETA
CHARACTER*1 TRANSA, TRANSB
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
CHARACTER*14 CRC, CTA,CTB
IF (TRANSA.EQ.'N')THEN
@@ -735,7 +749,7 @@ SUBROUTINE DPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, M, N,
WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CTA,CTB
WRITE(NOUT, FMT = 9994)M, N, K, ALPHA, LDA, LDB, BETA, LDC
- 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',')
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', A14, ',', A14, ',', A14, ',')
9994 FORMAT( 20X, 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',',
$ F4.1, ', ', 'C,', I3, ').' )
END
@@ -761,7 +775,7 @@ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
DOUBLE PRECISION EPS, THRESH
INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
LOGICAL FATAL, REWI, TRACE
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
* .. Array Arguments ..
DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), B( NMAX, NMAX ),
@@ -996,22 +1010,22 @@ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
120 CONTINUE
RETURN
*
-10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
+10003 FORMAT( ' ', A13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
+10002 FORMAT( ' ', A13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
+10001 FORMAT( ' ', A13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
-10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
+10000 FORMAT( ' ', A13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
- 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
-C 9995 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
-C $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ',
-C $ ' .' )
+ 9996 FORMAT( ' ******* ', A13,' FAILED ON CALL NUMBER:' )
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
+ $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ',
+ $ ' .' )
9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
@@ -1024,7 +1038,7 @@ SUBROUTINE DPRCN2(NOUT, NC, SNAME, IORDER, SIDE, UPLO, M, N,
INTEGER NOUT, NC, IORDER, M, N, LDA, LDB, LDC
DOUBLE PRECISION ALPHA, BETA
CHARACTER*1 SIDE, UPLO
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
CHARACTER*14 CRC, CS,CU
IF (SIDE.EQ.'L')THEN
@@ -1045,7 +1059,7 @@ SUBROUTINE DPRCN2(NOUT, NC, SNAME, IORDER, SIDE, UPLO, M, N,
WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CS,CU
WRITE(NOUT, FMT = 9994)M, N, ALPHA, LDA, LDB, BETA, LDC
- 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',')
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', A14, ',', A14, ',', A14, ',')
9994 FORMAT( 20X, 2( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',',
$ F4.1, ', ', 'C,', I3, ').' )
END
@@ -1071,7 +1085,7 @@ SUBROUTINE DCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
DOUBLE PRECISION EPS, THRESH
INTEGER NALF, NIDIM, NMAX, NOUT, NTRA, IORDER
LOGICAL FATAL, REWI, TRACE
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
* .. Array Arguments ..
DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), B( NMAX, NMAX ),
@@ -1203,7 +1217,7 @@ SUBROUTINE DCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$ REWIND NTRA
CALL CDTRMM( IORDER, SIDE, UPLO, TRANSA,
$ DIAG, M, N, ALPHA, AA, LDA,
- $ BB, LDB )
+ $ BB, LDB )
ELSE IF( SNAME( 10: 11 ).EQ.'sm' )THEN
IF( TRACE )
$ CALL DPRCN3( NTRA, NC, SNAME, IORDER,
@@ -1213,7 +1227,7 @@ SUBROUTINE DCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$ REWIND NTRA
CALL CDTRSM( IORDER, SIDE, UPLO, TRANSA,
$ DIAG, M, N, ALPHA, AA, LDA,
- $ BB, LDB )
+ $ BB, LDB )
END IF
*
* Check if error-exit was taken incorrectly.
@@ -1344,21 +1358,21 @@ SUBROUTINE DCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
160 CONTINUE
RETURN
*
-10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
+10003 FORMAT( ' ', A13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
+10002 FORMAT( ' ', A13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
+10001 FORMAT( ' ', A13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
-10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
+10000 FORMAT( ' ', A13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
- 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
-C 9995 FORMAT( 1X, I6, ': ', A12,'(', 4( '''', A1, ''',' ), 2( I3, ',' ),
-C $ F4.1, ', A,', I3, ', B,', I3, ') .' )
+ 9996 FORMAT( ' ******* ', A13,' FAILED ON CALL NUMBER:' )
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', 4( '''', A1, ''',' ), 2( I3, ',' ),
+ $ F4.1, ', A,', I3, ', B,', I3, ') .' )
9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
@@ -1371,7 +1385,7 @@ SUBROUTINE DPRCN3(NOUT, NC, SNAME, IORDER, SIDE, UPLO, TRANSA,
INTEGER NOUT, NC, IORDER, M, N, LDA, LDB
DOUBLE PRECISION ALPHA
CHARACTER*1 SIDE, UPLO, TRANSA, DIAG
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
CHARACTER*14 CRC, CS, CU, CA, CD
IF (SIDE.EQ.'L')THEN
@@ -1404,7 +1418,7 @@ SUBROUTINE DPRCN3(NOUT, NC, SNAME, IORDER, SIDE, UPLO, TRANSA,
WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CS,CU
WRITE(NOUT, FMT = 9994)CA, CD, M, N, ALPHA, LDA, LDB
- 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',')
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', A14, ',', A14, ',', A14, ',')
9994 FORMAT( 22X, 2( A14, ',') , 2( I3, ',' ),
$ F4.1, ', A,', I3, ', B,', I3, ').' )
END
@@ -1430,7 +1444,7 @@ SUBROUTINE DCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
DOUBLE PRECISION EPS, THRESH
INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
LOGICAL FATAL, REWI, TRACE
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
* .. Array Arguments ..
DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), B( NMAX, NMAX ),
@@ -1669,22 +1683,22 @@ SUBROUTINE DCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
130 CONTINUE
RETURN
*
-10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
+10003 FORMAT( ' ', A13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
+10002 FORMAT( ' ', A13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
+10001 FORMAT( ' ', A13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
-10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
+10000 FORMAT( ' ', A13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
- 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
+ 9996 FORMAT( ' ******* ', A13,' FAILED ON CALL NUMBER:' )
9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
-C 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
-C $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' )
+ 9994 FORMAT( 1X, I6, ': ', A13,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
+ $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' )
9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
@@ -1697,7 +1711,7 @@ SUBROUTINE DPRCN4(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
INTEGER NOUT, NC, IORDER, N, K, LDA, LDC
DOUBLE PRECISION ALPHA, BETA
CHARACTER*1 UPLO, TRANSA
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
CHARACTER*14 CRC, CU, CA
IF (UPLO.EQ.'U')THEN
@@ -1720,7 +1734,7 @@ SUBROUTINE DPRCN4(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA
WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, BETA, LDC
- 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') )
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', 3( A14, ',') )
9994 FORMAT( 20X, 2( I3, ',' ),
$ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ').' )
END
@@ -1728,7 +1742,7 @@ SUBROUTINE DPRCN4(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
$ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W,
- $ IORDER )
+ $ IORDER )
*
* Tests DSYR2K.
*
@@ -1747,7 +1761,7 @@ SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
DOUBLE PRECISION EPS, THRESH
INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
LOGICAL FATAL, REWI, TRACE
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
* .. Array Arguments ..
DOUBLE PRECISION AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ),
$ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ),
@@ -1890,7 +1904,7 @@ SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$ REWIND NTRA
CALL CDSYR2K( IORDER, UPLO, TRANS, N, K,
$ ALPHA, AA, LDA, BB, LDB, BETA,
- $ CC, LDC )
+ $ CC, LDC )
*
* Check if error-exit was taken incorrectly.
*
@@ -2025,23 +2039,23 @@ SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
160 CONTINUE
RETURN
*
-10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
+10003 FORMAT( ' ', A13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
+10002 FORMAT( ' ', A13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
+10001 FORMAT( ' ', A13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
-10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
+10000 FORMAT( ' ', A13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
- 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
+ 9996 FORMAT( ' ******* ', A13,' FAILED ON CALL NUMBER:' )
9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
-C 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
-C $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ',
-C $ ' .' )
+ 9994 FORMAT( 1X, I6, ': ', A13,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
+ $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ',
+ $ ' .' )
9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
@@ -2054,7 +2068,7 @@ SUBROUTINE DPRCN5(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
INTEGER NOUT, NC, IORDER, N, K, LDA, LDB, LDC
DOUBLE PRECISION ALPHA, BETA
CHARACTER*1 UPLO, TRANSA
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
CHARACTER*14 CRC, CU, CA
IF (UPLO.EQ.'U')THEN
@@ -2077,7 +2091,7 @@ SUBROUTINE DPRCN5(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA
WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, LDB, BETA, LDC
- 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') )
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', 3( A14, ',') )
9994 FORMAT( 20X, 2( I3, ',' ),
$ F4.1, ', A,', I3, ', B', I3, ',', F4.1, ', C,', I3, ').' )
END
@@ -2401,7 +2415,7 @@ LOGICAL FUNCTION LDERES( TYPE, UPLO, M, N, AA, AS, LDA )
50 CONTINUE
END IF
*
-C 60 CONTINUE
+ 60 CONTINUE
LDERES = .TRUE.
GO TO 80
70 CONTINUE
@@ -2476,3 +2490,474 @@ DOUBLE PRECISION FUNCTION DDIFF( X, Y )
* End of DDIFF.
*
END
+
+ SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
+ $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
+ $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G,
+ $ IORDER)
+*
+* Tests DGEMMTR.
+*
+* Auxiliary routine for test program for Level 3 Blas.
+*
+* -- Written on 19-July-2023.
+* Martin Koehler, MPI Magdeburg
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D0 )
+* .. Scalar Arguments ..
+ DOUBLE PRECISION EPS, THRESH
+ INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
+ LOGICAL FATAL, REWI, TRACE
+ CHARACTER*13 SNAME
+* .. Array Arguments ..
+ DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
+ $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
+ $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
+ $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
+ $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
+ INTEGER IDIM( NIDIM )
+* .. Local Scalars ..
+ DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX
+ INTEGER I, IA, IB, ICA, ICB, IK, IN, K, KS, LAA,
+ $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS,
+ $ MA, MB, N, NA, NARGS, NB, NC, NS, IS
+ LOGICAL NULL, RESET, SAME, TRANA, TRANB
+ CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB, UPLO, UPLOS
+ CHARACTER*3 ICH
+ CHARACTER*2 ISHAPE
+* .. Local Arrays ..
+ LOGICAL ISAME( 13 )
+* .. External Functions ..
+ LOGICAL LDE, LDERES
+ EXTERNAL LDE, LDERES
+* .. External Subroutines ..
+ EXTERNAL CDGEMMTR, DMAKE, DMMTCH
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* .. Scalars in Common ..
+ INTEGER INFOT, NOUTC
+ LOGICAL LERR, OK
+* .. Common blocks ..
+ COMMON /INFOC/INFOT, NOUTC, OK, LERR
+* .. Data statements ..
+ DATA ICH/'NTC'/
+ DATA ISHAPE/'UL'/
+* .. Executable Statements ..
+*
+ NARGS = 13
+ NC = 0
+ RESET = .TRUE.
+ ERRMAX = ZERO
+*
+ DO 100 IN = 1, NIDIM
+ N = IDIM( IN )
+* Set LDC to 1 more than minimum value if room.
+ LDC = N
+ IF( LDC.LT.NMAX )
+ $ LDC = LDC + 1
+* Skip tests if not enough room.
+ IF( LDC.GT.NMAX )
+ $ GO TO 100
+ LCC = LDC*N
+ NULL = N.LE.0
+*
+ DO 90 IK = 1, NIDIM
+ K = IDIM( IK )
+*
+ DO 80 ICA = 1, 3
+ TRANSA = ICH( ICA: ICA )
+ TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
+*
+ IF( TRANA )THEN
+ MA = K
+ NA = N
+ ELSE
+ MA = N
+ NA = K
+ END IF
+* Set LDA to 1 more than minimum value if room.
+ LDA = MA
+ IF( LDA.LT.NMAX )
+ $ LDA = LDA + 1
+* Skip tests if not enough room.
+ IF( LDA.GT.NMAX )
+ $ GO TO 80
+ LAA = LDA*NA
+*
+* Generate the matrix A.
+*
+ CALL DMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
+ $ RESET, ZERO )
+*
+ DO 70 ICB = 1, 3
+ TRANSB = ICH( ICB: ICB )
+ TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
+*
+ IF( TRANB )THEN
+ MB = N
+ NB = K
+ ELSE
+ MB = K
+ NB = N
+ END IF
+* Set LDB to 1 more than minimum value if room.
+ LDB = MB
+ IF( LDB.LT.NMAX )
+ $ LDB = LDB + 1
+* Skip tests if not enough room.
+ IF( LDB.GT.NMAX )
+ $ GO TO 70
+ LBB = LDB*NB
+*
+* Generate the matrix B.
+*
+ CALL DMAKE( 'GE', ' ', ' ', MB, NB, B, NMAX, BB,
+ $ LDB, RESET, ZERO )
+*
+ DO 60 IA = 1, NALF
+ ALPHA = ALF( IA )
+*
+ DO 50 IB = 1, NBET
+ BETA = BET( IB )
+
+ DO 45 IS = 1, 2
+ UPLO = ISHAPE( IS: IS )
+
+*
+* Generate the matrix C.
+*
+ CALL DMAKE( 'GE', UPLO, ' ', N, N, C,
+ $ NMAX, CC, LDC, RESET, ZERO )
+*
+ NC = NC + 1
+*
+* Save every datum before calling the
+* subroutine.
+*
+ UPLOS = UPLO
+ TRANAS = TRANSA
+ TRANBS = TRANSB
+ NS = N
+ KS = K
+ ALS = ALPHA
+ DO 10 I = 1, LAA
+ AS( I ) = AA( I )
+ 10 CONTINUE
+ LDAS = LDA
+ DO 20 I = 1, LBB
+ BS( I ) = BB( I )
+ 20 CONTINUE
+ LDBS = LDB
+ BLS = BETA
+ DO 30 I = 1, LCC
+ CS( I ) = CC( I )
+ 30 CONTINUE
+ LDCS = LDC
+*
+* Call the subroutine.
+*
+ IF( TRACE )
+ $ CALL DPRCN8(NTRA, NC, SNAME, IORDER, UPLO,
+ $ TRANSA, TRANSB, N, K, ALPHA, LDA,
+ $ LDB, BETA, LDC)
+ IF( REWI )
+ $ REWIND NTRA
+ CALL CDGEMMTR( IORDER, UPLO, TRANSA, TRANSB,
+ $ N, K, ALPHA, AA, LDA, BB, LDB,
+ $ BETA, CC, LDC )
+*
+* Check if error-exit was taken incorrectly.
+*
+ IF( .NOT.OK )THEN
+ WRITE( NOUT, FMT = 9994 )
+ FATAL = .TRUE.
+ GO TO 120
+ END IF
+*
+* See what data changed inside subroutines.
+*
+ ISAME( 1 ) = UPLO.EQ.UPLOS
+ ISAME( 2 ) = TRANSA.EQ.TRANAS
+ ISAME( 3 ) = TRANSB.EQ.TRANBS
+ ISAME( 4 ) = NS.EQ.N
+ ISAME( 5 ) = KS.EQ.K
+ ISAME( 6 ) = ALS.EQ.ALPHA
+ ISAME( 7 ) = LDE( AS, AA, LAA )
+ ISAME( 8 ) = LDAS.EQ.LDA
+ ISAME( 9 ) = LDE( BS, BB, LBB )
+ ISAME( 10 ) = LDBS.EQ.LDB
+ ISAME( 11 ) = BLS.EQ.BETA
+ IF( NULL )THEN
+ ISAME( 12 ) = LDE( CS, CC, LCC )
+ ELSE
+ ISAME( 12 ) = LDERES( 'GE', ' ', N, N,
+ $ CS, CC, LDC )
+ END IF
+ ISAME( 13 ) = LDCS.EQ.LDC
+*
+* If data was incorrectly changed, report
+* and return.
+*
+ SAME = .TRUE.
+ DO 40 I = 1, NARGS
+ SAME = SAME.AND.ISAME( I )
+ IF( .NOT.ISAME( I ) )
+ $ WRITE( NOUT, FMT = 9998 )I
+ 40 CONTINUE
+ IF( .NOT.SAME )THEN
+ FATAL = .TRUE.
+ GO TO 120
+ END IF
+*
+ IF( .NOT.NULL )THEN
+*
+* Check the result.
+*
+ CALL DMMTCH( UPLO, TRANSA, TRANSB,
+ $ N, K,
+ $ ALPHA, A, NMAX, B, NMAX, BETA,
+ $ C, NMAX, CT, G, CC, LDC, EPS,
+ $ ERR, FATAL, NOUT, .TRUE. )
+ ERRMAX = MAX( ERRMAX, ERR )
+* If got really bad answer, report and
+* return.
+ IF( FATAL )
+ $ GO TO 120
+ END IF
+*
+ 45 CONTINUE
+*
+ 50 CONTINUE
+*
+ 60 CONTINUE
+*
+ 70 CONTINUE
+*
+ 80 CONTINUE
+*
+ 90 CONTINUE
+*
+ 100 CONTINUE
+*
+*
+* Report result.
+*
+ IF( ERRMAX.LT.THRESH )THEN
+ IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC
+ IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC
+ ELSE
+ IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
+ IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
+ END IF
+ GO TO 130
+*
+ 120 CONTINUE
+ WRITE( NOUT, FMT = 9996 )SNAME
+ CALL DPRCN8(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, TRANSB,
+ $ N, K, ALPHA, LDA, LDB, BETA, LDC)
+*
+ 130 CONTINUE
+ RETURN
+*
+10003 FORMAT( ' ', A13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
+ $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
+ $ 'RATIO ', F8.2, ' - SUSPECT *******' )
+10002 FORMAT( ' ', A13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
+ $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
+ $ 'RATIO ', F8.2, ' - SUSPECT *******' )
+10001 FORMAT( ' ', A13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
+ $ ' (', I6, ' CALL', 'S)' )
+10000 FORMAT( ' ', A13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
+ $ ' (', I6, ' CALL', 'S)' )
+ 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
+ $ 'ANGED INCORRECTLY *******' )
+ 9997 FORMAT( ' ', A13, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
+ $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
+ $ ' - SUSPECT *******' )
+ 9996 FORMAT( ' ******* ', A13, ' FAILED ON CALL NUMBER:' )
+ 9995 FORMAT( 1X, I6, ': ', A13, '(''',A1, ''',''',A1, ''',''', A1,''',',
+ $ 2( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ',
+ $ 'C,', I3, ').' )
+ 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
+ $ '******' )
+*
+* End of DCHK6
+*
+ END
+
+ SUBROUTINE DPRCN8(NOUT, NC, SNAME, IORDER, UPLO,
+ $ TRANSA, TRANSB, N,
+ $ K, ALPHA, LDA, LDB, BETA, LDC)
+ INTEGER NOUT, NC, IORDER, N, K, LDA, LDB, LDC
+ DOUBLE PRECISION ALPHA, BETA
+ CHARACTER*1 TRANSA, TRANSB, UPLO
+ CHARACTER*13 SNAME
+ CHARACTER*14 CRC, CTA,CTB,CUPLO
+
+ IF (UPLO.EQ.'U') THEN
+ CUPLO = 'CblasUpper'
+ ELSE
+ CUPLO = 'CblasLower'
+ END IF
+ IF (TRANSA.EQ.'N')THEN
+ CTA = ' CblasNoTrans'
+ ELSE IF (TRANSA.EQ.'T')THEN
+ CTA = ' CblasTrans'
+ ELSE
+ CTA = 'CblasConjTrans'
+ END IF
+ IF (TRANSB.EQ.'N')THEN
+ CTB = ' CblasNoTrans'
+ ELSE IF (TRANSB.EQ.'T')THEN
+ CTB = ' CblasTrans'
+ ELSE
+ CTB = 'CblasConjTrans'
+ END IF
+ IF (IORDER.EQ.1)THEN
+ CRC = ' CblasRowMajor'
+ ELSE
+ CRC = ' CblasColMajor'
+ END IF
+ WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CUPLO, CTA,CTB
+ WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, LDB, BETA, LDC
+
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', A14, ',', A14, ',', A14, ',',
+ $ A14, ',')
+ 9994 FORMAT( 10X, 2( I3, ',' ) ,' ', F4.1,' , A,',
+ $ I3, ', B,', I3, ', ', F4.1,' , C,', I3, ').' )
+ END
+
+ SUBROUTINE DMMTCH( UPLO, TRANSA, TRANSB, N, KK, ALPHA, A, LDA,
+ $ B, LDB, BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR,
+ $ FATAL, NOUT, MV )
+*
+* Checks the results of the computational tests.
+*
+* Auxiliary routine for test program for Level 3 Blas. (DGEMMTR)
+*
+* -- Written on 19-July-2023.
+* Martin Koehler, MPI Magdeburg
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* .. Scalar Arguments ..
+ DOUBLE PRECISION ALPHA, BETA, EPS, ERR
+ INTEGER KK, LDA, LDB, LDC, LDCC, N, NOUT
+ LOGICAL FATAL, MV
+ CHARACTER*1 UPLO, TRANSA, TRANSB
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ),
+ $ CC( LDCC, * ), CT( * ), G( * )
+* .. Local Scalars ..
+ DOUBLE PRECISION ERRI
+ INTEGER I, J, K, ISTART, ISTOP
+ LOGICAL TRANA, TRANB, UPPER
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* .. Executable Statements ..
+ UPPER = UPLO.EQ.'U'
+ TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
+ TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
+*
+* Compute expected result, one column at a time, in CT using data
+* in A, B and C.
+* Compute gauges in G.
+*
+ ISTART = 1
+ ISTOP = N
+
+ DO 120 J = 1, N
+*
+ IF ( UPPER ) THEN
+ ISTART = 1
+ ISTOP = J
+ ELSE
+ ISTART = J
+ ISTOP = N
+ END IF
+ DO 10 I = ISTART, ISTOP
+ CT( I ) = ZERO
+ G( I ) = ZERO
+ 10 CONTINUE
+ IF( .NOT.TRANA.AND..NOT.TRANB )THEN
+ DO 30 K = 1, KK
+ DO 20 I = ISTART, ISTOP
+ CT( I ) = CT( I ) + A( I, K )*B( K, J )
+ G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( K, J ) )
+ 20 CONTINUE
+ 30 CONTINUE
+ ELSE IF( TRANA.AND..NOT.TRANB )THEN
+ DO 50 K = 1, KK
+ DO 40 I = ISTART, ISTOP
+ CT( I ) = CT( I ) + A( K, I )*B( K, J )
+ G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( K, J ) )
+ 40 CONTINUE
+ 50 CONTINUE
+ ELSE IF( .NOT.TRANA.AND.TRANB )THEN
+ DO 70 K = 1, KK
+ DO 60 I = ISTART, ISTOP
+ CT( I ) = CT( I ) + A( I, K )*B( J, K )
+ G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( J, K ) )
+ 60 CONTINUE
+ 70 CONTINUE
+ ELSE IF( TRANA.AND.TRANB )THEN
+ DO 90 K = 1, KK
+ DO 80 I = ISTART, ISTOP
+ CT( I ) = CT( I ) + A( K, I )*B( J, K )
+ G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( J, K ) )
+ 80 CONTINUE
+ 90 CONTINUE
+ END IF
+ DO 100 I = ISTART, ISTOP
+ CT( I ) = ALPHA*CT( I ) + BETA*C( I, J )
+ G( I ) = ABS( ALPHA )*G( I ) + ABS( BETA )*ABS( C( I, J ) )
+ 100 CONTINUE
+*
+* Compute the error ratio for this result.
+*
+ ERR = ZERO
+ DO 110 I = ISTART, ISTOP
+ ERRI = ABS( CT( I ) - CC( I, J ) )/EPS
+ IF( G( I ).NE.ZERO )
+ $ ERRI = ERRI/G( I )
+ ERR = MAX( ERR, ERRI )
+ IF( ERR*SQRT( EPS ).GE.ONE )
+ $ GO TO 130
+ 110 CONTINUE
+*
+ 120 CONTINUE
+*
+* If the loop completes, all results are at least half accurate.
+ GO TO 150
+*
+* Report fatal error.
+*
+ 130 FATAL = .TRUE.
+ WRITE( NOUT, FMT = 9999 )
+ DO 140 I = ISTART, ISTOP
+ IF( MV )THEN
+ WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J )
+ ELSE
+ WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I )
+ END IF
+ 140 CONTINUE
+ IF( N.GT.1 )
+ $ WRITE( NOUT, FMT = 9997 )J
+*
+ 150 CONTINUE
+ RETURN
+*
+ 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
+ $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU',
+ $ 'TED RESULT' )
+ 9998 FORMAT( 1X, I7, 2G18.6 )
+ 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
+*
+* End of DMMTCH
+*
+ END
+
+
diff --git a/ctest/c_sblas3.c b/ctest/c_sblas3.c
index 10dc049a84..5ff34254c3 100644
--- a/ctest/c_sblas3.c
+++ b/ctest/c_sblas3.c
@@ -6,51 +6,55 @@
*/
#include <stdio.h>
#include <stdlib.h>
-#include "common.h"
+#include "cblas.h"
#include "cblas_test.h"
-void F77_sgemm(int *order, char *transpa, char *transpb, int *m, int *n,
+void F77_sgemm(int *layout, char *transpa, char *transpb, int *m, int *n,
int *k, float *alpha, float *a, int *lda, float *b, int *ldb,
- float *beta, float *c, int *ldc ) {
+ float *beta, float *c, int *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN transpa_len, FORTRAN_STRLEN transpb_len
+#endif
+) {
float *A, *B, *C;
int i,j,LDA, LDB, LDC;
- enum CBLAS_TRANSPOSE transa, transb;
+ CBLAS_TRANSPOSE transa, transb;
get_transpose_type(transpa, &transa);
get_transpose_type(transpb, &transb);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (transa == CblasNoTrans) {
LDA = *k+1;
- A = (float *)malloc( (*m)*(size_t)LDA*sizeof( float ) );
+ A = (float *)malloc( (*m)*LDA*sizeof( float ) );
for( i=0; i<*m; i++ )
for( j=0; j<*k; j++ )
A[i*LDA+j]=a[j*(*lda)+i];
}
else {
LDA = *m+1;
- A = ( float* )malloc( (size_t)LDA*(*k)*sizeof( float ) );
+ A = ( float* )malloc( LDA*(*k)*sizeof( float ) );
for( i=0; i<*k; i++ )
for( j=0; j<*m; j++ )
A[i*LDA+j]=a[j*(*lda)+i];
}
if (transb == CblasNoTrans) {
LDB = *n+1;
- B = ( float* )malloc( (*k)*(size_t)LDB*sizeof( float ) );
+ B = ( float* )malloc( (*k)*LDB*sizeof( float ) );
for( i=0; i<*k; i++ )
for( j=0; j<*n; j++ )
B[i*LDB+j]=b[j*(*ldb)+i];
}
else {
LDB = *k+1;
- B = ( float* )malloc( (size_t)LDB*(*n)*sizeof( float ) );
+ B = ( float* )malloc( LDB*(*n)*sizeof( float ) );
for( i=0; i<*n; i++ )
for( j=0; j<*k; j++ )
B[i*LDB+j]=b[j*(*ldb)+i];
}
LDC = *n+1;
- C = ( float* )malloc( (*m)*(size_t)LDC*sizeof( float ) );
+ C = ( float* )malloc( (*m)*LDC*sizeof( float ) );
for( j=0; j<*n; j++ )
for( i=0; i<*m; i++ )
C[i*LDC+j]=c[j*(*ldc)+i];
@@ -63,47 +67,127 @@ void F77_sgemm(int *order, char *transpa, char *transpb, int *m, int *n,
free(B);
free(C);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_sgemm( CblasColMajor, transa, transb, *m, *n, *k, *alpha, a, *lda,
b, *ldb, *beta, c, *ldc );
else
cblas_sgemm( UNDEFINED, transa, transb, *m, *n, *k, *alpha, a, *lda,
b, *ldb, *beta, c, *ldc );
}
-void F77_ssymm(int *order, char *rtlf, char *uplow, int *m, int *n,
+
+void F77_sgemmtr(int *layout, char *uplop, char *transpa, char *transpb, int *n,
+ int *k, float *alpha, float *a, int *lda,
+ float *b, int *ldb, float *beta,
+ float *c, int *ldc ) {
+
+ float *A, *B, *C;
+ int i,j,LDA, LDB, LDC;
+ CBLAS_TRANSPOSE transa, transb;
+ CBLAS_UPLO uplo;
+
+ get_transpose_type(transpa, &transa);
+ get_transpose_type(transpb, &transb);
+ get_uplo_type(uplop, &uplo);
+
+ if (*layout == TEST_ROW_MJR) {
+ if (transa == CblasNoTrans) {
+ LDA = *k+1;
+ A=(float*)malloc((*n)*LDA*sizeof(float));
+ for( i=0; i<*n; i++ )
+ for( j=0; j<*k; j++ ) {
+ A[i*LDA+j]=a[j*(*lda)+i];
+ }
+ }
+ else {
+ LDA = *n+1;
+ A=(float* )malloc(LDA*(*k)*sizeof(float));
+ for( i=0; i<*k; i++ )
+ for( j=0; j<*n; j++ ) {
+ A[i*LDA+j]=a[j*(*lda)+i];
+ }
+ }
+
+ if (transb == CblasNoTrans) {
+ LDB = *n+1;
+ B=(float* )malloc((*k)*LDB*sizeof(float) );
+ for( i=0; i<*k; i++ )
+ for( j=0; j<*n; j++ ) {
+ B[i*LDB+j]=b[j*(*ldb)+i];
+ }
+ }
+ else {
+ LDB = *k+1;
+ B=(float* )malloc(LDB*(*n)*sizeof(float));
+ for( i=0; i<*n; i++ )
+ for( j=0; j<*k; j++ ) {
+ B[i*LDB+j]=b[j*(*ldb)+i];
+ }
+ }
+
+ LDC = *n+1;
+ C=(float* )malloc((*n)*LDC*sizeof(float));
+ for( j=0; j<*n; j++ )
+ for( i=0; i<*n; i++ ) {
+ C[i*LDC+j]=c[j*(*ldc)+i];
+ }
+ cblas_sgemmtr( CblasRowMajor, uplo, transa, transb, *n, *k, *alpha, A, LDA,
+ B, LDB, *beta, C, LDC );
+ for( j=0; j<*n; j++ )
+ for( i=0; i<*n; i++ ) {
+ c[j*(*ldc)+i]=C[i*LDC+j];
+ }
+ free(A);
+ free(B);
+ free(C);
+ }
+ else if (*layout == TEST_COL_MJR)
+ cblas_sgemmtr( CblasColMajor, uplo, transa, transb, *n, *k, *alpha, a, *lda,
+ b, *ldb, *beta, c, *ldc );
+ else
+ cblas_sgemmtr( UNDEFINED, uplo, transa, transb, *n, *k, *alpha, a, *lda,
+ b, *ldb, *beta, c, *ldc );
+}
+
+
+
+void F77_ssymm(int *layout, char *rtlf, char *uplow, int *m, int *n,
float *alpha, float *a, int *lda, float *b, int *ldb,
- float *beta, float *c, int *ldc ) {
+ float *beta, float *c, int *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len
+#endif
+) {
float *A, *B, *C;
int i,j,LDA, LDB, LDC;
- enum CBLAS_UPLO uplo;
- enum CBLAS_SIDE side;
+ CBLAS_UPLO uplo;
+ CBLAS_SIDE side;
get_uplo_type(uplow,&uplo);
get_side_type(rtlf,&side);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (side == CblasLeft) {
LDA = *m+1;
- A = ( float* )malloc( (*m)*(size_t)LDA*sizeof( float ) );
+ A = ( float* )malloc( (*m)*LDA*sizeof( float ) );
for( i=0; i<*m; i++ )
for( j=0; j<*m; j++ )
A[i*LDA+j]=a[j*(*lda)+i];
}
else{
LDA = *n+1;
- A = ( float* )malloc( (*n)*(size_t)LDA*sizeof( float ) );
+ A = ( float* )malloc( (*n)*LDA*sizeof( float ) );
for( i=0; i<*n; i++ )
for( j=0; j<*n; j++ )
A[i*LDA+j]=a[j*(*lda)+i];
}
LDB = *n+1;
- B = ( float* )malloc( (*m)*(size_t)LDB*sizeof( float ) );
+ B = ( float* )malloc( (*m)*LDB*sizeof( float ) );
for( i=0; i<*m; i++ )
for( j=0; j<*n; j++ )
B[i*LDB+j]=b[j*(*ldb)+i];
LDC = *n+1;
- C = ( float* )malloc( (*m)*(size_t)LDC*sizeof( float ) );
+ C = ( float* )malloc( (*m)*LDC*sizeof( float ) );
for( j=0; j<*n; j++ )
for( i=0; i<*m; i++ )
C[i*LDC+j]=c[j*(*ldc)+i];
@@ -116,7 +200,7 @@ void F77_ssymm(int *order, char *rtlf, char *uplow, int *m, int *n,
free(B);
free(C);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_ssymm( CblasColMajor, side, uplo, *m, *n, *alpha, a, *lda, b, *ldb,
*beta, c, *ldc );
else
@@ -124,35 +208,39 @@ void F77_ssymm(int *order, char *rtlf, char *uplow, int *m, int *n,
*beta, c, *ldc );
}
-void F77_ssyrk(int *order, char *uplow, char *transp, int *n, int *k,
+void F77_ssyrk(int *layout, char *uplow, char *transp, int *n, int *k,
float *alpha, float *a, int *lda,
- float *beta, float *c, int *ldc ) {
+ float *beta, float *c, int *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len
+#endif
+) {
int i,j,LDA,LDC;
float *A, *C;
- enum CBLAS_UPLO uplo;
- enum CBLAS_TRANSPOSE trans;
+ CBLAS_UPLO uplo;
+ CBLAS_TRANSPOSE trans;
get_uplo_type(uplow,&uplo);
get_transpose_type(transp,&trans);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (trans == CblasNoTrans) {
LDA = *k+1;
- A = ( float* )malloc( (*n)*(size_t)LDA*sizeof( float ) );
+ A = ( float* )malloc( (*n)*LDA*sizeof( float ) );
for( i=0; i<*n; i++ )
for( j=0; j<*k; j++ )
A[i*LDA+j]=a[j*(*lda)+i];
}
else{
LDA = *n+1;
- A = ( float* )malloc( (*k)*(size_t)LDA*sizeof( float ) );
+ A = ( float* )malloc( (*k)*LDA*sizeof( float ) );
for( i=0; i<*k; i++ )
for( j=0; j<*n; j++ )
A[i*LDA+j]=a[j*(*lda)+i];
}
LDC = *n+1;
- C = ( float* )malloc( (*n)*(size_t)LDC*sizeof( float ) );
+ C = ( float* )malloc( (*n)*LDC*sizeof( float ) );
for( i=0; i<*n; i++ )
for( j=0; j<*n; j++ )
C[i*LDC+j]=c[j*(*ldc)+i];
@@ -164,7 +252,7 @@ void F77_ssyrk(int *order, char *uplow, char *transp, int *n, int *k,
free(A);
free(C);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_ssyrk(CblasColMajor, uplo, trans, *n, *k, *alpha, a, *lda, *beta,
c, *ldc );
else
@@ -172,23 +260,27 @@ void F77_ssyrk(int *order, char *uplow, char *transp, int *n, int *k,
c, *ldc );
}
-void F77_ssyr2k(int *order, char *uplow, char *transp, int *n, int *k,
+void F77_ssyr2k(int *layout, char *uplow, char *transp, int *n, int *k,
float *alpha, float *a, int *lda, float *b, int *ldb,
- float *beta, float *c, int *ldc ) {
+ float *beta, float *c, int *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len
+#endif
+) {
int i,j,LDA,LDB,LDC;
float *A, *B, *C;
- enum CBLAS_UPLO uplo;
- enum CBLAS_TRANSPOSE trans;
+ CBLAS_UPLO uplo;
+ CBLAS_TRANSPOSE trans;
get_uplo_type(uplow,&uplo);
get_transpose_type(transp,&trans);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (trans == CblasNoTrans) {
LDA = *k+1;
LDB = *k+1;
- A = ( float* )malloc( (*n)*(size_t)LDA*sizeof( float ) );
- B = ( float* )malloc( (*n)*(size_t)LDB*sizeof( float ) );
+ A = ( float* )malloc( (*n)*LDA*sizeof( float ) );
+ B = ( float* )malloc( (*n)*LDB*sizeof( float ) );
for( i=0; i<*n; i++ )
for( j=0; j<*k; j++ ) {
A[i*LDA+j]=a[j*(*lda)+i];
@@ -198,8 +290,8 @@ void F77_ssyr2k(int *order, char *uplow, char *transp, int *n, int *k,
else {
LDA = *n+1;
LDB = *n+1;
- A = ( float* )malloc( (size_t)LDA*(*k)*sizeof( float ) );
- B = ( float* )malloc( (size_t)LDB*(*k)*sizeof( float ) );
+ A = ( float* )malloc( LDA*(*k)*sizeof( float ) );
+ B = ( float* )malloc( LDB*(*k)*sizeof( float ) );
for( i=0; i<*k; i++ )
for( j=0; j<*n; j++ ){
A[i*LDA+j]=a[j*(*lda)+i];
@@ -207,7 +299,7 @@ void F77_ssyr2k(int *order, char *uplow, char *transp, int *n, int *k,
}
}
LDC = *n+1;
- C = ( float* )malloc( (*n)*(size_t)LDC*sizeof( float ) );
+ C = ( float* )malloc( (*n)*LDC*sizeof( float ) );
for( i=0; i<*n; i++ )
for( j=0; j<*n; j++ )
C[i*LDC+j]=c[j*(*ldc)+i];
@@ -220,45 +312,49 @@ void F77_ssyr2k(int *order, char *uplow, char *transp, int *n, int *k,
free(B);
free(C);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_ssyr2k(CblasColMajor, uplo, trans, *n, *k, *alpha, a, *lda,
b, *ldb, *beta, c, *ldc );
else
cblas_ssyr2k(UNDEFINED, uplo, trans, *n, *k, *alpha, a, *lda,
b, *ldb, *beta, c, *ldc );
}
-void F77_strmm(int *order, char *rtlf, char *uplow, char *transp, char *diagn,
+void F77_strmm(int *layout, char *rtlf, char *uplow, char *transp, char *diagn,
int *m, int *n, float *alpha, float *a, int *lda, float *b,
- int *ldb) {
+ int *ldb
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
int i,j,LDA,LDB;
float *A, *B;
- enum CBLAS_SIDE side;
- enum CBLAS_DIAG diag;
- enum CBLAS_UPLO uplo;
- enum CBLAS_TRANSPOSE trans;
+ CBLAS_SIDE side;
+ CBLAS_DIAG diag;
+ CBLAS_UPLO uplo;
+ CBLAS_TRANSPOSE trans;
get_uplo_type(uplow,&uplo);
get_transpose_type(transp,&trans);
get_diag_type(diagn,&diag);
get_side_type(rtlf,&side);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (side == CblasLeft) {
LDA = *m+1;
- A = ( float* )malloc( (*m)*(size_t)LDA*sizeof( float ) );
+ A = ( float* )malloc( (*m)*LDA*sizeof( float ) );
for( i=0; i<*m; i++ )
for( j=0; j<*m; j++ )
A[i*LDA+j]=a[j*(*lda)+i];
}
else{
LDA = *n+1;
- A = ( float* )malloc( (*n)*(size_t)LDA*sizeof( float ) );
+ A = ( float* )malloc( (*n)*LDA*sizeof( float ) );
for( i=0; i<*n; i++ )
for( j=0; j<*n; j++ )
A[i*LDA+j]=a[j*(*lda)+i];
}
LDB = *n+1;
- B = ( float* )malloc( (*m)*(size_t)LDB*sizeof( float ) );
+ B = ( float* )malloc( (*m)*LDB*sizeof( float ) );
for( i=0; i<*m; i++ )
for( j=0; j<*n; j++ )
B[i*LDB+j]=b[j*(*ldb)+i];
@@ -270,7 +366,7 @@ void F77_strmm(int *order, char *rtlf, char *uplow, char *transp, char *diagn,
free(A);
free(B);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_strmm(CblasColMajor, side, uplo, trans, diag, *m, *n, *alpha,
a, *lda, b, *ldb);
else
@@ -278,38 +374,42 @@ void F77_strmm(int *order, char *rtlf, char *uplow, char *transp, char *diagn,
a, *lda, b, *ldb);
}
-void F77_strsm(int *order, char *rtlf, char *uplow, char *transp, char *diagn,
+void F77_strsm(int *layout, char *rtlf, char *uplow, char *transp, char *diagn,
int *m, int *n, float *alpha, float *a, int *lda, float *b,
- int *ldb) {
+ int *ldb
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
int i,j,LDA,LDB;
float *A, *B;
- enum CBLAS_SIDE side;
- enum CBLAS_DIAG diag;
- enum CBLAS_UPLO uplo;
- enum CBLAS_TRANSPOSE trans;
+ CBLAS_SIDE side;
+ CBLAS_DIAG diag;
+ CBLAS_UPLO uplo;
+ CBLAS_TRANSPOSE trans;
get_uplo_type(uplow,&uplo);
get_transpose_type(transp,&trans);
get_diag_type(diagn,&diag);
get_side_type(rtlf,&side);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (side == CblasLeft) {
LDA = *m+1;
- A = ( float* )malloc( (*m)*(size_t)LDA*sizeof( float ) );
+ A = ( float* )malloc( (*m)*LDA*sizeof( float ) );
for( i=0; i<*m; i++ )
for( j=0; j<*m; j++ )
A[i*LDA+j]=a[j*(*lda)+i];
}
else{
LDA = *n+1;
- A = ( float* )malloc( (*n)*(size_t)LDA*sizeof( float ) );
+ A = ( float* )malloc( (*n)*LDA*sizeof( float ) );
for( i=0; i<*n; i++ )
for( j=0; j<*n; j++ )
A[i*LDA+j]=a[j*(*lda)+i];
}
LDB = *n+1;
- B = ( float* )malloc( (*m)*(size_t)LDB*sizeof( float ) );
+ B = ( float* )malloc( (*m)*LDB*sizeof( float ) );
for( i=0; i<*m; i++ )
for( j=0; j<*n; j++ )
B[i*LDB+j]=b[j*(*ldb)+i];
@@ -321,7 +421,7 @@ void F77_strsm(int *order, char *rtlf, char *uplow, char *transp, char *diagn,
free(A);
free(B);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_strsm(CblasColMajor, side, uplo, trans, diag, *m, *n, *alpha,
a, *lda, b, *ldb);
else
diff --git a/ctest/c_sblat3.f b/ctest/c_sblat3.f
index 61bf46997f..c6f6961900 100644
--- a/ctest/c_sblat3.f
+++ b/ctest/c_sblat3.f
@@ -4,13 +4,13 @@ PROGRAM SBLAT3
*
* 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
+* are read using the format ( A13, 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 ERROR STOP ON FAILURES.
+* 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
@@ -20,12 +20,14 @@ PROGRAM SBLAT3
* 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.
+* 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.
+* cblas_sgemmtr T PUT F FOR NO TEST. SAME COLUMNS.
+
*
* See:
*
@@ -46,7 +48,7 @@ PROGRAM SBLAT3
INTEGER NIN, NOUT
PARAMETER ( NIN = 5, NOUT = 6 )
INTEGER NSUBS
- PARAMETER ( NSUBS = 6 )
+ PARAMETER ( NSUBS = 7 )
REAL ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 )
INTEGER NMAX
@@ -60,7 +62,7 @@ PROGRAM SBLAT3
LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
$ TSTERR, CORDER, RORDER
CHARACTER*1 TRANSA, TRANSB
- CHARACTER*12 SNAMET
+ CHARACTER*13 SNAMET
CHARACTER*32 SNAPS
* .. Local Arrays ..
REAL AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ),
@@ -71,27 +73,27 @@ PROGRAM SBLAT3
$ G( NMAX ), W( 2*NMAX )
INTEGER IDIM( NIDMAX )
LOGICAL LTEST( NSUBS )
- CHARACTER*12 SNAMES( NSUBS )
+ CHARACTER*13 SNAMES( NSUBS )
* .. External Functions ..
REAL SDIFF
LOGICAL LSE
EXTERNAL SDIFF, LSE
* .. External Subroutines ..
EXTERNAL SCHK1, SCHK2, SCHK3, SCHK4, SCHK5, CS3CHKE,
- $ SMMCH
+ $ SMMCH, SCHK6
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL OK
- CHARACTER*12 SRNAMT
+ CHARACTER*13 SRNAMT
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK
COMMON /SRNAMC/SRNAMT
* .. Data statements ..
DATA SNAMES/'cblas_sgemm ', 'cblas_ssymm ',
$ 'cblas_strmm ', 'cblas_strsm ','cblas_ssyrk ',
- $ 'cblas_ssyr2k'/
+ $ 'cblas_ssyr2k', 'cblas_sgemmtr'/
* .. Executable Statements ..
*
NOUTC = NOUT
@@ -188,7 +190,7 @@ PROGRAM SBLAT3
$ GO TO 50
40 CONTINUE
WRITE( NOUT, FMT = 9990 )SNAMET
- ERROR STOP
+ STOP
50 LTEST( I ) = LTESTT
GO TO 30
*
@@ -231,7 +233,7 @@ PROGRAM SBLAT3
SAME = LSE( CC, CT, N )
IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
- ERROR STOP
+ STOP
END IF
TRANSB = 'T'
CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
@@ -240,7 +242,7 @@ PROGRAM SBLAT3
SAME = LSE( CC, CT, N )
IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
- ERROR STOP
+ STOP
END IF
DO 120 J = 1, N
AB( J, NMAX + 1 ) = N - J + 1
@@ -258,7 +260,7 @@ PROGRAM SBLAT3
SAME = LSE( CC, CT, N )
IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
- ERROR STOP
+ STOP
END IF
TRANSB = 'T'
CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
@@ -267,7 +269,7 @@ PROGRAM SBLAT3
SAME = LSE( CC, CT, N )
IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
- ERROR STOP
+ STOP
END IF
*
* Test each subroutine in turn.
@@ -288,7 +290,7 @@ PROGRAM SBLAT3
INFOT = 0
OK = .TRUE.
FATAL = .FALSE.
- GO TO ( 140, 150, 160, 160, 170, 180 )ISNUM
+ GO TO ( 140, 150, 160, 160, 170, 180, 185 )ISNUM
* Test SGEMM, 01.
140 IF (CORDER) THEN
CALL SCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
@@ -359,8 +361,24 @@ PROGRAM SBLAT3
$ 1 )
END IF
GO TO 190
+* Test SGEMMTR, 07.
+ 185 IF (CORDER) THEN
+ CALL SCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
+ $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
+ $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W,
+ $ 0 )
+
+ END IF
+ IF (RORDER) THEN
+ CALL SCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
+ $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
+ $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W,
+ $ 1 )
+ END IF
+ GO TO 190
*
- 190 IF( FATAL.AND.SFATAL )
+
+ 190 IF( FATAL.AND.SFATAL )
$ GO TO 210
END IF
200 CONTINUE
@@ -378,9 +396,7 @@ PROGRAM SBLAT3
IF( TRACE )
$ CLOSE ( NTRA )
CLOSE ( NOUT )
- IF( FATAL ) THEN
- ERROR STOP
- END IF
+ STOP
*
10002 FORMAT( ' COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED' )
10001 FORMAT( ' ROW-MAJOR DATA LAYOUT IS TESTED' )
@@ -398,7 +414,7 @@ PROGRAM SBLAT3
9992 FORMAT( ' FOR BETA ', 7F6.1 )
9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
$ /' ******* TESTS ABANDONED *******' )
- 9990 FORMAT( ' SUBPROGRAM NAME ', A12,' NOT RECOGNIZED', /' ******* ',
+ 9990 FORMAT( ' SUBPROGRAM NAME ', A13,' NOT RECOGNIZED', /' ******* ',
$ 'TESTS ABANDONED *******' )
9989 FORMAT( ' ERROR IN SMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
$ 'ATED WRONGLY.', /' SMMCH WAS CALLED WITH TRANSA = ', A1,
@@ -406,8 +422,8 @@ PROGRAM SBLAT3
$ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ',
$ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ',
$ '*******' )
- 9988 FORMAT( A12,L2 )
- 9987 FORMAT( 1X, A12,' WAS NOT TESTED' )
+ 9988 FORMAT( A13,L2 )
+ 9987 FORMAT( 1X, A13,' WAS NOT TESTED' )
9986 FORMAT( /' END OF TESTS' )
9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
@@ -437,7 +453,7 @@ SUBROUTINE SCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
REAL EPS, THRESH
INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
LOGICAL FATAL, REWI, TRACE
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
* .. Array Arguments ..
REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), B( NMAX, NMAX ),
@@ -683,22 +699,22 @@ SUBROUTINE SCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
130 CONTINUE
RETURN
*
-10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
+10003 FORMAT( ' ', A13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
+10002 FORMAT( ' ', A13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
+10001 FORMAT( ' ', A13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
-10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
+10000 FORMAT( ' ', A13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
- 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
-C 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',',
-C $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ',
-C $ 'C,', I3, ').' )
+ 9996 FORMAT( ' ******* ', A13,' FAILED ON CALL NUMBER:' )
+ 9995 FORMAT( 1X, I6, ': ', A13,'(''', A1, ''',''', A1, ''',',
+ $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ',
+ $ 'C,', I3, ').' )
9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
@@ -713,7 +729,7 @@ SUBROUTINE SPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, M, N,
INTEGER NOUT, NC, IORDER, M, N, K, LDA, LDB, LDC
REAL ALPHA, BETA
CHARACTER*1 TRANSA, TRANSB
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
CHARACTER*14 CRC, CTA,CTB
IF (TRANSA.EQ.'N')THEN
@@ -738,7 +754,7 @@ SUBROUTINE SPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, M, N,
WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CTA,CTB
WRITE(NOUT, FMT = 9994)M, N, K, ALPHA, LDA, LDB, BETA, LDC
- 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',')
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', A14, ',', A14, ',', A14, ',')
9994 FORMAT( 20X, 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',',
$ F4.1, ', ', 'C,', I3, ').' )
END
@@ -765,7 +781,7 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
REAL EPS, THRESH
INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
LOGICAL FATAL, REWI, TRACE
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
* .. Array Arguments ..
REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), B( NMAX, NMAX ),
@@ -1000,22 +1016,22 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
120 CONTINUE
RETURN
*
-10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
+10003 FORMAT( ' ', A13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
+10002 FORMAT( ' ', A13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
+10001 FORMAT( ' ', A13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
-10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
+10000 FORMAT( ' ', A13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
- 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
-C 9995 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
-C $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ',
-C $ ' .' )
+ 9996 FORMAT( ' ******* ', A13,' FAILED ON CALL NUMBER:' )
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
+ $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ',
+ $ ' .' )
9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
@@ -1028,7 +1044,7 @@ SUBROUTINE SPRCN2(NOUT, NC, SNAME, IORDER, SIDE, UPLO, M, N,
INTEGER NOUT, NC, IORDER, M, N, LDA, LDB, LDC
REAL ALPHA, BETA
CHARACTER*1 SIDE, UPLO
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
CHARACTER*14 CRC, CS,CU
IF (SIDE.EQ.'L')THEN
@@ -1049,7 +1065,7 @@ SUBROUTINE SPRCN2(NOUT, NC, SNAME, IORDER, SIDE, UPLO, M, N,
WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CS,CU
WRITE(NOUT, FMT = 9994)M, N, ALPHA, LDA, LDB, BETA, LDC
- 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',')
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', A14, ',', A14, ',', A14, ',')
9994 FORMAT( 20X, 2( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',',
$ F4.1, ', ', 'C,', I3, ').' )
END
@@ -1075,7 +1091,7 @@ SUBROUTINE SCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
REAL EPS, THRESH
INTEGER NALF, NIDIM, NMAX, NOUT, NTRA, IORDER
LOGICAL FATAL, REWI, TRACE
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
* .. Array Arguments ..
REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), B( NMAX, NMAX ),
@@ -1348,21 +1364,21 @@ SUBROUTINE SCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
160 CONTINUE
RETURN
*
-10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
+10003 FORMAT( ' ', A13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
+10002 FORMAT( ' ', A13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
+10001 FORMAT( ' ', A13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
-10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
+10000 FORMAT( ' ', A13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
- 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
-C 9995 FORMAT( 1X, I6, ': ', A12,'(', 4( '''', A1, ''',' ), 2( I3, ',' ),
-C $ F4.1, ', A,', I3, ', B,', I3, ') .' )
+ 9996 FORMAT( ' ******* ', A13,' FAILED ON CALL NUMBER:' )
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', 4( '''', A1, ''',' ), 2( I3, ',' ),
+ $ F4.1, ', A,', I3, ', B,', I3, ') .' )
9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
@@ -1375,7 +1391,7 @@ SUBROUTINE SPRCN3(NOUT, NC, SNAME, IORDER, SIDE, UPLO, TRANSA,
INTEGER NOUT, NC, IORDER, M, N, LDA, LDB
REAL ALPHA
CHARACTER*1 SIDE, UPLO, TRANSA, DIAG
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
CHARACTER*14 CRC, CS, CU, CA, CD
IF (SIDE.EQ.'L')THEN
@@ -1408,7 +1424,7 @@ SUBROUTINE SPRCN3(NOUT, NC, SNAME, IORDER, SIDE, UPLO, TRANSA,
WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CS,CU
WRITE(NOUT, FMT = 9994)CA, CD, M, N, ALPHA, LDA, LDB
- 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',')
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', A14, ',', A14, ',', A14, ',')
9994 FORMAT( 22X, 2( A14, ',') , 2( I3, ',' ),
$ F4.1, ', A,', I3, ', B,', I3, ').' )
END
@@ -1435,7 +1451,7 @@ SUBROUTINE SCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
REAL EPS, THRESH
INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
LOGICAL FATAL, REWI, TRACE
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
* .. Array Arguments ..
REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), B( NMAX, NMAX ),
@@ -1674,22 +1690,22 @@ SUBROUTINE SCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
130 CONTINUE
RETURN
*
-10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
+10003 FORMAT( ' ', A13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
+10002 FORMAT( ' ', A13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
+10001 FORMAT( ' ', A13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
-10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
+10000 FORMAT( ' ', A13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
- 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
+ 9996 FORMAT( ' ******* ', A13,' FAILED ON CALL NUMBER:' )
9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
-C 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
-C $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' )
+ 9994 FORMAT( 1X, I6, ': ', A13,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
+ $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' )
9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
@@ -1702,7 +1718,7 @@ SUBROUTINE SPRCN4(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
INTEGER NOUT, NC, IORDER, N, K, LDA, LDC
REAL ALPHA, BETA
CHARACTER*1 UPLO, TRANSA
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
CHARACTER*14 CRC, CU, CA
IF (UPLO.EQ.'U')THEN
@@ -1725,7 +1741,7 @@ SUBROUTINE SPRCN4(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA
WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, BETA, LDC
- 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') )
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', 3( A14, ',') )
9994 FORMAT( 20X, 2( I3, ',' ),
$ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ').' )
END
@@ -1752,7 +1768,7 @@ SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
REAL EPS, THRESH
INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
LOGICAL FATAL, REWI, TRACE
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
* .. Array Arguments ..
REAL AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ),
$ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ),
@@ -2029,23 +2045,23 @@ SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
160 CONTINUE
RETURN
*
-10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
+10003 FORMAT( ' ', A13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
+10002 FORMAT( ' ', A13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
+10001 FORMAT( ' ', A13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
-10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
+10000 FORMAT( ' ', A13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
- 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
+ 9996 FORMAT( ' ******* ', A13,' FAILED ON CALL NUMBER:' )
9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
-C 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
-C $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ',
-C $ ' .' )
+ 9994 FORMAT( 1X, I6, ': ', A13,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
+ $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ',
+ $ ' .' )
9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
@@ -2058,7 +2074,7 @@ SUBROUTINE SPRCN5(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
INTEGER NOUT, NC, IORDER, N, K, LDA, LDB, LDC
REAL ALPHA, BETA
CHARACTER*1 UPLO, TRANSA
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
CHARACTER*14 CRC, CU, CA
IF (UPLO.EQ.'U')THEN
@@ -2081,7 +2097,7 @@ SUBROUTINE SPRCN5(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA
WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, LDB, BETA, LDC
- 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') )
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', 3( A14, ',') )
9994 FORMAT( 20X, 2( I3, ',' ),
$ F4.1, ', A,', I3, ', B', I3, ',', F4.1, ', C,', I3, ').' )
END
@@ -2405,7 +2421,7 @@ LOGICAL FUNCTION LSERES( TYPE, UPLO, M, N, AA, AS, LDA )
50 CONTINUE
END IF
*
-C 60 CONTINUE
+ 60 CONTINUE
LSERES = .TRUE.
GO TO 80
70 CONTINUE
@@ -2480,3 +2496,475 @@ REAL FUNCTION SDIFF( X, Y )
* End of SDIFF.
*
END
+
+
+ SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
+ $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
+ $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G,
+ $ IORDER)
+*
+* Tests SGEMMTR.
+*
+* Auxiliary routine for test program for Level 3 Blas.
+*
+* -- Written on 19-July-2023.
+* Martin Koehler, MPI Magdeburg
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0 )
+* .. Scalar Arguments ..
+ REAL EPS, THRESH
+ INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
+ LOGICAL FATAL, REWI, TRACE
+ CHARACTER*13 SNAME
+* .. Array Arguments ..
+ REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
+ $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
+ $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
+ $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
+ $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
+ INTEGER IDIM( NIDIM )
+* .. Local Scalars ..
+ REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX
+ INTEGER I, IA, IB, ICA, ICB, IK, IN, K, KS, LAA,
+ $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS,
+ $ MA, MB, N, NA, NARGS, NB, NC, NS, IS
+ LOGICAL NULL, RESET, SAME, TRANA, TRANB
+ CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB, UPLO, UPLOS
+ CHARACTER*3 ICH
+ CHARACTER*2 ISHAPE
+* .. Local Arrays ..
+ LOGICAL ISAME( 13 )
+* .. External Functions ..
+ LOGICAL LSE, LSERES
+ EXTERNAL LSE, LSERES
+* .. External Subroutines ..
+ EXTERNAL CSGEMMTR, SMAKE, SMMTCH, SPRCN8
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* .. Scalars in Common ..
+ INTEGER INFOT, NOUTC
+ LOGICAL LERR, OK
+* .. Common blocks ..
+ COMMON /INFOC/INFOT, NOUTC, OK, LERR
+* .. Data statements ..
+ DATA ICH/'NTC'/
+ DATA ISHAPE/'UL'/
+* .. Executable Statements ..
+*
+ NARGS = 13
+ NC = 0
+ RESET = .TRUE.
+ ERRMAX = ZERO
+*
+ DO 100 IN = 1, NIDIM
+ N = IDIM( IN )
+* Set LDC to 1 more than minimum value if room.
+ LDC = N
+ IF( LDC.LT.NMAX )
+ $ LDC = LDC + 1
+* Skip tests if not enough room.
+ IF( LDC.GT.NMAX )
+ $ GO TO 100
+ LCC = LDC*N
+ NULL = N.LE.0
+*
+ DO 90 IK = 1, NIDIM
+ K = IDIM( IK )
+*
+ DO 80 ICA = 1, 3
+ TRANSA = ICH( ICA: ICA )
+ TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
+*
+ IF( TRANA )THEN
+ MA = K
+ NA = N
+ ELSE
+ MA = N
+ NA = K
+ END IF
+* Set LDA to 1 more than minimum value if room.
+ LDA = MA
+ IF( LDA.LT.NMAX )
+ $ LDA = LDA + 1
+* Skip tests if not enough room.
+ IF( LDA.GT.NMAX )
+ $ GO TO 80
+ LAA = LDA*NA
+*
+* Generate the matrix A.
+*
+ CALL SMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
+ $ RESET, ZERO )
+*
+ DO 70 ICB = 1, 3
+ TRANSB = ICH( ICB: ICB )
+ TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
+*
+ IF( TRANB )THEN
+ MB = N
+ NB = K
+ ELSE
+ MB = K
+ NB = N
+ END IF
+* Set LDB to 1 more than minimum value if room.
+ LDB = MB
+ IF( LDB.LT.NMAX )
+ $ LDB = LDB + 1
+* Skip tests if not enough room.
+ IF( LDB.GT.NMAX )
+ $ GO TO 70
+ LBB = LDB*NB
+*
+* Generate the matrix B.
+*
+ CALL SMAKE( 'GE', ' ', ' ', MB, NB, B, NMAX, BB,
+ $ LDB, RESET, ZERO )
+*
+ DO 60 IA = 1, NALF
+ ALPHA = ALF( IA )
+*
+ DO 50 IB = 1, NBET
+ BETA = BET( IB )
+
+ DO 45 IS = 1, 2
+ UPLO = ISHAPE( IS: IS )
+
+*
+* Generate the matrix C.
+*
+ CALL SMAKE( 'GE', UPLO, ' ', N, N, C,
+ $ NMAX, CC, LDC, RESET, ZERO )
+*
+ NC = NC + 1
+*
+* Save every datum before calling the
+* subroutine.
+*
+ UPLOS = UPLO
+ TRANAS = TRANSA
+ TRANBS = TRANSB
+ NS = N
+ KS = K
+ ALS = ALPHA
+ DO 10 I = 1, LAA
+ AS( I ) = AA( I )
+ 10 CONTINUE
+ LDAS = LDA
+ DO 20 I = 1, LBB
+ BS( I ) = BB( I )
+ 20 CONTINUE
+ LDBS = LDB
+ BLS = BETA
+ DO 30 I = 1, LCC
+ CS( I ) = CC( I )
+ 30 CONTINUE
+ LDCS = LDC
+*
+* Call the subroutine.
+*
+ IF( TRACE )
+ $ CALL SPRCN8(NTRA, NC, SNAME, IORDER, UPLO,
+ $ TRANSA, TRANSB, N, K, ALPHA, LDA,
+ $ LDB, BETA, LDC)
+ IF( REWI )
+ $ REWIND NTRA
+ CALL CSGEMMTR( IORDER, UPLO, TRANSA, TRANSB,
+ $ N, K, ALPHA, AA, LDA, BB, LDB,
+ $ BETA, CC, LDC )
+*
+* Check if error-exit was taken incorrectly.
+*
+ IF( .NOT.OK )THEN
+ WRITE( NOUT, FMT = 9994 )
+ FATAL = .TRUE.
+ GO TO 120
+ END IF
+*
+* See what data changed inside subroutines.
+*
+ ISAME( 1 ) = UPLO.EQ.UPLOS
+ ISAME( 2 ) = TRANSA.EQ.TRANAS
+ ISAME( 3 ) = TRANSB.EQ.TRANBS
+ ISAME( 4 ) = NS.EQ.N
+ ISAME( 5 ) = KS.EQ.K
+ ISAME( 6 ) = ALS.EQ.ALPHA
+ ISAME( 7 ) = LSE( AS, AA, LAA )
+ ISAME( 8 ) = LDAS.EQ.LDA
+ ISAME( 9 ) = LSE( BS, BB, LBB )
+ ISAME( 10 ) = LDBS.EQ.LDB
+ ISAME( 11 ) = BLS.EQ.BETA
+ IF( NULL )THEN
+ ISAME( 12 ) = LSE( CS, CC, LCC )
+ ELSE
+ ISAME( 12 ) = LSERES( 'GE', ' ', N, N,
+ $ CS, CC, LDC )
+ END IF
+ ISAME( 13 ) = LDCS.EQ.LDC
+*
+* If data was incorrectly changed, report
+* and return.
+*
+ SAME = .TRUE.
+ DO 40 I = 1, NARGS
+ SAME = SAME.AND.ISAME( I )
+ IF( .NOT.ISAME( I ) )
+ $ WRITE( NOUT, FMT = 9998 )I
+ 40 CONTINUE
+ IF( .NOT.SAME )THEN
+ FATAL = .TRUE.
+ GO TO 120
+ END IF
+*
+ IF( .NOT.NULL )THEN
+*
+* Check the result.
+*
+ CALL SMMTCH( UPLO, TRANSA, TRANSB,
+ $ N, K,
+ $ ALPHA, A, NMAX, B, NMAX, BETA,
+ $ C, NMAX, CT, G, CC, LDC, EPS,
+ $ ERR, FATAL, NOUT, .TRUE. )
+ ERRMAX = MAX( ERRMAX, ERR )
+* If got really bad answer, report and
+* return.
+ IF( FATAL )
+ $ GO TO 120
+ END IF
+*
+ 45 CONTINUE
+*
+ 50 CONTINUE
+*
+ 60 CONTINUE
+*
+ 70 CONTINUE
+*
+ 80 CONTINUE
+*
+ 90 CONTINUE
+*
+ 100 CONTINUE
+*
+*
+* Report result.
+*
+ IF( ERRMAX.LT.THRESH )THEN
+ IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC
+ IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC
+ ELSE
+ IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
+ IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
+ END IF
+ GO TO 130
+*
+ 120 CONTINUE
+ WRITE( NOUT, FMT = 9996 )SNAME
+ CALL SPRCN8(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, TRANSB,
+ $ N, K, ALPHA, LDA, LDB, BETA, LDC)
+*
+ 130 CONTINUE
+ RETURN
+*
+10003 FORMAT( ' ', A13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
+ $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
+ $ 'RATIO ', F8.2, ' - SUSPECT *******' )
+10002 FORMAT( ' ', A13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
+ $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
+ $ 'RATIO ', F8.2, ' - SUSPECT *******' )
+10001 FORMAT( ' ', A13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
+ $ ' (', I6, ' CALL', 'S)' )
+10000 FORMAT( ' ', A13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
+ $ ' (', I6, ' CALL', 'S)' )
+ 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
+ $ 'ANGED INCORRECTLY *******' )
+ 9997 FORMAT( ' ', A13, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
+ $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
+ $ ' - SUSPECT *******' )
+ 9996 FORMAT( ' ******* ', A13, ' FAILED ON CALL NUMBER:' )
+ 9995 FORMAT( 1X, I6, ': ', A13, '(''',A1, ''',''',A1, ''',''', A1,''',',
+ $ 2( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ',
+ $ 'C,', I3, ').' )
+ 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
+ $ '******' )
+*
+* End of SCHK6
+*
+ END
+
+ SUBROUTINE SPRCN8(NOUT, NC, SNAME, IORDER, UPLO,
+ $ TRANSA, TRANSB, N,
+ $ K, ALPHA, LDA, LDB, BETA, LDC)
+ INTEGER NOUT, NC, IORDER, N, K, LDA, LDB, LDC
+ REAL ALPHA, BETA
+ CHARACTER*1 TRANSA, TRANSB, UPLO
+ CHARACTER*13 SNAME
+ CHARACTER*14 CRC, CTA,CTB,CUPLO
+
+ IF (UPLO.EQ.'U') THEN
+ CUPLO = 'CblasUpper'
+ ELSE
+ CUPLO = 'CblasLower'
+ END IF
+ IF (TRANSA.EQ.'N')THEN
+ CTA = ' CblasNoTrans'
+ ELSE IF (TRANSA.EQ.'T')THEN
+ CTA = ' CblasTrans'
+ ELSE
+ CTA = 'CblasConjTrans'
+ END IF
+ IF (TRANSB.EQ.'N')THEN
+ CTB = ' CblasNoTrans'
+ ELSE IF (TRANSB.EQ.'T')THEN
+ CTB = ' CblasTrans'
+ ELSE
+ CTB = 'CblasConjTrans'
+ END IF
+ IF (IORDER.EQ.1)THEN
+ CRC = ' CblasRowMajor'
+ ELSE
+ CRC = ' CblasColMajor'
+ END IF
+ WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CUPLO, CTA,CTB
+ WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, LDB, BETA, LDC
+
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', A14, ',', A14, ',', A14, ',',
+ $ A14, ',')
+ 9994 FORMAT( 10X, 2( I3, ',' ) ,' ', F4.1,' , A,',
+ $ I3, ', B,', I3, ', ', F4.1,' , C,', I3, ').' )
+ END
+
+ SUBROUTINE SMMTCH( UPLO, TRANSA, TRANSB, N, KK, ALPHA, A, LDA,
+ $ B, LDB, BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR,
+ $ FATAL, NOUT, MV )
+*
+* Checks the results of the computational tests.
+*
+* Auxiliary routine for test program for Level 3 Blas. (DGEMMTR)
+*
+* -- Written on 19-July-2023.
+* Martin Koehler, MPI Magdeburg
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0, ONE = 1.0 )
+* .. Scalar Arguments ..
+ REAL ALPHA, BETA, EPS, ERR
+ INTEGER KK, LDA, LDB, LDC, LDCC, N, NOUT
+ LOGICAL FATAL, MV
+ CHARACTER*1 UPLO, TRANSA, TRANSB
+* .. Array Arguments ..
+ REAL A( LDA, * ), B( LDB, * ), C( LDC, * ),
+ $ CC( LDCC, * ), CT( * ), G( * )
+* .. Local Scalars ..
+ REAL ERRI
+ INTEGER I, J, K, ISTART, ISTOP
+ LOGICAL TRANA, TRANB, UPPER
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* .. Executable Statements ..
+ UPPER = UPLO.EQ.'U'
+ TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
+ TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
+*
+* Compute expected result, one column at a time, in CT using data
+* in A, B and C.
+* Compute gauges in G.
+*
+ ISTART = 1
+ ISTOP = N
+
+ DO 120 J = 1, N
+*
+ IF ( UPPER ) THEN
+ ISTART = 1
+ ISTOP = J
+ ELSE
+ ISTART = J
+ ISTOP = N
+ END IF
+ DO 10 I = ISTART, ISTOP
+ CT( I ) = ZERO
+ G( I ) = ZERO
+ 10 CONTINUE
+ IF( .NOT.TRANA.AND..NOT.TRANB )THEN
+ DO 30 K = 1, KK
+ DO 20 I = ISTART, ISTOP
+ CT( I ) = CT( I ) + A( I, K )*B( K, J )
+ G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( K, J ) )
+ 20 CONTINUE
+ 30 CONTINUE
+ ELSE IF( TRANA.AND..NOT.TRANB )THEN
+ DO 50 K = 1, KK
+ DO 40 I = ISTART, ISTOP
+ CT( I ) = CT( I ) + A( K, I )*B( K, J )
+ G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( K, J ) )
+ 40 CONTINUE
+ 50 CONTINUE
+ ELSE IF( .NOT.TRANA.AND.TRANB )THEN
+ DO 70 K = 1, KK
+ DO 60 I = ISTART, ISTOP
+ CT( I ) = CT( I ) + A( I, K )*B( J, K )
+ G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( J, K ) )
+ 60 CONTINUE
+ 70 CONTINUE
+ ELSE IF( TRANA.AND.TRANB )THEN
+ DO 90 K = 1, KK
+ DO 80 I = ISTART, ISTOP
+ CT( I ) = CT( I ) + A( K, I )*B( J, K )
+ G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( J, K ) )
+ 80 CONTINUE
+ 90 CONTINUE
+ END IF
+ DO 100 I = ISTART, ISTOP
+ CT( I ) = ALPHA*CT( I ) + BETA*C( I, J )
+ G( I ) = ABS( ALPHA )*G( I ) + ABS( BETA )*ABS( C( I, J ) )
+ 100 CONTINUE
+*
+* Compute the error ratio for this result.
+*
+ ERR = ZERO
+ DO 110 I = ISTART, ISTOP
+ ERRI = ABS( CT( I ) - CC( I, J ) )/EPS
+ IF( G( I ).NE.ZERO )
+ $ ERRI = ERRI/G( I )
+ ERR = MAX( ERR, ERRI )
+ IF( ERR*SQRT( EPS ).GE.ONE )
+ $ GO TO 130
+ 110 CONTINUE
+*
+ 120 CONTINUE
+*
+* If the loop completes, all results are at least half accurate.
+ GO TO 150
+*
+* Report fatal error.
+*
+ 130 FATAL = .TRUE.
+ WRITE( NOUT, FMT = 9999 )
+ DO 140 I = ISTART, ISTOP
+ IF( MV )THEN
+ WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J )
+ ELSE
+ WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I )
+ END IF
+ 140 CONTINUE
+ IF( N.GT.1 )
+ $ WRITE( NOUT, FMT = 9997 )J
+*
+ 150 CONTINUE
+ RETURN
+*
+ 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
+ $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU',
+ $ 'TED RESULT' )
+ 9998 FORMAT( 1X, I7, 2G18.6 )
+ 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
+*
+* End of SMMTCH
+*
+ END
+
+
diff --git a/ctest/c_zblas3.c b/ctest/c_zblas3.c
index aac46ddfa2..8102c9228d 100644
--- a/ctest/c_zblas3.c
+++ b/ctest/c_zblas3.c
@@ -5,28 +5,33 @@
* Modified by T. H. Do, 4/15/98, SGI/CRAY Research.
*/
#include <stdlib.h>
-#include "common.h"
+#include <stdio.h>
+#include "cblas.h"
#include "cblas_test.h"
#define TEST_COL_MJR 0
#define TEST_ROW_MJR 1
#define UNDEFINED -1
-void F77_zgemm(int *order, char *transpa, char *transpb, int *m, int *n,
+void F77_zgemm(int *layout, char *transpa, char *transpb, int *m, int *n,
int *k, CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, int *lda,
CBLAS_TEST_ZOMPLEX *b, int *ldb, CBLAS_TEST_ZOMPLEX *beta,
- CBLAS_TEST_ZOMPLEX *c, int *ldc ) {
+ CBLAS_TEST_ZOMPLEX *c, int *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN transpa_len, FORTRAN_STRLEN transpb_len
+#endif
+) {
CBLAS_TEST_ZOMPLEX *A, *B, *C;
int i,j,LDA, LDB, LDC;
- enum CBLAS_TRANSPOSE transa, transb;
+ CBLAS_TRANSPOSE transa, transb;
get_transpose_type(transpa, &transa);
get_transpose_type(transpb, &transb);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (transa == CblasNoTrans) {
LDA = *k+1;
- A=(CBLAS_TEST_ZOMPLEX*)malloc((*m)*(size_t)LDA*sizeof(CBLAS_TEST_ZOMPLEX));
+ A=(CBLAS_TEST_ZOMPLEX*)malloc((*m)*LDA*sizeof(CBLAS_TEST_ZOMPLEX));
for( i=0; i<*m; i++ )
for( j=0; j<*k; j++ ) {
A[i*LDA+j].real=a[j*(*lda)+i].real;
@@ -35,7 +40,7 @@ void F77_zgemm(int *order, char *transpa, char *transpb, int *m, int *n,
}
else {
LDA = *m+1;
- A=(CBLAS_TEST_ZOMPLEX* )malloc((size_t)LDA*(*k)*sizeof(CBLAS_TEST_ZOMPLEX));
+ A=(CBLAS_TEST_ZOMPLEX* )malloc(LDA*(*k)*sizeof(CBLAS_TEST_ZOMPLEX));
for( i=0; i<*k; i++ )
for( j=0; j<*m; j++ ) {
A[i*LDA+j].real=a[j*(*lda)+i].real;
@@ -45,7 +50,7 @@ void F77_zgemm(int *order, char *transpa, char *transpb, int *m, int *n,
if (transb == CblasNoTrans) {
LDB = *n+1;
- B=(CBLAS_TEST_ZOMPLEX* )malloc((*k)*(size_t)LDB*sizeof(CBLAS_TEST_ZOMPLEX) );
+ B=(CBLAS_TEST_ZOMPLEX* )malloc((*k)*LDB*sizeof(CBLAS_TEST_ZOMPLEX) );
for( i=0; i<*k; i++ )
for( j=0; j<*n; j++ ) {
B[i*LDB+j].real=b[j*(*ldb)+i].real;
@@ -54,7 +59,7 @@ void F77_zgemm(int *order, char *transpa, char *transpb, int *m, int *n,
}
else {
LDB = *k+1;
- B=(CBLAS_TEST_ZOMPLEX* )malloc((size_t)LDB*(*n)*sizeof(CBLAS_TEST_ZOMPLEX));
+ B=(CBLAS_TEST_ZOMPLEX* )malloc(LDB*(*n)*sizeof(CBLAS_TEST_ZOMPLEX));
for( i=0; i<*n; i++ )
for( j=0; j<*k; j++ ) {
B[i*LDB+j].real=b[j*(*ldb)+i].real;
@@ -63,7 +68,7 @@ void F77_zgemm(int *order, char *transpa, char *transpb, int *m, int *n,
}
LDC = *n+1;
- C=(CBLAS_TEST_ZOMPLEX* )malloc((*m)*(size_t)LDC*sizeof(CBLAS_TEST_ZOMPLEX));
+ C=(CBLAS_TEST_ZOMPLEX* )malloc((*m)*LDC*sizeof(CBLAS_TEST_ZOMPLEX));
for( j=0; j<*n; j++ )
for( i=0; i<*m; i++ ) {
C[i*LDC+j].real=c[j*(*ldc)+i].real;
@@ -80,30 +85,116 @@ void F77_zgemm(int *order, char *transpa, char *transpb, int *m, int *n,
free(B);
free(C);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_zgemm( CblasColMajor, transa, transb, *m, *n, *k, alpha, a, *lda,
b, *ldb, beta, c, *ldc );
else
cblas_zgemm( UNDEFINED, transa, transb, *m, *n, *k, alpha, a, *lda,
b, *ldb, beta, c, *ldc );
}
-void F77_zhemm(int *order, char *rtlf, char *uplow, int *m, int *n,
+
+
+void F77_zgemmtr(int *layout, char *uplop, char *transpa, char *transpb, int *n,
+ int *k, CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, int *lda,
+ CBLAS_TEST_ZOMPLEX *b, int *ldb, CBLAS_TEST_ZOMPLEX *beta,
+ CBLAS_TEST_ZOMPLEX *c, int *ldc ) {
+
+ CBLAS_TEST_ZOMPLEX *A, *B, *C;
+ int i,j,LDA, LDB, LDC;
+ CBLAS_TRANSPOSE transa, transb;
+ CBLAS_UPLO uplo;
+
+ get_transpose_type(transpa, &transa);
+ get_transpose_type(transpb, &transb);
+ get_uplo_type(uplop, &uplo);
+
+ if (*layout == TEST_ROW_MJR) {
+ if (transa == CblasNoTrans) {
+ LDA = *k+1;
+ A=(CBLAS_TEST_ZOMPLEX*)malloc((*n)*LDA*sizeof(CBLAS_TEST_ZOMPLEX));
+ for( i=0; i<*n; i++ )
+ for( j=0; j<*k; j++ ) {
+ A[i*LDA+j].real=a[j*(*lda)+i].real;
+ A[i*LDA+j].imag=a[j*(*lda)+i].imag;
+ }
+ }
+ else {
+ LDA = *n+1;
+ A=(CBLAS_TEST_ZOMPLEX* )malloc(LDA*(*k)*sizeof(CBLAS_TEST_ZOMPLEX));
+ for( i=0; i<*k; i++ )
+ for( j=0; j<*n; j++ ) {
+ A[i*LDA+j].real=a[j*(*lda)+i].real;
+ A[i*LDA+j].imag=a[j*(*lda)+i].imag;
+ }
+ }
+
+ if (transb == CblasNoTrans) {
+ LDB = *n+1;
+ B=(CBLAS_TEST_ZOMPLEX* )malloc((*k)*LDB*sizeof(CBLAS_TEST_ZOMPLEX) );
+ for( i=0; i<*k; i++ )
+ for( j=0; j<*n; j++ ) {
+ B[i*LDB+j].real=b[j*(*ldb)+i].real;
+ B[i*LDB+j].imag=b[j*(*ldb)+i].imag;
+ }
+ }
+ else {
+ LDB = *k+1;
+ B=(CBLAS_TEST_ZOMPLEX* )malloc(LDB*(*n)*sizeof(CBLAS_TEST_ZOMPLEX));
+ for( i=0; i<*n; i++ )
+ for( j=0; j<*k; j++ ) {
+ B[i*LDB+j].real=b[j*(*ldb)+i].real;
+ B[i*LDB+j].imag=b[j*(*ldb)+i].imag;
+ }
+ }
+
+ LDC = *n+1;
+ C=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*LDC*sizeof(CBLAS_TEST_ZOMPLEX));
+ for( j=0; j<*n; j++ )
+ for( i=0; i<*n; i++ ) {
+ C[i*LDC+j].real=c[j*(*ldc)+i].real;
+ C[i*LDC+j].imag=c[j*(*ldc)+i].imag;
+ }
+ cblas_zgemmtr( CblasRowMajor, uplo, transa, transb, *n, *k, alpha, A, LDA,
+ B, LDB, beta, C, LDC );
+ for( j=0; j<*n; j++ )
+ for( i=0; i<*n; i++ ) {
+ c[j*(*ldc)+i].real=C[i*LDC+j].real;
+ c[j*(*ldc)+i].imag=C[i*LDC+j].imag;
+ }
+ free(A);
+ free(B);
+ free(C);
+ }
+ else if (*layout == TEST_COL_MJR)
+ cblas_zgemmtr( CblasColMajor, uplo, transa, transb, *n, *k, alpha, a, *lda,
+ b, *ldb, beta, c, *ldc );
+ else
+ cblas_zgemmtr( UNDEFINED, uplo, transa, transb, *n, *k, alpha, a, *lda,
+ b, *ldb, beta, c, *ldc );
+}
+
+
+void F77_zhemm(int *layout, char *rtlf, char *uplow, int *m, int *n,
CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, int *lda,
CBLAS_TEST_ZOMPLEX *b, int *ldb, CBLAS_TEST_ZOMPLEX *beta,
- CBLAS_TEST_ZOMPLEX *c, int *ldc ) {
+ CBLAS_TEST_ZOMPLEX *c, int *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len
+#endif
+) {
CBLAS_TEST_ZOMPLEX *A, *B, *C;
int i,j,LDA, LDB, LDC;
- enum CBLAS_UPLO uplo;
- enum CBLAS_SIDE side;
+ CBLAS_UPLO uplo;
+ CBLAS_SIDE side;
get_uplo_type(uplow,&uplo);
get_side_type(rtlf,&side);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (side == CblasLeft) {
LDA = *m+1;
- A= (CBLAS_TEST_ZOMPLEX* )malloc((*m)*(size_t)LDA*sizeof(CBLAS_TEST_ZOMPLEX));
+ A= (CBLAS_TEST_ZOMPLEX* )malloc((*m)*LDA*sizeof(CBLAS_TEST_ZOMPLEX));
for( i=0; i<*m; i++ )
for( j=0; j<*m; j++ ) {
A[i*LDA+j].real=a[j*(*lda)+i].real;
@@ -112,7 +203,7 @@ void F77_zhemm(int *order, char *rtlf, char *uplow, int *m, int *n,
}
else{
LDA = *n+1;
- A=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*(size_t)LDA*sizeof(CBLAS_TEST_ZOMPLEX ) );
+ A=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_ZOMPLEX ) );
for( i=0; i<*n; i++ )
for( j=0; j<*n; j++ ) {
A[i*LDA+j].real=a[j*(*lda)+i].real;
@@ -120,14 +211,14 @@ void F77_zhemm(int *order, char *rtlf, char *uplow, int *m, int *n,
}
}
LDB = *n+1;
- B=(CBLAS_TEST_ZOMPLEX* )malloc( (*m)*(size_t)LDB*sizeof(CBLAS_TEST_ZOMPLEX ) );
+ B=(CBLAS_TEST_ZOMPLEX* )malloc( (*m)*LDB*sizeof(CBLAS_TEST_ZOMPLEX ) );
for( i=0; i<*m; i++ )
for( j=0; j<*n; j++ ) {
B[i*LDB+j].real=b[j*(*ldb)+i].real;
B[i*LDB+j].imag=b[j*(*ldb)+i].imag;
}
LDC = *n+1;
- C=(CBLAS_TEST_ZOMPLEX* )malloc((*m)*(size_t)LDC*sizeof(CBLAS_TEST_ZOMPLEX ) );
+ C=(CBLAS_TEST_ZOMPLEX* )malloc((*m)*LDC*sizeof(CBLAS_TEST_ZOMPLEX ) );
for( j=0; j<*n; j++ )
for( i=0; i<*m; i++ ) {
C[i*LDC+j].real=c[j*(*ldc)+i].real;
@@ -144,48 +235,52 @@ void F77_zhemm(int *order, char *rtlf, char *uplow, int *m, int *n,
free(B);
free(C);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_zhemm( CblasColMajor, side, uplo, *m, *n, alpha, a, *lda, b, *ldb,
beta, c, *ldc );
else
cblas_zhemm( UNDEFINED, side, uplo, *m, *n, alpha, a, *lda, b, *ldb,
beta, c, *ldc );
}
-void F77_zsymm(int *order, char *rtlf, char *uplow, int *m, int *n,
+void F77_zsymm(int *layout, char *rtlf, char *uplow, int *m, int *n,
CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, int *lda,
CBLAS_TEST_ZOMPLEX *b, int *ldb, CBLAS_TEST_ZOMPLEX *beta,
- CBLAS_TEST_ZOMPLEX *c, int *ldc ) {
+ CBLAS_TEST_ZOMPLEX *c, int *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len
+#endif
+) {
CBLAS_TEST_ZOMPLEX *A, *B, *C;
int i,j,LDA, LDB, LDC;
- enum CBLAS_UPLO uplo;
- enum CBLAS_SIDE side;
+ CBLAS_UPLO uplo;
+ CBLAS_SIDE side;
get_uplo_type(uplow,&uplo);
get_side_type(rtlf,&side);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (side == CblasLeft) {
LDA = *m+1;
- A=(CBLAS_TEST_ZOMPLEX* )malloc((*m)*(size_t)LDA*sizeof(CBLAS_TEST_ZOMPLEX));
+ A=(CBLAS_TEST_ZOMPLEX* )malloc((*m)*LDA*sizeof(CBLAS_TEST_ZOMPLEX));
for( i=0; i<*m; i++ )
for( j=0; j<*m; j++ )
A[i*LDA+j]=a[j*(*lda)+i];
}
else{
LDA = *n+1;
- A=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*(size_t)LDA*sizeof(CBLAS_TEST_ZOMPLEX ) );
+ A=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_ZOMPLEX ) );
for( i=0; i<*n; i++ )
for( j=0; j<*n; j++ )
A[i*LDA+j]=a[j*(*lda)+i];
}
LDB = *n+1;
- B=(CBLAS_TEST_ZOMPLEX* )malloc((*m)*(size_t)LDB*sizeof(CBLAS_TEST_ZOMPLEX ));
+ B=(CBLAS_TEST_ZOMPLEX* )malloc((*m)*LDB*sizeof(CBLAS_TEST_ZOMPLEX ));
for( i=0; i<*m; i++ )
for( j=0; j<*n; j++ )
B[i*LDB+j]=b[j*(*ldb)+i];
LDC = *n+1;
- C=(CBLAS_TEST_ZOMPLEX* )malloc((*m)*(size_t)LDC*sizeof(CBLAS_TEST_ZOMPLEX));
+ C=(CBLAS_TEST_ZOMPLEX* )malloc((*m)*LDC*sizeof(CBLAS_TEST_ZOMPLEX));
for( j=0; j<*n; j++ )
for( i=0; i<*m; i++ )
C[i*LDC+j]=c[j*(*ldc)+i];
@@ -198,7 +293,7 @@ void F77_zsymm(int *order, char *rtlf, char *uplow, int *m, int *n,
free(B);
free(C);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_zsymm( CblasColMajor, side, uplo, *m, *n, alpha, a, *lda, b, *ldb,
beta, c, *ldc );
else
@@ -206,22 +301,26 @@ void F77_zsymm(int *order, char *rtlf, char *uplow, int *m, int *n,
beta, c, *ldc );
}
-void F77_zherk(int *order, char *uplow, char *transp, int *n, int *k,
+void F77_zherk(int *layout, char *uplow, char *transp, int *n, int *k,
double *alpha, CBLAS_TEST_ZOMPLEX *a, int *lda,
- double *beta, CBLAS_TEST_ZOMPLEX *c, int *ldc ) {
+ double *beta, CBLAS_TEST_ZOMPLEX *c, int *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len
+#endif
+) {
int i,j,LDA,LDC;
CBLAS_TEST_ZOMPLEX *A, *C;
- enum CBLAS_UPLO uplo;
- enum CBLAS_TRANSPOSE trans;
+ CBLAS_UPLO uplo;
+ CBLAS_TRANSPOSE trans;
get_uplo_type(uplow,&uplo);
get_transpose_type(transp,&trans);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (trans == CblasNoTrans) {
LDA = *k+1;
- A=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*(size_t)LDA*sizeof(CBLAS_TEST_ZOMPLEX ) );
+ A=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_ZOMPLEX ) );
for( i=0; i<*n; i++ )
for( j=0; j<*k; j++ ) {
A[i*LDA+j].real=a[j*(*lda)+i].real;
@@ -230,7 +329,7 @@ void F77_zherk(int *order, char *uplow, char *transp, int *n, int *k,
}
else{
LDA = *n+1;
- A=(CBLAS_TEST_ZOMPLEX* )malloc((*k)*(size_t)LDA*sizeof(CBLAS_TEST_ZOMPLEX ) );
+ A=(CBLAS_TEST_ZOMPLEX* )malloc((*k)*LDA*sizeof(CBLAS_TEST_ZOMPLEX ) );
for( i=0; i<*k; i++ )
for( j=0; j<*n; j++ ) {
A[i*LDA+j].real=a[j*(*lda)+i].real;
@@ -238,7 +337,7 @@ void F77_zherk(int *order, char *uplow, char *transp, int *n, int *k,
}
}
LDC = *n+1;
- C=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*(size_t)LDC*sizeof(CBLAS_TEST_ZOMPLEX ) );
+ C=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*LDC*sizeof(CBLAS_TEST_ZOMPLEX ) );
for( i=0; i<*n; i++ )
for( j=0; j<*n; j++ ) {
C[i*LDC+j].real=c[j*(*ldc)+i].real;
@@ -254,7 +353,7 @@ void F77_zherk(int *order, char *uplow, char *transp, int *n, int *k,
free(A);
free(C);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_zherk(CblasColMajor, uplo, trans, *n, *k, *alpha, a, *lda, *beta,
c, *ldc );
else
@@ -262,22 +361,26 @@ void F77_zherk(int *order, char *uplow, char *transp, int *n, int *k,
c, *ldc );
}
-void F77_zsyrk(int *order, char *uplow, char *transp, int *n, int *k,
+void F77_zsyrk(int *layout, char *uplow, char *transp, int *n, int *k,
CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, int *lda,
- CBLAS_TEST_ZOMPLEX *beta, CBLAS_TEST_ZOMPLEX *c, int *ldc ) {
+ CBLAS_TEST_ZOMPLEX *beta, CBLAS_TEST_ZOMPLEX *c, int *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len
+#endif
+) {
int i,j,LDA,LDC;
CBLAS_TEST_ZOMPLEX *A, *C;
- enum CBLAS_UPLO uplo;
- enum CBLAS_TRANSPOSE trans;
+ CBLAS_UPLO uplo;
+ CBLAS_TRANSPOSE trans;
get_uplo_type(uplow,&uplo);
get_transpose_type(transp,&trans);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (trans == CblasNoTrans) {
LDA = *k+1;
- A=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*(size_t)LDA*sizeof(CBLAS_TEST_ZOMPLEX));
+ A=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_ZOMPLEX));
for( i=0; i<*n; i++ )
for( j=0; j<*k; j++ ) {
A[i*LDA+j].real=a[j*(*lda)+i].real;
@@ -286,7 +389,7 @@ void F77_zsyrk(int *order, char *uplow, char *transp, int *n, int *k,
}
else{
LDA = *n+1;
- A=(CBLAS_TEST_ZOMPLEX* )malloc((*k)*(size_t)LDA*sizeof(CBLAS_TEST_ZOMPLEX ) );
+ A=(CBLAS_TEST_ZOMPLEX* )malloc((*k)*LDA*sizeof(CBLAS_TEST_ZOMPLEX ) );
for( i=0; i<*k; i++ )
for( j=0; j<*n; j++ ) {
A[i*LDA+j].real=a[j*(*lda)+i].real;
@@ -294,7 +397,7 @@ void F77_zsyrk(int *order, char *uplow, char *transp, int *n, int *k,
}
}
LDC = *n+1;
- C=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*(size_t)LDC*sizeof(CBLAS_TEST_ZOMPLEX ) );
+ C=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*LDC*sizeof(CBLAS_TEST_ZOMPLEX ) );
for( i=0; i<*n; i++ )
for( j=0; j<*n; j++ ) {
C[i*LDC+j].real=c[j*(*ldc)+i].real;
@@ -310,31 +413,35 @@ void F77_zsyrk(int *order, char *uplow, char *transp, int *n, int *k,
free(A);
free(C);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_zsyrk(CblasColMajor, uplo, trans, *n, *k, alpha, a, *lda, beta,
c, *ldc );
else
cblas_zsyrk(UNDEFINED, uplo, trans, *n, *k, alpha, a, *lda, beta,
c, *ldc );
}
-void F77_zher2k(int *order, char *uplow, char *transp, int *n, int *k,
+void F77_zher2k(int *layout, char *uplow, char *transp, int *n, int *k,
CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, int *lda,
CBLAS_TEST_ZOMPLEX *b, int *ldb, double *beta,
- CBLAS_TEST_ZOMPLEX *c, int *ldc ) {
+ CBLAS_TEST_ZOMPLEX *c, int *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len
+#endif
+) {
int i,j,LDA,LDB,LDC;
CBLAS_TEST_ZOMPLEX *A, *B, *C;
- enum CBLAS_UPLO uplo;
- enum CBLAS_TRANSPOSE trans;
+ CBLAS_UPLO uplo;
+ CBLAS_TRANSPOSE trans;
get_uplo_type(uplow,&uplo);
get_transpose_type(transp,&trans);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (trans == CblasNoTrans) {
LDA = *k+1;
LDB = *k+1;
- A=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*(size_t)LDA*sizeof(CBLAS_TEST_ZOMPLEX ));
- B=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*(size_t)LDB*sizeof(CBLAS_TEST_ZOMPLEX ));
+ A=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_ZOMPLEX ));
+ B=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*LDB*sizeof(CBLAS_TEST_ZOMPLEX ));
for( i=0; i<*n; i++ )
for( j=0; j<*k; j++ ) {
A[i*LDA+j].real=a[j*(*lda)+i].real;
@@ -346,8 +453,8 @@ void F77_zher2k(int *order, char *uplow, char *transp, int *n, int *k,
else {
LDA = *n+1;
LDB = *n+1;
- A=(CBLAS_TEST_ZOMPLEX* )malloc( (size_t)LDA*(*k)*sizeof(CBLAS_TEST_ZOMPLEX ) );
- B=(CBLAS_TEST_ZOMPLEX* )malloc( (size_t)LDB*(*k)*sizeof(CBLAS_TEST_ZOMPLEX ) );
+ A=(CBLAS_TEST_ZOMPLEX* )malloc( LDA*(*k)*sizeof(CBLAS_TEST_ZOMPLEX ) );
+ B=(CBLAS_TEST_ZOMPLEX* )malloc( LDB*(*k)*sizeof(CBLAS_TEST_ZOMPLEX ) );
for( i=0; i<*k; i++ )
for( j=0; j<*n; j++ ){
A[i*LDA+j].real=a[j*(*lda)+i].real;
@@ -357,7 +464,7 @@ void F77_zher2k(int *order, char *uplow, char *transp, int *n, int *k,
}
}
LDC = *n+1;
- C=(CBLAS_TEST_ZOMPLEX* )malloc( (*n)*(size_t)LDC*sizeof(CBLAS_TEST_ZOMPLEX ) );
+ C=(CBLAS_TEST_ZOMPLEX* )malloc( (*n)*LDC*sizeof(CBLAS_TEST_ZOMPLEX ) );
for( i=0; i<*n; i++ )
for( j=0; j<*n; j++ ) {
C[i*LDC+j].real=c[j*(*ldc)+i].real;
@@ -374,31 +481,35 @@ void F77_zher2k(int *order, char *uplow, char *transp, int *n, int *k,
free(B);
free(C);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_zher2k(CblasColMajor, uplo, trans, *n, *k, alpha, a, *lda,
b, *ldb, *beta, c, *ldc );
else
cblas_zher2k(UNDEFINED, uplo, trans, *n, *k, alpha, a, *lda,
b, *ldb, *beta, c, *ldc );
}
-void F77_zsyr2k(int *order, char *uplow, char *transp, int *n, int *k,
+void F77_zsyr2k(int *layout, char *uplow, char *transp, int *n, int *k,
CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, int *lda,
CBLAS_TEST_ZOMPLEX *b, int *ldb, CBLAS_TEST_ZOMPLEX *beta,
- CBLAS_TEST_ZOMPLEX *c, int *ldc ) {
+ CBLAS_TEST_ZOMPLEX *c, int *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len
+#endif
+) {
int i,j,LDA,LDB,LDC;
CBLAS_TEST_ZOMPLEX *A, *B, *C;
- enum CBLAS_UPLO uplo;
- enum CBLAS_TRANSPOSE trans;
+ CBLAS_UPLO uplo;
+ CBLAS_TRANSPOSE trans;
get_uplo_type(uplow,&uplo);
get_transpose_type(transp,&trans);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (trans == CblasNoTrans) {
LDA = *k+1;
LDB = *k+1;
- A=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*(size_t)LDA*sizeof(CBLAS_TEST_ZOMPLEX));
- B=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*(size_t)LDB*sizeof(CBLAS_TEST_ZOMPLEX));
+ A=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_ZOMPLEX));
+ B=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*LDB*sizeof(CBLAS_TEST_ZOMPLEX));
for( i=0; i<*n; i++ )
for( j=0; j<*k; j++ ) {
A[i*LDA+j].real=a[j*(*lda)+i].real;
@@ -410,8 +521,8 @@ void F77_zsyr2k(int *order, char *uplow, char *transp, int *n, int *k,
else {
LDA = *n+1;
LDB = *n+1;
- A=(CBLAS_TEST_ZOMPLEX* )malloc((size_t)LDA*(*k)*sizeof(CBLAS_TEST_ZOMPLEX));
- B=(CBLAS_TEST_ZOMPLEX* )malloc((size_t)LDB*(*k)*sizeof(CBLAS_TEST_ZOMPLEX));
+ A=(CBLAS_TEST_ZOMPLEX* )malloc(LDA*(*k)*sizeof(CBLAS_TEST_ZOMPLEX));
+ B=(CBLAS_TEST_ZOMPLEX* )malloc(LDB*(*k)*sizeof(CBLAS_TEST_ZOMPLEX));
for( i=0; i<*k; i++ )
for( j=0; j<*n; j++ ){
A[i*LDA+j].real=a[j*(*lda)+i].real;
@@ -421,7 +532,7 @@ void F77_zsyr2k(int *order, char *uplow, char *transp, int *n, int *k,
}
}
LDC = *n+1;
- C=(CBLAS_TEST_ZOMPLEX* )malloc( (*n)*(size_t)LDC*sizeof(CBLAS_TEST_ZOMPLEX));
+ C=(CBLAS_TEST_ZOMPLEX* )malloc( (*n)*LDC*sizeof(CBLAS_TEST_ZOMPLEX));
for( i=0; i<*n; i++ )
for( j=0; j<*n; j++ ) {
C[i*LDC+j].real=c[j*(*ldc)+i].real;
@@ -438,32 +549,36 @@ void F77_zsyr2k(int *order, char *uplow, char *transp, int *n, int *k,
free(B);
free(C);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_zsyr2k(CblasColMajor, uplo, trans, *n, *k, alpha, a, *lda,
b, *ldb, beta, c, *ldc );
else
cblas_zsyr2k(UNDEFINED, uplo, trans, *n, *k, alpha, a, *lda,
b, *ldb, beta, c, *ldc );
}
-void F77_ztrmm(int *order, char *rtlf, char *uplow, char *transp, char *diagn,
+void F77_ztrmm(int *layout, char *rtlf, char *uplow, char *transp, char *diagn,
int *m, int *n, CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a,
- int *lda, CBLAS_TEST_ZOMPLEX *b, int *ldb) {
+ int *lda, CBLAS_TEST_ZOMPLEX *b, int *ldb
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
int i,j,LDA,LDB;
CBLAS_TEST_ZOMPLEX *A, *B;
- enum CBLAS_SIDE side;
- enum CBLAS_DIAG diag;
- enum CBLAS_UPLO uplo;
- enum CBLAS_TRANSPOSE trans;
+ CBLAS_SIDE side;
+ CBLAS_DIAG diag;
+ CBLAS_UPLO uplo;
+ CBLAS_TRANSPOSE trans;
get_uplo_type(uplow,&uplo);
get_transpose_type(transp,&trans);
get_diag_type(diagn,&diag);
get_side_type(rtlf,&side);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (side == CblasLeft) {
LDA = *m+1;
- A=(CBLAS_TEST_ZOMPLEX* )malloc((*m)*(size_t)LDA*sizeof(CBLAS_TEST_ZOMPLEX));
+ A=(CBLAS_TEST_ZOMPLEX* )malloc((*m)*LDA*sizeof(CBLAS_TEST_ZOMPLEX));
for( i=0; i<*m; i++ )
for( j=0; j<*m; j++ ) {
A[i*LDA+j].real=a[j*(*lda)+i].real;
@@ -472,7 +587,7 @@ void F77_ztrmm(int *order, char *rtlf, char *uplow, char *transp, char *diagn,
}
else{
LDA = *n+1;
- A=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*(size_t)LDA*sizeof(CBLAS_TEST_ZOMPLEX));
+ A=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_ZOMPLEX));
for( i=0; i<*n; i++ )
for( j=0; j<*n; j++ ) {
A[i*LDA+j].real=a[j*(*lda)+i].real;
@@ -480,7 +595,7 @@ void F77_ztrmm(int *order, char *rtlf, char *uplow, char *transp, char *diagn,
}
}
LDB = *n+1;
- B=(CBLAS_TEST_ZOMPLEX* )malloc((*m)*(size_t)LDB*sizeof(CBLAS_TEST_ZOMPLEX));
+ B=(CBLAS_TEST_ZOMPLEX* )malloc((*m)*LDB*sizeof(CBLAS_TEST_ZOMPLEX));
for( i=0; i<*m; i++ )
for( j=0; j<*n; j++ ) {
B[i*LDB+j].real=b[j*(*ldb)+i].real;
@@ -496,7 +611,7 @@ void F77_ztrmm(int *order, char *rtlf, char *uplow, char *transp, char *diagn,
free(A);
free(B);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_ztrmm(CblasColMajor, side, uplo, trans, diag, *m, *n, alpha,
a, *lda, b, *ldb);
else
@@ -504,25 +619,29 @@ void F77_ztrmm(int *order, char *rtlf, char *uplow, char *transp, char *diagn,
a, *lda, b, *ldb);
}
-void F77_ztrsm(int *order, char *rtlf, char *uplow, char *transp, char *diagn,
+void F77_ztrsm(int *layout, char *rtlf, char *uplow, char *transp, char *diagn,
int *m, int *n, CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a,
- int *lda, CBLAS_TEST_ZOMPLEX *b, int *ldb) {
+ int *lda, CBLAS_TEST_ZOMPLEX *b, int *ldb
+#ifdef BLAS_FORTRAN_STRLEN_END
+ , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
int i,j,LDA,LDB;
CBLAS_TEST_ZOMPLEX *A, *B;
- enum CBLAS_SIDE side;
- enum CBLAS_DIAG diag;
- enum CBLAS_UPLO uplo;
- enum CBLAS_TRANSPOSE trans;
+ CBLAS_SIDE side;
+ CBLAS_DIAG diag;
+ CBLAS_UPLO uplo;
+ CBLAS_TRANSPOSE trans;
get_uplo_type(uplow,&uplo);
get_transpose_type(transp,&trans);
get_diag_type(diagn,&diag);
get_side_type(rtlf,&side);
- if (*order == TEST_ROW_MJR) {
+ if (*layout == TEST_ROW_MJR) {
if (side == CblasLeft) {
LDA = *m+1;
- A=(CBLAS_TEST_ZOMPLEX* )malloc( (*m)*(size_t)LDA*sizeof(CBLAS_TEST_ZOMPLEX ) );
+ A=(CBLAS_TEST_ZOMPLEX* )malloc( (*m)*LDA*sizeof(CBLAS_TEST_ZOMPLEX ) );
for( i=0; i<*m; i++ )
for( j=0; j<*m; j++ ) {
A[i*LDA+j].real=a[j*(*lda)+i].real;
@@ -531,7 +650,7 @@ void F77_ztrsm(int *order, char *rtlf, char *uplow, char *transp, char *diagn,
}
else{
LDA = *n+1;
- A=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*(size_t)LDA*sizeof(CBLAS_TEST_ZOMPLEX));
+ A=(CBLAS_TEST_ZOMPLEX* )malloc((*n)*LDA*sizeof(CBLAS_TEST_ZOMPLEX));
for( i=0; i<*n; i++ )
for( j=0; j<*n; j++ ) {
A[i*LDA+j].real=a[j*(*lda)+i].real;
@@ -539,7 +658,7 @@ void F77_ztrsm(int *order, char *rtlf, char *uplow, char *transp, char *diagn,
}
}
LDB = *n+1;
- B=(CBLAS_TEST_ZOMPLEX* )malloc((*m)*(size_t)LDB*sizeof(CBLAS_TEST_ZOMPLEX));
+ B=(CBLAS_TEST_ZOMPLEX* )malloc((*m)*LDB*sizeof(CBLAS_TEST_ZOMPLEX));
for( i=0; i<*m; i++ )
for( j=0; j<*n; j++ ) {
B[i*LDB+j].real=b[j*(*ldb)+i].real;
@@ -555,12 +674,10 @@ void F77_ztrsm(int *order, char *rtlf, char *uplow, char *transp, char *diagn,
free(A);
free(B);
}
- else if (*order == TEST_COL_MJR)
+ else if (*layout == TEST_COL_MJR)
cblas_ztrsm(CblasColMajor, side, uplo, trans, diag, *m, *n, alpha,
a, *lda, b, *ldb);
else
cblas_ztrsm(UNDEFINED, side, uplo, trans, diag, *m, *n, alpha,
a, *lda, b, *ldb);
}
-
-
diff --git a/ctest/c_zblat3.f b/ctest/c_zblat3.f
index e14f5af65a..23ee361acc 100644
--- a/ctest/c_zblat3.f
+++ b/ctest/c_zblat3.f
@@ -4,13 +4,13 @@ PROGRAM ZBLAT3
*
* 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
+* are read using the format ( A13,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 ERROR STOP ON FAILURES.
+* 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
@@ -20,16 +20,17 @@ PROGRAM ZBLAT3
* (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.
-*
+* cblas_zgemm T PUT F FOR NO TEST. SAME COLUMNS.
+* cblas_zhemm T PUT F FOR NO TEST. SAME COLUMNS.
+* cblas_zsymm T PUT F FOR NO TEST. SAME COLUMNS.
+* cblas_ztrmm T PUT F FOR NO TEST. SAME COLUMNS.
+* cblas_ztrsm T PUT F FOR NO TEST. SAME COLUMNS.
+* cblas_zherk T PUT F FOR NO TEST. SAME COLUMNS.
+* cblas_zsyrk T PUT F FOR NO TEST. SAME COLUMNS.
+* cblas_zher2k T PUT F FOR NO TEST. SAME COLUMNS.
+* cblas_zsyr2k T PUT F FOR NO TEST. SAME COLUMNS.
+* cblas_zgemmtr T PUT F FOR NO TEST. SAME COLUMNS.
+
* See:
*
* Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S.
@@ -49,7 +50,7 @@ PROGRAM ZBLAT3
INTEGER NIN, NOUT
PARAMETER ( NIN = 5, NOUT = 6 )
INTEGER NSUBS
- PARAMETER ( NSUBS = 9 )
+ PARAMETER ( NSUBS = 10 )
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ),
$ ONE = ( 1.0D0, 0.0D0 ) )
@@ -66,7 +67,7 @@ PROGRAM ZBLAT3
LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
$ TSTERR, CORDER, RORDER
CHARACTER*1 TRANSA, TRANSB
- CHARACTER*12 SNAMET
+ CHARACTER*13 SNAMET
CHARACTER*32 SNAPS
* .. Local Arrays ..
COMPLEX*16 AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ),
@@ -78,19 +79,19 @@ PROGRAM ZBLAT3
DOUBLE PRECISION G( NMAX )
INTEGER IDIM( NIDMAX )
LOGICAL LTEST( NSUBS )
- CHARACTER*12 SNAMES( NSUBS )
+ CHARACTER*13 SNAMES( NSUBS )
* .. External Functions ..
DOUBLE PRECISION DDIFF
LOGICAL LZE
EXTERNAL DDIFF, LZE
* .. External Subroutines ..
- EXTERNAL ZCHK1, ZCHK2, ZCHK3, ZCHK4, ZCHK5,ZMMCH
+ EXTERNAL ZCHK1, ZCHK2, ZCHK3, ZCHK4, ZCHK5, ZCHK6, ZMMCH
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
- CHARACTER*12 SRNAMT
+ CHARACTER*13 SRNAMT
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
COMMON /SRNAMC/SRNAMT
@@ -98,7 +99,7 @@ PROGRAM ZBLAT3
DATA SNAMES/'cblas_zgemm ', 'cblas_zhemm ',
$ 'cblas_zsymm ', 'cblas_ztrmm ', 'cblas_ztrsm ',
$ 'cblas_zherk ', 'cblas_zsyrk ', 'cblas_zher2k',
- $ 'cblas_zsyr2k'/
+ $ 'cblas_zsyr2k', 'cblas_zgemmtr'/
* .. Executable Statements ..
*
NOUTC = NOUT
@@ -195,7 +196,7 @@ PROGRAM ZBLAT3
$ GO TO 50
40 CONTINUE
WRITE( NOUT, FMT = 9990 )SNAMET
- ERROR STOP
+ STOP
50 LTEST( I ) = LTESTT
GO TO 30
*
@@ -238,7 +239,7 @@ PROGRAM ZBLAT3
SAME = LZE( CC, CT, N )
IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
- ERROR STOP
+ STOP
END IF
TRANSB = 'C'
CALL ZMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
@@ -247,7 +248,7 @@ PROGRAM ZBLAT3
SAME = LZE( CC, CT, N )
IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
- ERROR STOP
+ STOP
END IF
DO 120 J = 1, N
AB( J, NMAX + 1 ) = N - J + 1
@@ -265,7 +266,7 @@ PROGRAM ZBLAT3
SAME = LZE( CC, CT, N )
IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
- ERROR STOP
+ STOP
END IF
TRANSB = 'C'
CALL ZMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
@@ -274,7 +275,7 @@ PROGRAM ZBLAT3
SAME = LZE( CC, CT, N )
IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
- ERROR STOP
+ STOP
END IF
*
* Test each subroutine in turn.
@@ -296,7 +297,7 @@ PROGRAM ZBLAT3
OK = .TRUE.
FATAL = .FALSE.
GO TO ( 140, 150, 150, 160, 160, 170, 170,
- $ 180, 180 )ISNUM
+ $ 180, 180, 185) ISNUM
* Test ZGEMM, 01.
140 IF (CORDER) THEN
CALL ZCHK1(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
@@ -330,13 +331,13 @@ PROGRAM ZBLAT3
CALL ZCHK3(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB,
$ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C,
- $ 0 )
+ $ 0 )
END IF
IF (RORDER) THEN
CALL ZCHK3(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB,
$ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C,
- $ 1 )
+ $ 1 )
END IF
GO TO 190
* Test ZHERK, 06, ZSYRK, 07.
@@ -358,13 +359,27 @@ PROGRAM ZBLAT3
CALL ZCHK5(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
$ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W,
- $ 0 )
+ $ 0 )
END IF
IF (RORDER) THEN
CALL ZCHK5(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
$ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
$ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W,
- $ 1 )
+ $ 1 )
+ END IF
+ GO TO 190
+* Test ZGEMMTR, 10
+ 185 IF (CORDER) THEN
+ CALL ZCHK6(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
+ $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
+ $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
+ $ CC, CS, CT, G, 0 )
+ END IF
+ IF (RORDER) THEN
+ CALL ZCHK6(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
+ $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
+ $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
+ $ CC, CS, CT, G, 1 )
END IF
GO TO 190
*
@@ -386,9 +401,7 @@ PROGRAM ZBLAT3
IF( TRACE )
$ CLOSE ( NTRA )
CLOSE ( NOUT )
- IF( FATAL ) THEN
- ERROR STOP
- END IF
+ STOP
*
10002 FORMAT( ' COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED' )
10001 FORMAT(' ROW-MAJOR DATA LAYOUT IS TESTED' )
@@ -408,7 +421,7 @@ PROGRAM ZBLAT3
$ 7( '(', F4.1, ',', F4.1, ') ', : ) )
9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
$ /' ******* TESTS ABANDONED *******' )
- 9990 FORMAT(' SUBPROGRAM NAME ', A12,' NOT RECOGNIZED', /' ******* T',
+ 9990 FORMAT(' SUBPROGRAM NAME ', A13,' NOT RECOGNIZED', /' ******* T',
$ 'ESTS ABANDONED *******' )
9989 FORMAT(' ERROR IN ZMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
$ 'ATED WRONGLY.', /' ZMMCH WAS CALLED WITH TRANSA = ', A1,
@@ -416,8 +429,8 @@ PROGRAM ZBLAT3
$ ' ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ',
$ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ',
$ '*******' )
- 9988 FORMAT( A12,L2 )
- 9987 FORMAT( 1X, A12,' WAS NOT TESTED' )
+ 9988 FORMAT( A13,L2 )
+ 9987 FORMAT( 1X, A13,' WAS NOT TESTED' )
9986 FORMAT( /' END OF TESTS' )
9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
@@ -449,7 +462,7 @@ SUBROUTINE ZCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
DOUBLE PRECISION EPS, THRESH
INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
LOGICAL FATAL, REWI, TRACE
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
* .. Array Arguments ..
COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), B( NMAX, NMAX ),
@@ -697,22 +710,22 @@ SUBROUTINE ZCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
130 CONTINUE
RETURN
*
-10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
+10003 FORMAT( ' ', A13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
+10002 FORMAT( ' ', A13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
+10001 FORMAT( ' ', A13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
-10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
+10000 FORMAT( ' ', A13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
- 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
-C 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',',
-C $ 3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3,
-C $ ',(', F4.1, ',', F4.1, '), C,', I3, ').' )
+ 9996 FORMAT( ' ******* ', A13,' FAILED ON CALL NUMBER:' )
+ 9995 FORMAT( 1X, I6, ': ', A13,'(''', A1, ''',''', A1, ''',',
+ $ 3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3,
+ $ ',(', F4.1, ',', F4.1, '), C,', I3, ').' )
9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
@@ -725,7 +738,7 @@ SUBROUTINE ZPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, M, N,
INTEGER NOUT, NC, IORDER, M, N, K, LDA, LDB, LDC
DOUBLE COMPLEX ALPHA, BETA
CHARACTER*1 TRANSA, TRANSB
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
CHARACTER*14 CRC, CTA,CTB
IF (TRANSA.EQ.'N')THEN
@@ -750,7 +763,7 @@ SUBROUTINE ZPRCN1(NOUT, NC, SNAME, IORDER, TRANSA, TRANSB, M, N,
WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CTA,CTB
WRITE(NOUT, FMT = 9994)M, N, K, ALPHA, LDA, LDB, BETA, LDC
- 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',')
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', A14, ',', A14, ',', A14, ',')
9994 FORMAT( 10X, 3( I3, ',' ) ,' (', F4.1,',',F4.1,') , A,',
$ I3, ', B,', I3, ', (', F4.1,',',F4.1,') , C,', I3, ').' )
END
@@ -779,7 +792,7 @@ SUBROUTINE ZCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
DOUBLE PRECISION EPS, THRESH
INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
LOGICAL FATAL, REWI, TRACE
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
* .. Array Arguments ..
COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), B( NMAX, NMAX ),
@@ -1023,22 +1036,22 @@ SUBROUTINE ZCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
120 CONTINUE
RETURN
*
-10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
+10003 FORMAT( ' ', A13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
+10002 FORMAT( ' ', A13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
+10001 FORMAT( ' ', A13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
-10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
+10000 FORMAT( ' ', A13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
- 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
-C 9995 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
-C $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1,
-C $ ',', F4.1, '), C,', I3, ') .' )
+ 9996 FORMAT( ' ******* ', A13,' FAILED ON CALL NUMBER:' )
+ 9995 FORMAT(1X, I6, ': ', A13,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
+ $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1,
+ $ ',', F4.1, '), C,', I3, ') .' )
9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
@@ -1051,7 +1064,7 @@ SUBROUTINE ZPRCN2(NOUT, NC, SNAME, IORDER, SIDE, UPLO, M, N,
INTEGER NOUT, NC, IORDER, M, N, LDA, LDB, LDC
DOUBLE COMPLEX ALPHA, BETA
CHARACTER*1 SIDE, UPLO
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
CHARACTER*14 CRC, CS,CU
IF (SIDE.EQ.'L')THEN
@@ -1072,7 +1085,7 @@ SUBROUTINE ZPRCN2(NOUT, NC, SNAME, IORDER, SIDE, UPLO, M, N,
WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CS,CU
WRITE(NOUT, FMT = 9994)M, N, ALPHA, LDA, LDB, BETA, LDC
- 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',')
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', A14, ',', A14, ',', A14, ',')
9994 FORMAT( 10X, 2( I3, ',' ),' (',F4.1,',',F4.1, '), A,', I3,
$ ', B,', I3, ', (',F4.1,',',F4.1, '), ', 'C,', I3, ').' )
END
@@ -1100,7 +1113,7 @@ SUBROUTINE ZCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
DOUBLE PRECISION EPS, THRESH
INTEGER NALF, NIDIM, NMAX, NOUT, NTRA, IORDER
LOGICAL FATAL, REWI, TRACE
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
* .. Array Arguments ..
COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), B( NMAX, NMAX ),
@@ -1375,22 +1388,22 @@ SUBROUTINE ZCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
160 CONTINUE
RETURN
*
-10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
+10003 FORMAT( ' ', A13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
+10002 FORMAT( ' ', A13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
+10001 FORMAT( ' ', A13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
-10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
+10000 FORMAT( ' ', A13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
- 9996 FORMAT(' ******* ', A12,' FAILED ON CALL NUMBER:' )
-C 9995 FORMAT(1X, I6, ': ', A12,'(', 4( '''', A1, ''',' ), 2( I3, ',' ),
-C $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ') ',
-C $ ' .' )
+ 9996 FORMAT(' ******* ', A13,' FAILED ON CALL NUMBER:' )
+ 9995 FORMAT(1X, I6, ': ', A13,'(', 4( '''', A1, ''',' ), 2( I3, ',' ),
+ $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ') ',
+ $ ' .' )
9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
@@ -1403,7 +1416,7 @@ SUBROUTINE ZPRCN3(NOUT, NC, SNAME, IORDER, SIDE, UPLO, TRANSA,
INTEGER NOUT, NC, IORDER, M, N, LDA, LDB
DOUBLE COMPLEX ALPHA
CHARACTER*1 SIDE, UPLO, TRANSA, DIAG
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
CHARACTER*14 CRC, CS, CU, CA, CD
IF (SIDE.EQ.'L')THEN
@@ -1436,7 +1449,7 @@ SUBROUTINE ZPRCN3(NOUT, NC, SNAME, IORDER, SIDE, UPLO, TRANSA,
WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CS,CU
WRITE(NOUT, FMT = 9994)CA, CD, M, N, ALPHA, LDA, LDB
- 9995 FORMAT( 1X, I6, ': ', A12,'(', A14, ',', A14, ',', A14, ',')
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', A14, ',', A14, ',', A14, ',')
9994 FORMAT( 10X, 2( A14, ',') , 2( I3, ',' ), ' (', F4.1, ',',
$ F4.1, '), A,', I3, ', B,', I3, ').' )
END
@@ -1465,7 +1478,7 @@ SUBROUTINE ZCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
DOUBLE PRECISION EPS, THRESH
INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
LOGICAL FATAL, REWI, TRACE
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
* .. Array Arguments ..
COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), B( NMAX, NMAX ),
@@ -1506,8 +1519,6 @@ SUBROUTINE ZCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
NC = 0
RESET = .TRUE.
ERRMAX = RZERO
- RALS = RONE
- RBETS = RONE
*
DO 100 IN = 1, NIDIM
N = IDIM( IN )
@@ -1759,26 +1770,26 @@ SUBROUTINE ZCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
130 CONTINUE
RETURN
*
-10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
+10003 FORMAT( ' ', A13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
+10002 FORMAT( ' ', A13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
+10001 FORMAT( ' ', A13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
-10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
+10000 FORMAT( ' ', A13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
- 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
+ 9996 FORMAT( ' ******* ', A13,' FAILED ON CALL NUMBER:' )
9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
-C 9994 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
-C $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') ',
-C $ ' .' )
-C 9993 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
-C $ '(', F4.1, ',', F4.1, ') , A,', I3, ',(', F4.1, ',', F4.1,
-C $ '), C,', I3, ') .' )
+ 9994 FORMAT(1X, I6, ': ', A13,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
+ $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') ',
+ $ ' .' )
+ 9993 FORMAT(1X, I6, ': ', A13,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
+ $ '(', F4.1, ',', F4.1, ') , A,', I3, ',(', F4.1, ',', F4.1,
+ $ '), C,', I3, ') .' )
9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
@@ -1791,7 +1802,7 @@ SUBROUTINE ZPRCN4(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
INTEGER NOUT, NC, IORDER, N, K, LDA, LDC
DOUBLE COMPLEX ALPHA, BETA
CHARACTER*1 UPLO, TRANSA
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
CHARACTER*14 CRC, CU, CA
IF (UPLO.EQ.'U')THEN
@@ -1814,7 +1825,7 @@ SUBROUTINE ZPRCN4(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA
WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, BETA, LDC
- 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') )
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', 3( A14, ',') )
9994 FORMAT( 10X, 2( I3, ',' ), ' (', F4.1, ',', F4.1 ,'), A,',
$ I3, ', (', F4.1,',', F4.1, '), C,', I3, ').' )
END
@@ -1825,7 +1836,7 @@ SUBROUTINE ZPRCN6(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
INTEGER NOUT, NC, IORDER, N, K, LDA, LDC
DOUBLE PRECISION ALPHA, BETA
CHARACTER*1 UPLO, TRANSA
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
CHARACTER*14 CRC, CU, CA
IF (UPLO.EQ.'U')THEN
@@ -1848,7 +1859,7 @@ SUBROUTINE ZPRCN6(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA
WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, BETA, LDC
- 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') )
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', 3( A14, ',') )
9994 FORMAT( 10X, 2( I3, ',' ),
$ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ').' )
END
@@ -1877,7 +1888,7 @@ SUBROUTINE ZCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
DOUBLE PRECISION EPS, THRESH
INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
LOGICAL FATAL, REWI, TRACE
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
* .. Array Arguments ..
COMPLEX*16 AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ),
$ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ),
@@ -2212,26 +2223,26 @@ SUBROUTINE ZCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
160 CONTINUE
RETURN
*
-10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
+10003 FORMAT( ' ', A13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
+10002 FORMAT( ' ', A13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
$ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
$ 'RATIO ', F8.2, ' - SUSPECT *******' )
-10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
+10001 FORMAT( ' ', A13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
-10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
+10000 FORMAT( ' ', A13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
$ ' (', I6, ' CALL', 'S)' )
9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
- 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' )
+ 9996 FORMAT( ' ******* ', A13,' FAILED ON CALL NUMBER:' )
9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
-C 9994 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
-C $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',', F4.1,
-C $ ', C,', I3, ') .' )
-C 9993 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
-C $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1,
-C $ ',', F4.1, '), C,', I3, ') .' )
+ 9994 FORMAT(1X, I6, ': ', A13,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
+ $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',', F4.1,
+ $ ', C,', I3, ') .' )
+ 9993 FORMAT(1X, I6, ': ', A13,'(', 2( '''', A1, ''',' ), 2( I3, ',' ),
+ $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1,
+ $ ',', F4.1, '), C,', I3, ') .' )
9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
@@ -2244,7 +2255,7 @@ SUBROUTINE ZPRCN5(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
INTEGER NOUT, NC, IORDER, N, K, LDA, LDB, LDC
DOUBLE COMPLEX ALPHA, BETA
CHARACTER*1 UPLO, TRANSA
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
CHARACTER*14 CRC, CU, CA
IF (UPLO.EQ.'U')THEN
@@ -2267,7 +2278,7 @@ SUBROUTINE ZPRCN5(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA
WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, LDB, BETA, LDC
- 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') )
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', 3( A14, ',') )
9994 FORMAT( 10X, 2( I3, ',' ), ' (', F4.1, ',', F4.1, '), A,',
$ I3, ', B', I3, ', (', F4.1, ',', F4.1, '), C,', I3, ').' )
END
@@ -2279,7 +2290,7 @@ SUBROUTINE ZPRCN7(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
DOUBLE COMPLEX ALPHA
DOUBLE PRECISION BETA
CHARACTER*1 UPLO, TRANSA
- CHARACTER*12 SNAME
+ CHARACTER*13 SNAME
CHARACTER*14 CRC, CU, CA
IF (UPLO.EQ.'U')THEN
@@ -2302,7 +2313,7 @@ SUBROUTINE ZPRCN7(NOUT, NC, SNAME, IORDER, UPLO, TRANSA,
WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA
WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, LDB, BETA, LDC
- 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') )
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', 3( A14, ',') )
9994 FORMAT( 10X, 2( I3, ',' ), ' (', F4.1, ',', F4.1, '), A,',
$ I3, ', B', I3, ',', F4.1, ', C,', I3, ').' )
END
@@ -2710,7 +2721,7 @@ LOGICAL FUNCTION LZERES( TYPE, UPLO, M, N, AA, AS, LDA )
50 CONTINUE
END IF
*
-C 60 CONTINUE
+ 60 CONTINUE
LZERES = .TRUE.
GO TO 80
70 CONTINUE
@@ -2794,3 +2805,540 @@ DOUBLE PRECISION FUNCTION DDIFF( X, Y )
*
END
+ SUBROUTINE ZCHK6( 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 )
+ IMPLICIT NONE
+*
+* Tests CGEMMTR.
+*
+* Auxiliary routine for test program for Level 3 Blas.
+*
+* -- Written on 24-June-2024.
+* Martin Koehler, Max Planck Institute Magdeburg
+*
+* .. Parameters ..
+ COMPLEX*16 ZERO
+ PARAMETER ( ZERO = ( 0.0, 0.0 ) )
+ DOUBLE PRECISION RZERO
+ PARAMETER ( RZERO = 0.0 )
+* .. Scalar Arguments ..
+ DOUBLE PRECISION EPS, THRESH
+ INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
+ LOGICAL FATAL, REWI, TRACE
+ CHARACTER*13 SNAME
+* .. Array Arguments ..
+ COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
+ $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
+ $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
+ $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
+ $ CS( NMAX*NMAX ), CT( NMAX )
+ DOUBLE PRECISION G( NMAX )
+ INTEGER IDIM( NIDIM )
+* .. Local Scalars ..
+ COMPLEX*16 ALPHA, ALS, BETA, BLS
+ DOUBLE PRECISION ERR, ERRMAX
+ INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA,
+ $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS,
+ $ MA, MB, N, NA, NARGS, NB, NC, NS, IS
+ LOGICAL NULL, RESET, SAME, TRANA, TRANB
+ CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB, UPLO, UPLOS
+ CHARACTER*3 ICH
+ CHARACTER*2 ISHAPE
+* .. Local Arrays ..
+ LOGICAL ISAME( 13 )
+* .. External Functions ..
+ LOGICAL LZE, LZERES
+ EXTERNAL LZE, LZERES
+* .. External Subroutines ..
+ EXTERNAL CZGEMMTR, ZMAKE, ZMMTCH, ZPRCN8
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* .. Scalars in Common ..
+ INTEGER INFOT, NOUTC
+ LOGICAL LERR, OK
+* .. Common blocks ..
+ COMMON /INFOC/INFOT, NOUTC, OK, LERR
+* .. Data statements ..
+ DATA ICH/'NTC'/
+ DATA ISHAPE/'UL'/
+* .. Executable Statements ..
+*
+ NARGS = 13
+ NC = 0
+ RESET = .TRUE.
+ ERRMAX = RZERO
+*
+ DO 100 IN = 1, NIDIM
+ N = IDIM( IN )
+* Set LDC to 1 more than minimum value if room.
+ LDC = N
+ IF( LDC.LT.NMAX )
+ $ LDC = LDC + 1
+* Skip tests if not enough room.
+ IF( LDC.GT.NMAX )
+ $ GO TO 100
+ LCC = LDC*N
+ NULL = N.LE.0.
+*
+ DO 90 IK = 1, NIDIM
+ K = IDIM( IK )
+*
+ DO 80 ICA = 1, 3
+ TRANSA = ICH( ICA: ICA )
+ TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
+*
+ IF( TRANA )THEN
+ MA = K
+ NA = N
+ ELSE
+ MA = N
+ NA = K
+ END IF
+* Set LDA to 1 more than minimum value if room.
+ LDA = MA
+ IF( LDA.LT.NMAX )
+ $ LDA = LDA + 1
+* Skip tests if not enough room.
+ IF( LDA.GT.NMAX )
+ $ GO TO 80
+ LAA = LDA*NA
+*
+* Generate the matrix A.
+*
+ CALL ZMAKE( 'ge', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
+ $ RESET, ZERO )
+*
+ DO 70 ICB = 1, 3
+ TRANSB = ICH( ICB: ICB )
+ TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
+*
+ IF( TRANB )THEN
+ MB = N
+ NB = K
+ ELSE
+ MB = K
+ NB = N
+ END IF
+* Set LDB to 1 more than minimum value if room.
+ LDB = MB
+ IF( LDB.LT.NMAX )
+ $ LDB = LDB + 1
+* Skip tests if not enough room.
+ IF( LDB.GT.NMAX )
+ $ GO TO 70
+ LBB = LDB*NB
+*
+* Generate the matrix B.
+*
+ CALL ZMAKE( 'ge', ' ', ' ', MB, NB, B, NMAX, BB,
+ $ LDB, RESET, ZERO )
+*
+ DO 60 IA = 1, NALF
+ ALPHA = ALF( IA )
+*
+ DO 50 IB = 1, NBET
+ BETA = BET( IB )
+ DO 45 IS = 1, 2
+ UPLO = ISHAPE(IS:IS)
+*
+* Generate the matrix C.
+*
+ CALL ZMAKE( 'ge', UPLO, ' ', N, N, C, NMAX,
+ $ CC, LDC, RESET, ZERO )
+*
+ NC = NC + 1
+*
+* Save every datum before calling the
+* subroutine.
+*
+ UPLOS = UPLO
+ TRANAS = TRANSA
+ TRANBS = TRANSB
+ NS = N
+ KS = K
+ ALS = ALPHA
+ DO 10 I = 1, LAA
+ AS( I ) = AA( I )
+ 10 CONTINUE
+ LDAS = LDA
+ DO 20 I = 1, LBB
+ BS( I ) = BB( I )
+ 20 CONTINUE
+ LDBS = LDB
+ BLS = BETA
+ DO 30 I = 1, LCC
+ CS( I ) = CC( I )
+ 30 CONTINUE
+ LDCS = LDC
+*
+* Call the subroutine.
+*
+ IF( TRACE )
+ $ CALL ZPRCN8(NTRA, NC, SNAME, IORDER, UPLO,
+ $ TRANSA, TRANSB, N, K, ALPHA, LDA,
+ $ LDB, BETA, LDC)
+ IF( REWI )
+ $ REWIND NTRA
+ CALL CZGEMMTR(IORDER, UPLO, TRANSA, TRANSB,
+ $ N, K, ALPHA, AA, LDA, BB, LDB,
+ $ BETA, CC, LDC )
+*
+* Check if error-exit was taken incorrectly.
+*
+ IF( .NOT.OK )THEN
+ WRITE( NOUT, FMT = 9994 )
+ FATAL = .TRUE.
+ GO TO 120
+ END IF
+*
+* See what data changed inside subroutines.
+*
+ ISAME( 1 ) = UPLO .EQ. UPLOS
+ ISAME( 2 ) = TRANSA.EQ.TRANAS
+ ISAME( 3 ) = TRANSB.EQ.TRANBS
+ ISAME( 4 ) = NS.EQ.N
+ ISAME( 5 ) = KS.EQ.K
+ ISAME( 6 ) = ALS.EQ.ALPHA
+ ISAME( 7 ) = LZE( AS, AA, LAA )
+ ISAME( 8 ) = LDAS.EQ.LDA
+ ISAME( 9 ) = LZE( BS, BB, LBB )
+ ISAME( 10 ) = LDBS.EQ.LDB
+ ISAME( 11 ) = BLS.EQ.BETA
+ IF( NULL )THEN
+ ISAME( 12 ) = LZE( CS, CC, LCC )
+ ELSE
+ ISAME( 12 ) = LZERES( 'ge', ' ', N, N, CS,
+ $ CC, LDC )
+ END IF
+ ISAME( 13 ) = LDCS.EQ.LDC
+*
+* If data was incorrectly changed, report
+* and return.
+*
+ SAME = .TRUE.
+ DO 40 I = 1, NARGS
+ SAME = SAME.AND.ISAME( I )
+ IF( .NOT.ISAME( I ) )
+ $ WRITE( NOUT, FMT = 9998 )I
+ 40 CONTINUE
+ IF( .NOT.SAME )THEN
+ FATAL = .TRUE.
+ GO TO 120
+ END IF
+*
+ IF( .NOT.NULL )THEN
+*
+* Check the result.
+*
+ CALL ZMMTCH( UPLO, TRANSA, TRANSB, N, K,
+ $ ALPHA, A, NMAX, B, NMAX, BETA,
+ $ C, NMAX, CT, G, CC, LDC, EPS,
+ $ ERR, FATAL, NOUT, .TRUE. )
+ ERRMAX = MAX( ERRMAX, ERR )
+* If got really bad answer, report and
+* return.
+ IF( FATAL )
+ $ GO TO 120
+ END IF
+*
+ 45 CONTINUE
+*
+ 50 CONTINUE
+*
+ 60 CONTINUE
+*
+ 70 CONTINUE
+*
+ 80 CONTINUE
+*
+ 90 CONTINUE
+*
+ 100 CONTINUE
+*
+*
+* Report result.
+*
+ IF( ERRMAX.LT.THRESH )THEN
+ IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC
+ IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC
+ ELSE
+ IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
+ IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
+ END IF
+ GO TO 130
+*
+ 120 CONTINUE
+ WRITE( NOUT, FMT = 9996 )SNAME
+ CALL ZPRCN8(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, TRANSB,
+ $ N, K, ALPHA, LDA, LDB, BETA, LDC)
+*
+ 130 CONTINUE
+ RETURN
+*
+10003 FORMAT( ' ', A13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
+ $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
+ $ 'RATIO ', F8.2, ' - SUSPECT *******' )
+10002 FORMAT( ' ', A13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
+ $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
+ $ 'RATIO ', F8.2, ' - SUSPECT *******' )
+10001 FORMAT( ' ', A13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
+ $ ' (', I6, ' CALL', 'S)' )
+10000 FORMAT( ' ', A13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
+ $ ' (', I6, ' CALL', 'S)' )
+ 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
+ $ 'ANGED INCORRECTLY *******' )
+ 9996 FORMAT( ' ******* ', A13,' FAILED ON CALL NUMBER:' )
+ 9995 FORMAT( 1X, I6, ': ', A13,'(''', A1, ''',''', A1, ''',',
+ $ 3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3,
+ $ ',(', F4.1, ',', F4.1, '), C,', I3, ').' )
+ 9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
+ $ '******' )
+*
+* End of ZCHK6.
+*
+ END
+
+ SUBROUTINE ZPRCN8(NOUT, NC, SNAME, IORDER, UPLO,
+ $ TRANSA, TRANSB, N,
+ $ K, ALPHA, LDA, LDB, BETA, LDC)
+ INTEGER NOUT, NC, IORDER, N, K, LDA, LDB, LDC
+ COMPLEX*16 ALPHA, BETA
+ CHARACTER*1 TRANSA, TRANSB, UPLO
+ CHARACTER*13 SNAME
+ CHARACTER*14 CRC, CTA,CTB,CUPLO
+
+ IF (UPLO.EQ.'U') THEN
+ CUPLO = 'CblasUpper'
+ ELSE
+ CUPLO = 'CblasLower'
+ END IF
+ IF (TRANSA.EQ.'N')THEN
+ CTA = ' CblasNoTrans'
+ ELSE IF (TRANSA.EQ.'T')THEN
+ CTA = ' CblasTrans'
+ ELSE
+ CTA = 'CblasConjTrans'
+ END IF
+ IF (TRANSB.EQ.'N')THEN
+ CTB = ' CblasNoTrans'
+ ELSE IF (TRANSB.EQ.'T')THEN
+ CTB = ' CblasTrans'
+ ELSE
+ CTB = 'CblasConjTrans'
+ END IF
+ IF (IORDER.EQ.1)THEN
+ CRC = ' CblasRowMajor'
+ ELSE
+ CRC = ' CblasColMajor'
+ END IF
+ WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CUPLO, CTA,CTB
+ WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, LDB, BETA, LDC
+
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', A14, ',', A14, ',', A14, ',',
+ $ A14, ',')
+ 9994 FORMAT( 10X, 2( I3, ',' ) ,' (', F4.1,',',F4.1,') , A,',
+ $ I3, ', B,', I3, ', (', F4.1,',',F4.1,') , C,', I3, ').' )
+ END
+
+ SUBROUTINE ZMMTCH(UPLO, TRANSA, TRANSB, N, KK, ALPHA, A, LDA,
+ $ B, LDB,
+ $ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL,
+ $ NOUT, MV )
+ IMPLICIT NONE
+*
+* Checks the results of the computational tests for GEMMTR.
+*
+* Auxiliary routine for test program for Level 3 Blas.
+*
+* -- Written on 24-June-2024.
+* Martin Koehler, Max Planck Institute, Magdeburg
+*
+* .. Parameters ..
+ COMPLEX*16 ZERO
+ PARAMETER ( ZERO = ( 0.0, 0.0 ) )
+ DOUBLE PRECISION RZERO, RONE
+ PARAMETER ( RZERO = 0.0, RONE = 1.0 )
+* .. Scalar Arguments ..
+ COMPLEX*16 ALPHA, BETA
+ DOUBLE PRECISION EPS, ERR
+ INTEGER KK, LDA, LDB, LDC, LDCC, N, NOUT
+ LOGICAL FATAL, MV
+ CHARACTER*1 TRANSA, TRANSB, UPLO
+* .. Array Arguments ..
+ COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ),
+ $ CC( LDCC, * ), CT( * )
+ DOUBLE PRECISION G( * )
+* .. Local Scalars ..
+ COMPLEX*16 CL
+ DOUBLE PRECISION ERRI
+ INTEGER I, J, K, ISTART, ISTOP
+ LOGICAL CTRANA, CTRANB, TRANA, TRANB, UPPER
+* .. Intrinsic Functions ..
+ INTRINSIC DABS, DIMAG, DCONJG, MAX, DBLE, DSQRT
+* .. Statement Functions ..
+ DOUBLE PRECISION ABS1
+* .. Statement Function definitions ..
+ ABS1( CL ) = DABS( DBLE( CL ) ) + DABS( DIMAG( CL ) )
+* .. Executable Statements ..
+
+ UPPER = UPLO.EQ.'U'
+ TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
+ TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
+ CTRANA = TRANSA.EQ.'C'
+ CTRANB = TRANSB.EQ.'C'
+
+ ISTART = 1
+ ISTOP = N
+*
+* Compute expected result, one column at a time, in CT using data
+* in A, B and C.
+* Compute gauges in G.
+*
+ DO 220 J = 1, N
+*
+ IF (UPPER) THEN
+ ISTART = 1
+ ISTOP = J
+ ELSE
+ ISTART = J
+ ISTOP = N
+ END IF
+ DO 10 I = ISTART, ISTOP
+ CT( I ) = ZERO
+ G( I ) = RZERO
+ 10 CONTINUE
+ IF( .NOT.TRANA.AND..NOT.TRANB )THEN
+ DO 30 K = 1, KK
+ DO 20 I = ISTART, ISTOP
+ CT( I ) = CT( I ) + A( I, K )*B( K, J )
+ G( I ) = G( I ) + ABS1( A( I, K ) )*ABS1( B( K, J ) )
+ 20 CONTINUE
+ 30 CONTINUE
+ ELSE IF( TRANA.AND..NOT.TRANB )THEN
+ IF( CTRANA )THEN
+ DO 50 K = 1, KK
+ DO 40 I = ISTART, ISTOP
+ CT( I ) = CT( I ) + DCONJG( A( K, I ) )*B( K, J )
+ G( I ) = G( I ) + ABS1( A( K, I ) )*
+ $ ABS1( B( K, J ) )
+ 40 CONTINUE
+ 50 CONTINUE
+ ELSE
+ DO 70 K = 1, KK
+ DO 60 I = ISTART, ISTOP
+ CT( I ) = CT( I ) + A( K, I )*B( K, J )
+ G( I ) = G( I ) + ABS1( A( K, I ) )*
+ $ ABS1( B( K, J ) )
+ 60 CONTINUE
+ 70 CONTINUE
+ END IF
+ ELSE IF( .NOT.TRANA.AND.TRANB )THEN
+ IF( CTRANB )THEN
+ DO 90 K = 1, KK
+ DO 80 I = ISTART, ISTOP
+ CT( I ) = CT( I ) + A( I, K )*DCONJG( B( J, K ) )
+ G( I ) = G( I ) + ABS1( A( I, K ) )*
+ $ ABS1( B( J, K ) )
+ 80 CONTINUE
+ 90 CONTINUE
+ ELSE
+ DO 110 K = 1, KK
+ DO 100 I = ISTART, ISTOP
+ CT( I ) = CT( I ) + A( I, K )*B( J, K )
+ G( I ) = G( I ) + ABS1( A( I, K ) )*
+ $ ABS1( B( J, K ) )
+ 100 CONTINUE
+ 110 CONTINUE
+ END IF
+ ELSE IF( TRANA.AND.TRANB )THEN
+ IF( CTRANA )THEN
+ IF( CTRANB )THEN
+ DO 130 K = 1, KK
+ DO 120 I = ISTART, ISTOP
+ CT( I ) = CT( I ) + DCONJG( A( K, I ) )*
+ $ DCONJG( B( J, K ) )
+ G( I ) = G( I ) + ABS1( A( K, I ) )*
+ $ ABS1( B( J, K ) )
+ 120 CONTINUE
+ 130 CONTINUE
+ ELSE
+ DO 150 K = 1, KK
+ DO 140 I = ISTART, ISTOP
+ CT( I ) = CT( I ) + DCONJG( A( K, I ) )*B( J, K )
+ G( I ) = G( I ) + ABS1( A( K, I ) )*
+ $ ABS1( B( J, K ) )
+ 140 CONTINUE
+ 150 CONTINUE
+ END IF
+ ELSE
+ IF( CTRANB )THEN
+ DO 170 K = 1, KK
+ DO 160 I = ISTART, ISTOP
+ CT( I ) = CT( I ) + A( K, I )*DCONJG( B( J, K ) )
+ G( I ) = G( I ) + ABS1( A( K, I ) )*
+ $ ABS1( B( J, K ) )
+ 160 CONTINUE
+ 170 CONTINUE
+ ELSE
+ DO 190 K = 1, KK
+ DO 180 I = ISTART, ISTOP
+ CT( I ) = CT( I ) + A( K, I )*B( J, K )
+ G( I ) = G( I ) + ABS1( A( K, I ) )*
+ $ ABS1( B( J, K ) )
+ 180 CONTINUE
+ 190 CONTINUE
+ END IF
+ END IF
+ END IF
+ DO 200 I = ISTART, ISTOP
+ CT( I ) = ALPHA*CT( I ) + BETA*C( I, J )
+ G( I ) = ABS1( ALPHA )*G( I ) +
+ $ ABS1( BETA )*ABS1( C( I, J ) )
+ 200 CONTINUE
+*
+* Compute the error ratio for this result.
+*
+ ERR = ZERO
+ DO 210 I = ISTART, ISTOP
+ ERRI = ABS1( CT( I ) - CC( I, J ) )/EPS
+ IF( G( I ).NE.RZERO )
+ $ ERRI = ERRI/G( I )
+ ERR = MAX( ERR, ERRI )
+ IF( ERR*DSQRT( EPS ).GE.RONE )
+ $ GO TO 230
+ 210 CONTINUE
+*
+ 220 CONTINUE
+*
+* If the loop completes, all results are at least half accurate.
+ GO TO 250
+*
+* Report fatal error.
+*
+ 230 FATAL = .TRUE.
+ WRITE( NOUT, FMT = 9999 )
+ DO 240 I = ISTART, ISTOP
+ IF( MV )THEN
+ WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J )
+ ELSE
+ WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I )
+ END IF
+ 240 CONTINUE
+ IF( N.GT.1 )
+ $ WRITE( NOUT, FMT = 9997 )J
+*
+ 250 CONTINUE
+ RETURN
+*
+ 9999 FORMAT(' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
+ $ 'F ACCURATE *******', /' EXPECTED RE',
+ $ 'SULT COMPUTED RESULT' )
+ 9998 FORMAT( 1X, I7, 2( ' (', G15.6, ',', G15.6, ')' ) )
+ 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
+*
+* End of ZMMTCH.
+*
+ END
+
diff --git a/ctest/cblas_test.h b/ctest/cblas_test.h
index 502a2fee20..3b6ce166fe 100644
--- a/ctest/cblas_test.h
+++ b/ctest/cblas_test.h
@@ -5,18 +5,15 @@
#ifndef CBLAS_TEST_H
#define CBLAS_TEST_H
#include "cblas.h"
+#include "cblas_mangling.h"
-#ifdef USE64BITINT
-#define int long
-#endif
+/* It seems all current Fortran compilers put strlen at end.
+* Some historical compilers put strlen after the str argument
+* or make the str argument into a struct. */
+#define BLAS_FORTRAN_STRLEN_END
-#if defined(_MSC_VER) && defined(__INTEL_CLANG_COMPILER)
-//#define LAPACK_COMPLEX_STRUCTURE
-#define NOCHANGE
-#endif
-/* e.g. mingw64/x86_64-w64-mingw32/include/winerror.h */
-#ifdef FAILED
-#undef FAILED
+#ifndef FORTRAN_STRLEN
+ #define FORTRAN_STRLEN size_t
#endif
#define TRUE 1
@@ -33,497 +30,174 @@
typedef struct { float real; float imag; } CBLAS_TEST_COMPLEX;
typedef struct { double real; double imag; } CBLAS_TEST_ZOMPLEX;
-#if defined(ADD_)
-/*
- * Level 1 BLAS
- */
- #define F77_srotg srotgtest_
- #define F77_srotmg srotmgtest_
- #define F77_srot srottest_
- #define F77_srotm srotmtest_
- #define F77_drotg drotgtest_
- #define F77_drotmg drotmgtest_
- #define F77_drot drottest_
- #define F77_drotm drotmtest_
- #define F77_sswap sswaptest_
- #define F77_scopy scopytest_
- #define F77_saxpy saxpytest_
- #define F77_isamax isamaxtest_
- #define F77_dswap dswaptest_
- #define F77_dcopy dcopytest_
- #define F77_daxpy daxpytest_
- #define F77_idamax idamaxtest_
- #define F77_cswap cswaptest_
- #define F77_ccopy ccopytest_
- #define F77_caxpy caxpytest_
- #define F77_icamax icamaxtest_
- #define F77_zswap zswaptest_
- #define F77_zcopy zcopytest_
- #define F77_zaxpy zaxpytest_
- #define F77_izamax izamaxtest_
- #define F77_sdot sdottest_
- #define F77_ddot ddottest_
- #define F77_dsdot dsdottest_
- #define F77_sscal sscaltest_
- #define F77_dscal dscaltest_
- #define F77_cscal cscaltest_
- #define F77_zscal zscaltest_
- #define F77_csscal csscaltest_
- #define F77_zdscal zdscaltest_
- #define F77_cdotu cdotutest_
- #define F77_cdotc cdotctest_
- #define F77_zdotu zdotutest_
- #define F77_zdotc zdotctest_
- #define F77_snrm2 snrm2test_
- #define F77_sasum sasumtest_
- #define F77_dnrm2 dnrm2test_
- #define F77_dasum dasumtest_
- #define F77_scnrm2 scnrm2test_
- #define F77_scasum scasumtest_
- #define F77_dznrm2 dznrm2test_
- #define F77_dzasum dzasumtest_
- #define F77_sdsdot sdsdottest_
-/*
- * Level 2 BLAS
- */
- #define F77_s2chke cs2chke_
- #define F77_d2chke cd2chke_
- #define F77_c2chke cc2chke_
- #define F77_z2chke cz2chke_
- #define F77_ssymv cssymv_
- #define F77_ssbmv cssbmv_
- #define F77_sspmv csspmv_
- #define F77_sger csger_
- #define F77_ssyr cssyr_
- #define F77_sspr csspr_
- #define F77_ssyr2 cssyr2_
- #define F77_sspr2 csspr2_
- #define F77_dsymv cdsymv_
- #define F77_dsbmv cdsbmv_
- #define F77_dspmv cdspmv_
- #define F77_dger cdger_
- #define F77_dsyr cdsyr_
- #define F77_dspr cdspr_
- #define F77_dsyr2 cdsyr2_
- #define F77_dspr2 cdspr2_
- #define F77_chemv cchemv_
- #define F77_chbmv cchbmv_
- #define F77_chpmv cchpmv_
- #define F77_cgeru ccgeru_
- #define F77_cgerc ccgerc_
- #define F77_cher ccher_
- #define F77_chpr cchpr_
- #define F77_cher2 ccher2_
- #define F77_chpr2 cchpr2_
- #define F77_zhemv czhemv_
- #define F77_zhbmv czhbmv_
- #define F77_zhpmv czhpmv_
- #define F77_zgeru czgeru_
- #define F77_zgerc czgerc_
- #define F77_zher czher_
- #define F77_zhpr czhpr_
- #define F77_zher2 czher2_
- #define F77_zhpr2 czhpr2_
- #define F77_sgemv csgemv_
- #define F77_sgbmv csgbmv_
- #define F77_strmv cstrmv_
- #define F77_stbmv cstbmv_
- #define F77_stpmv cstpmv_
- #define F77_strsv cstrsv_
- #define F77_stbsv cstbsv_
- #define F77_stpsv cstpsv_
- #define F77_dgemv cdgemv_
- #define F77_dgbmv cdgbmv_
- #define F77_dtrmv cdtrmv_
- #define F77_dtbmv cdtbmv_
- #define F77_dtpmv cdtpmv_
- #define F77_dtrsv cdtrsv_
- #define F77_dtbsv cdtbsv_
- #define F77_dtpsv cdtpsv_
- #define F77_cgemv ccgemv_
- #define F77_cgbmv ccgbmv_
- #define F77_ctrmv cctrmv_
- #define F77_ctbmv cctbmv_
- #define F77_ctpmv cctpmv_
- #define F77_ctrsv cctrsv_
- #define F77_ctbsv cctbsv_
- #define F77_ctpsv cctpsv_
- #define F77_zgemv czgemv_
- #define F77_zgbmv czgbmv_
- #define F77_ztrmv cztrmv_
- #define F77_ztbmv cztbmv_
- #define F77_ztpmv cztpmv_
- #define F77_ztrsv cztrsv_
- #define F77_ztbsv cztbsv_
- #define F77_ztpsv cztpsv_
-/*
- * Level 3 BLAS
- */
- #define F77_s3chke cs3chke_
- #define F77_d3chke cd3chke_
- #define F77_c3chke cc3chke_
- #define F77_z3chke cz3chke_
- #define F77_chemm cchemm_
- #define F77_cherk ccherk_
- #define F77_cher2k ccher2k_
- #define F77_zhemm czhemm_
- #define F77_zherk czherk_
- #define F77_zher2k czher2k_
- #define F77_sgemm csgemm_
- #define F77_ssymm cssymm_
- #define F77_ssyrk cssyrk_
- #define F77_ssyr2k cssyr2k_
- #define F77_strmm cstrmm_
- #define F77_strsm cstrsm_
- #define F77_dgemm cdgemm_
- #define F77_dsymm cdsymm_
- #define F77_dsyrk cdsyrk_
- #define F77_dsyr2k cdsyr2k_
- #define F77_dtrmm cdtrmm_
- #define F77_dtrsm cdtrsm_
- #define F77_cgemm ccgemm_
- #define F77_cgemm3m ccgemm3m_
- #define F77_csymm ccsymm_
- #define F77_csyrk ccsyrk_
- #define F77_csyr2k ccsyr2k_
- #define F77_ctrmm cctrmm_
- #define F77_ctrsm cctrsm_
- #define F77_zgemm czgemm_
- #define F77_zgemm3m czgemm3m_
- #define F77_zsymm czsymm_
- #define F77_zsyrk czsyrk_
- #define F77_zsyr2k czsyr2k_
- #define F77_ztrmm cztrmm_
- #define F77_ztrsm cztrsm_
-#elif defined(UPCASE)
+//#define F77_xerbla F77_GLOBAL(xerbla,XERBLA)
/*
* Level 1 BLAS
*/
- #define F77_srotg SROTGTEST
- #define F77_srotmg SROTMGTEST
- #define F77_srot SROTCTEST
- #define F77_srotm SROTMTEST
- #define F77_drotg DROTGTEST
- #define F77_drotmg DROTMGTEST
- #define F77_drot DROTTEST
- #define F77_drotm DROTMTEST
- #define F77_sswap SSWAPTEST
- #define F77_scopy SCOPYTEST
- #define F77_saxpy SAXPYTEST
- #define F77_isamax ISAMAXTEST
- #define F77_dswap DSWAPTEST
- #define F77_dcopy DCOPYTEST
- #define F77_daxpy DAXPYTEST
- #define F77_idamax IDAMAXTEST
- #define F77_cswap CSWAPTEST
- #define F77_ccopy CCOPYTEST
- #define F77_caxpy CAXPYTEST
- #define F77_icamax ICAMAXTEST
- #define F77_zswap ZSWAPTEST
- #define F77_zcopy ZCOPYTEST
- #define F77_zaxpy ZAXPYTEST
- #define F77_izamax IZAMAXTEST
- #define F77_sdot SDOTTEST
- #define F77_ddot DDOTTEST
- #define F77_dsdot DSDOTTEST
- #define F77_sscal SSCALTEST
- #define F77_dscal DSCALTEST
- #define F77_cscal CSCALTEST
- #define F77_zscal ZSCALTEST
- #define F77_csscal CSSCALTEST
- #define F77_zdscal ZDSCALTEST
- #define F77_cdotu CDOTUTEST
- #define F77_cdotc CDOTCTEST
- #define F77_zdotu ZDOTUTEST
- #define F77_zdotc ZDOTCTEST
- #define F77_snrm2 SNRM2TEST
- #define F77_sasum SASUMTEST
- #define F77_dnrm2 DNRM2TEST
- #define F77_dasum DASUMTEST
- #define F77_scnrm2 SCNRM2TEST
- #define F77_scasum SCASUMTEST
- #define F77_dznrm2 DZNRM2TEST
- #define F77_dzasum DZASUMTEST
- #define F77_sdsdot SDSDOTTEST
+#define F77_srotg F77_GLOBAL(srotgtest,SROTGTEST)
+#define F77_srotmg F77_GLOBAL(srotmgtest,SROTMGTEST)
+#define F77_srot F77_GLOBAL(srottest,SROTTEST)
+#define F77_srotm F77_GLOBAL(srotmtest,SROTMTEST)
+#define F77_drotg F77_GLOBAL(drotgtest,DROTGTEST)
+#define F77_drotmg F77_GLOBAL(drotmgtest,DROTMGTEST)
+#define F77_drot F77_GLOBAL(drottest,DROTTEST)
+#define F77_drotm F77_GLOBAL(drotmtest,DROTMTEST)
+#define F77_sswap F77_GLOBAL(sswaptest,SSWAPTEST)
+#define F77_scopy F77_GLOBAL(scopytest,SCOPYTEST)
+#define F77_saxpy F77_GLOBAL(saxpytest,SAXPYTEST)
+#define F77_isamax F77_GLOBAL(isamaxtest,ISAMAXTEST)
+#define F77_dswap F77_GLOBAL(dswaptest,DSWAPTEST)
+#define F77_dcopy F77_GLOBAL(dcopytest,DCOPYTEST)
+#define F77_daxpy F77_GLOBAL(daxpytest,DAXPYTEST)
+#define F77_idamax F77_GLOBAL(idamaxtest,IDAMAXTEST)
+#define F77_cswap F77_GLOBAL(cswaptest,CSWAPTEST)
+#define F77_ccopy F77_GLOBAL(ccopytest,CCOPYTEST)
+#define F77_caxpy F77_GLOBAL(caxpytest,CAXPYTEST)
+#define F77_icamax F77_GLOBAL(icamaxtest,ICAMAXTEST)
+#define F77_zswap F77_GLOBAL(zswaptest,ZSWAPTEST)
+#define F77_zcopy F77_GLOBAL(zcopytest,ZCOPYTEST)
+#define F77_zaxpy F77_GLOBAL(zaxpytest,ZAXPYTEST)
+#define F77_izamax F77_GLOBAL(izamaxtest,IZAMAXTEST)
+#define F77_sdot F77_GLOBAL(sdottest,SDOTTEST)
+#define F77_ddot F77_GLOBAL(ddottest,DDOTTEST)
+#define F77_dsdot F77_GLOBAL(dsdottest,DSDOTTEST)
+#define F77_sscal F77_GLOBAL(sscaltest,SSCALTEST)
+#define F77_dscal F77_GLOBAL(dscaltest,DSCALTEST)
+#define F77_cscal F77_GLOBAL(cscaltest,CSCALTEST)
+#define F77_zscal F77_GLOBAL(zscaltest,ZSCALTEST)
+#define F77_csscal F77_GLOBAL(csscaltest,CSSCALTEST)
+#define F77_zdscal F77_GLOBAL(zdscaltest,ZDSCALTEST)
+#define F77_cdotu F77_GLOBAL(cdotutest,CDOTUTEST)
+#define F77_cdotc F77_GLOBAL(cdotctest,CDOTCTEST)
+#define F77_zdotu F77_GLOBAL(zdotutest,ZDOTUTEST)
+#define F77_zdotc F77_GLOBAL(zdotctest,ZDOTCTEST)
+#define F77_snrm2 F77_GLOBAL(snrm2test,SNRM2TEST)
+#define F77_sasum F77_GLOBAL(sasumtest,SASUMTEST)
+#define F77_dnrm2 F77_GLOBAL(dnrm2test,DNRM2TEST)
+#define F77_dasum F77_GLOBAL(dasumtest,DASUMTEST)
+#define F77_scnrm2 F77_GLOBAL(scnrm2test,SCNRM2TEST)
+#define F77_scasum F77_GLOBAL(scasumtest,SCASUMTEST)
+#define F77_dznrm2 F77_GLOBAL(dznrm2test,DZNRM2TEST)
+#define F77_dzasum F77_GLOBAL(dzasumtest,DZASUMTEST)
+#define F77_sdsdot F77_GLOBAL(sdsdottest, SDSDOTTEST)
/*
* Level 2 BLAS
*/
- #define F77_s2chke CS2CHKE
- #define F77_d2chke CD2CHKE
- #define F77_c2chke CC2CHKE
- #define F77_z2chke CZ2CHKE
- #define F77_ssymv CSSYMV
- #define F77_ssbmv CSSBMV
- #define F77_sspmv CSSPMV
- #define F77_sger CSGER
- #define F77_ssyr CSSYR
- #define F77_sspr CSSPR
- #define F77_ssyr2 CSSYR2
- #define F77_sspr2 CSSPR2
- #define F77_dsymv CDSYMV
- #define F77_dsbmv CDSBMV
- #define F77_dspmv CDSPMV
- #define F77_dger CDGER
- #define F77_dsyr CDSYR
- #define F77_dspr CDSPR
- #define F77_dsyr2 CDSYR2
- #define F77_dspr2 CDSPR2
- #define F77_chemv CCHEMV
- #define F77_chbmv CCHBMV
- #define F77_chpmv CCHPMV
- #define F77_cgeru CCGERU
- #define F77_cgerc CCGERC
- #define F77_cher CCHER
- #define F77_chpr CCHPR
- #define F77_cher2 CCHER2
- #define F77_chpr2 CCHPR2
- #define F77_zhemv CZHEMV
- #define F77_zhbmv CZHBMV
- #define F77_zhpmv CZHPMV
- #define F77_zgeru CZGERU
- #define F77_zgerc CZGERC
- #define F77_zher CZHER
- #define F77_zhpr CZHPR
- #define F77_zher2 CZHER2
- #define F77_zhpr2 CZHPR2
- #define F77_sgemv CSGEMV
- #define F77_sgbmv CSGBMV
- #define F77_strmv CSTRMV
- #define F77_stbmv CSTBMV
- #define F77_stpmv CSTPMV
- #define F77_strsv CSTRSV
- #define F77_stbsv CSTBSV
- #define F77_stpsv CSTPSV
- #define F77_dgemv CDGEMV
- #define F77_dgbmv CDGBMV
- #define F77_dtrmv CDTRMV
- #define F77_dtbmv CDTBMV
- #define F77_dtpmv CDTPMV
- #define F77_dtrsv CDTRSV
- #define F77_dtbsv CDTBSV
- #define F77_dtpsv CDTPSV
- #define F77_cgemv CCGEMV
- #define F77_cgbmv CCGBMV
- #define F77_ctrmv CCTRMV
- #define F77_ctbmv CCTBMV
- #define F77_ctpmv CCTPMV
- #define F77_ctrsv CCTRSV
- #define F77_ctbsv CCTBSV
- #define F77_ctpsv CCTPSV
- #define F77_zgemv CZGEMV
- #define F77_zgbmv CZGBMV
- #define F77_ztrmv CZTRMV
- #define F77_ztbmv CZTBMV
- #define F77_ztpmv CZTPMV
- #define F77_ztrsv CZTRSV
- #define F77_ztbsv CZTBSV
- #define F77_ztpsv CZTPSV
+#define F77_s2chke F77_GLOBAL(cs2chke,CS2CHKE)
+#define F77_d2chke F77_GLOBAL(cd2chke,CD2CHKE)
+#define F77_c2chke F77_GLOBAL(cc2chke,CC2CHKE)
+#define F77_z2chke F77_GLOBAL(cz2chke,CZ2CHKE)
+#define F77_ssymv F77_GLOBAL(cssymv,CSSYMV)
+#define F77_ssbmv F77_GLOBAL(cssbmv,CSSBMV)
+#define F77_sspmv F77_GLOBAL(csspmv,CSSPMV)
+#define F77_sger F77_GLOBAL(csger,CSGER)
+#define F77_ssyr F77_GLOBAL(cssyr,CSSYR)
+#define F77_sspr F77_GLOBAL(csspr,CSSPR)
+#define F77_ssyr2 F77_GLOBAL(cssyr2,CSSYR2)
+#define F77_sspr2 F77_GLOBAL(csspr2,CSSPR2)
+#define F77_dsymv F77_GLOBAL(cdsymv,CDSYMV)
+#define F77_dsbmv F77_GLOBAL(cdsbmv,CDSBMV)
+#define F77_dspmv F77_GLOBAL(cdspmv,CDSPMV)
+#define F77_dger F77_GLOBAL(cdger,CDGER)
+#define F77_dsyr F77_GLOBAL(cdsyr,CDSYR)
+#define F77_dspr F77_GLOBAL(cdspr,CDSPR)
+#define F77_dsyr2 F77_GLOBAL(cdsyr2,CDSYR2)
+#define F77_dspr2 F77_GLOBAL(cdspr2,CDSPR2)
+#define F77_chemv F77_GLOBAL(cchemv,CCHEMV)
+#define F77_chbmv F77_GLOBAL(cchbmv,CCHBMV)
+#define F77_chpmv F77_GLOBAL(cchpmv,CCHPMV)
+#define F77_cgeru F77_GLOBAL(ccgeru,CCGERU)
+#define F77_cgerc F77_GLOBAL(ccgerc,CCGERC)
+#define F77_cher F77_GLOBAL(ccher,CCHER)
+#define F77_chpr F77_GLOBAL(cchpr,CCHPR)
+#define F77_cher2 F77_GLOBAL(ccher2,CCHER2)
+#define F77_chpr2 F77_GLOBAL(cchpr2,CCHPR2)
+#define F77_zhemv F77_GLOBAL(czhemv,CZHEMV)
+#define F77_zhbmv F77_GLOBAL(czhbmv,CZHBMV)
+#define F77_zhpmv F77_GLOBAL(czhpmv,CZHPMV)
+#define F77_zgeru F77_GLOBAL(czgeru,CZGERU)
+#define F77_zgerc F77_GLOBAL(czgerc,CZGERC)
+#define F77_zher F77_GLOBAL(czher,CZHER)
+#define F77_zhpr F77_GLOBAL(czhpr,CZHPR)
+#define F77_zher2 F77_GLOBAL(czher2,CZHER2)
+#define F77_zhpr2 F77_GLOBAL(czhpr2,CZHPR2)
+#define F77_sgemv F77_GLOBAL(csgemv,CSGEMV)
+#define F77_sgbmv F77_GLOBAL(csgbmv,CSGBMV)
+#define F77_strmv F77_GLOBAL(cstrmv,CSTRMV)
+#define F77_stbmv F77_GLOBAL(cstbmv,CSTBMV)
+#define F77_stpmv F77_GLOBAL(cstpmv,CSTPMV)
+#define F77_strsv F77_GLOBAL(cstrsv,CSTRSV)
+#define F77_stbsv F77_GLOBAL(cstbsv,CSTBSV)
+#define F77_stpsv F77_GLOBAL(cstpsv,CSTPSV)
+#define F77_dgemv F77_GLOBAL(cdgemv,CDGEMV)
+#define F77_dgbmv F77_GLOBAL(cdgbmv,CDGBMV)
+#define F77_dtrmv F77_GLOBAL(cdtrmv,CDTRMV)
+#define F77_dtbmv F77_GLOBAL(cdtbmv,CDTBMV)
+#define F77_dtpmv F77_GLOBAL(cdtpmv,CDTPMV)
+#define F77_dtrsv F77_GLOBAL(cdtrsv,CDTRSV)
+#define F77_dtbsv F77_GLOBAL(cdtbsv,CDTBSV)
+#define F77_dtpsv F77_GLOBAL(cdtpsv,CDTPSV)
+#define F77_cgemv F77_GLOBAL(ccgemv,CCGEMV)
+#define F77_cgbmv F77_GLOBAL(ccgbmv,CCGBMV)
+#define F77_ctrmv F77_GLOBAL(cctrmv,CCTRMV)
+#define F77_ctbmv F77_GLOBAL(cctbmv,CCTBMV)
+#define F77_ctpmv F77_GLOBAL(cctpmv,CCTPMV)
+#define F77_ctrsv F77_GLOBAL(cctrsv,CCTRSV)
+#define F77_ctbsv F77_GLOBAL(cctbsv,CCTBSV)
+#define F77_ctpsv F77_GLOBAL(cctpsv,CCTPSV)
+#define F77_zgemv F77_GLOBAL(czgemv,CZGEMV)
+#define F77_zgbmv F77_GLOBAL(czgbmv,CZGBMV)
+#define F77_ztrmv F77_GLOBAL(cztrmv,CZTRMV)
+#define F77_ztbmv F77_GLOBAL(cztbmv,CZTBMV)
+#define F77_ztpmv F77_GLOBAL(cztpmv,CZTPMV)
+#define F77_ztrsv F77_GLOBAL(cztrsv,CZTRSV)
+#define F77_ztbsv F77_GLOBAL(cztbsv,CZTBSV)
+#define F77_ztpsv F77_GLOBAL(cztpsv,CZTPSV)
/*
* Level 3 BLAS
*/
- #define F77_s3chke CS3CHKE
- #define F77_d3chke CD3CHKE
- #define F77_c3chke CC3CHKE
- #define F77_z3chke CZ3CHKE
- #define F77_chemm CCHEMM
- #define F77_cherk CCHERK
- #define F77_cher2k CCHER2K
- #define F77_zhemm CZHEMM
- #define F77_zherk CZHERK
- #define F77_zher2k CZHER2K
- #define F77_sgemm CSGEMM
- #define F77_ssymm CSSYMM
- #define F77_ssyrk CSSYRK
- #define F77_ssyr2k CSSYR2K
- #define F77_strmm CSTRMM
- #define F77_strsm CSTRSM
- #define F77_dgemm CDGEMM
- #define F77_dsymm CDSYMM
- #define F77_dsyrk CDSYRK
- #define F77_dsyr2k CDSYR2K
- #define F77_dtrmm CDTRMM
- #define F77_dtrsm CDTRSM
- #define F77_cgemm CCGEMM
- #define F77_cgemm3m CCGEMM3M
- #define F77_csymm CCSYMM
- #define F77_csyrk CCSYRK
- #define F77_csyr2k CCSYR2K
- #define F77_ctrmm CCTRMM
- #define F77_ctrsm CCTRSM
- #define F77_zgemm CZGEMM
- #define F77_zgemm3m CZGEMM3M
- #define F77_zsymm CZSYMM
- #define F77_zsyrk CZSYRK
- #define F77_zsyr2k CZSYR2K
- #define F77_ztrmm CZTRMM
- #define F77_ztrsm CZTRSM
-#elif defined(NOCHANGE)
-/*
- * Level 1 BLAS
- */
- #define F77_srotg srotgtest
- #define F77_srotmg srotmgtest
- #define F77_srot srottest
- #define F77_srotm srotmtest
- #define F77_drotg drotgtest
- #define F77_drotmg drotmgtest
- #define F77_drot drottest
- #define F77_drotm drotmtest
- #define F77_sswap sswaptest
- #define F77_scopy scopytest
- #define F77_saxpy saxpytest
- #define F77_isamax isamaxtest
- #define F77_dswap dswaptest
- #define F77_dcopy dcopytest
- #define F77_daxpy daxpytest
- #define F77_idamax idamaxtest
- #define F77_cswap cswaptest
- #define F77_ccopy ccopytest
- #define F77_caxpy caxpytest
- #define F77_icamax icamaxtest
- #define F77_zswap zswaptest
- #define F77_zcopy zcopytest
- #define F77_zaxpy zaxpytest
- #define F77_izamax izamaxtest
- #define F77_sdot sdottest
- #define F77_ddot ddottest
- #define F77_dsdot dsdottest
- #define F77_sscal sscaltest
- #define F77_dscal dscaltest
- #define F77_cscal cscaltest
- #define F77_zscal zscaltest
- #define F77_csscal csscaltest
- #define F77_zdscal zdscaltest
- #define F77_cdotu cdotutest
- #define F77_cdotc cdotctest
- #define F77_zdotu zdotutest
- #define F77_zdotc zdotctest
- #define F77_snrm2 snrm2test
- #define F77_sasum sasumtest
- #define F77_dnrm2 dnrm2test
- #define F77_dasum dasumtest
- #define F77_scnrm2 scnrm2test
- #define F77_scasum scasumtest
- #define F77_dznrm2 dznrm2test
- #define F77_dzasum dzasumtest
- #define F77_sdsdot sdsdottest
-/*
- * Level 2 BLAS
- */
- #define F77_s2chke cs2chke
- #define F77_d2chke cd2chke
- #define F77_c2chke cc2chke
- #define F77_z2chke cz2chke
- #define F77_ssymv cssymv
- #define F77_ssbmv cssbmv
- #define F77_sspmv csspmv
- #define F77_sger csger
- #define F77_ssyr cssyr
- #define F77_sspr csspr
- #define F77_ssyr2 cssyr2
- #define F77_sspr2 csspr2
- #define F77_dsymv cdsymv
- #define F77_dsbmv cdsbmv
- #define F77_dspmv cdspmv
- #define F77_dger cdger
- #define F77_dsyr cdsyr
- #define F77_dspr cdspr
- #define F77_dsyr2 cdsyr2
- #define F77_dspr2 cdspr2
- #define F77_chemv cchemv
- #define F77_chbmv cchbmv
- #define F77_chpmv cchpmv
- #define F77_cgeru ccgeru
- #define F77_cgerc ccgerc
- #define F77_cher ccher
- #define F77_chpr cchpr
- #define F77_cher2 ccher2
- #define F77_chpr2 cchpr2
- #define F77_zhemv czhemv
- #define F77_zhbmv czhbmv
- #define F77_zhpmv czhpmv
- #define F77_zgeru czgeru
- #define F77_zgerc czgerc
- #define F77_zher czher
- #define F77_zhpr czhpr
- #define F77_zher2 czher2
- #define F77_zhpr2 czhpr2
- #define F77_sgemv csgemv
- #define F77_sgbmv csgbmv
- #define F77_strmv cstrmv
- #define F77_stbmv cstbmv
- #define F77_stpmv cstpmv
- #define F77_strsv cstrsv
- #define F77_stbsv cstbsv
- #define F77_stpsv cstpsv
- #define F77_dgemv cdgemv
- #define F77_dgbmv cdgbmv
- #define F77_dtrmv cdtrmv
- #define F77_dtbmv cdtbmv
- #define F77_dtpmv cdtpmv
- #define F77_dtrsv cdtrsv
- #define F77_dtbsv cdtbsv
- #define F77_dtpsv cdtpsv
- #define F77_cgemv ccgemv
- #define F77_cgbmv ccgbmv
- #define F77_ctrmv cctrmv
- #define F77_ctbmv cctbmv
- #define F77_ctpmv cctpmv
- #define F77_ctrsv cctrsv
- #define F77_ctbsv cctbsv
- #define F77_ctpsv cctpsv
- #define F77_zgemv czgemv
- #define F77_zgbmv czgbmv
- #define F77_ztrmv cztrmv
- #define F77_ztbmv cztbmv
- #define F77_ztpmv cztpmv
- #define F77_ztrsv cztrsv
- #define F77_ztbsv cztbsv
- #define F77_ztpsv cztpsv
-/*
- * Level 3 BLAS
- */
- #define F77_s3chke cs3chke
- #define F77_d3chke cd3chke
- #define F77_c3chke cc3chke
- #define F77_z3chke cz3chke
- #define F77_chemm cchemm
- #define F77_cherk ccherk
- #define F77_cher2k ccher2k
- #define F77_zhemm czhemm
- #define F77_zherk czherk
- #define F77_zher2k czher2k
- #define F77_sgemm csgemm
- #define F77_ssymm cssymm
- #define F77_ssyrk cssyrk
- #define F77_ssyr2k cssyr2k
- #define F77_strmm cstrmm
- #define F77_strsm cstrsm
- #define F77_dgemm cdgemm
- #define F77_dsymm cdsymm
- #define F77_dsyrk cdsyrk
- #define F77_dsyr2k cdsyr2k
- #define F77_dtrmm cdtrmm
- #define F77_dtrsm cdtrsm
- #define F77_cgemm ccgemm
- #define F77_cgemm3m ccgemm3m
- #define F77_csymm ccsymm
- #define F77_csyrk ccsyrk
- #define F77_csyr2k ccsyr2k
- #define F77_ctrmm cctrmm
- #define F77_ctrsm cctrsm
- #define F77_zgemm czgemm
- #define F77_zgemm3m czgemm3m
- #define F77_zsymm czsymm
- #define F77_zsyrk czsyrk
- #define F77_zsyr2k czsyr2k
- #define F77_ztrmm cztrmm
- #define F77_ztrsm cztrsm
-#endif
+#define F77_s3chke F77_GLOBAL(cs3chke,CS3CHKE)
+#define F77_d3chke F77_GLOBAL(cd3chke,CD3CHKE)
+#define F77_c3chke F77_GLOBAL(cc3chke,CC3CHKE)
+#define F77_z3chke F77_GLOBAL(cz3chke,CZ3CHKE)
+#define F77_chemm F77_GLOBAL(cchemm,CCHEMM)
+#define F77_cherk F77_GLOBAL(ccherk,CCHERK)
+#define F77_cher2k F77_GLOBAL(ccher2k,CCHER2K)
+#define F77_zhemm F77_GLOBAL(czhemm,CZHEMM)
+#define F77_zherk F77_GLOBAL(czherk,CZHERK)
+#define F77_zher2k F77_GLOBAL(czher2k,CZHER2K)
+#define F77_sgemm F77_GLOBAL(csgemm,CSGEMM)
+#define F77_sgemmtr F77_GLOBAL(csgemmtr,CSGEMMTR)
+#define F77_ssymm F77_GLOBAL(cssymm,CSSYMM)
+#define F77_ssyrk F77_GLOBAL(cssyrk,CSSYRK)
+#define F77_ssyr2k F77_GLOBAL(cssyr2k,CSSYR2K)
+#define F77_strmm F77_GLOBAL(cstrmm,CSTRMM)
+#define F77_strsm F77_GLOBAL(cstrsm,CSTRSM)
+#define F77_dgemm F77_GLOBAL(cdgemm,CDGEMM)
+#define F77_dgemmtr F77_GLOBAL(cdgemmtr,CDGEMMTR)
+#define F77_dsymm F77_GLOBAL(cdsymm,CDSYMM)
+#define F77_dsyrk F77_GLOBAL(cdsyrk,CDSYRK)
+#define F77_dsyr2k F77_GLOBAL(cdsyr2k,CDSYR2K)
+#define F77_dtrmm F77_GLOBAL(cdtrmm,CDTRMM)
+#define F77_dtrsm F77_GLOBAL(cdtrsm,CDTRSM)
+#define F77_cgemm F77_GLOBAL(ccgemm,CCGEMM)
+#define F77_cgemmtr F77_GLOBAL(ccgemmtr,CCGEMMTR)
+#define F77_csymm F77_GLOBAL(ccsymm,CCSYMM)
+#define F77_csyrk F77_GLOBAL(ccsyrk,CCSYRK)
+#define F77_csyr2k F77_GLOBAL(ccsyr2k,CCSYR2K)
+#define F77_ctrmm F77_GLOBAL(cctrmm,CCTRMM)
+#define F77_ctrsm F77_GLOBAL(cctrsm,CCTRSM)
+#define F77_zgemm F77_GLOBAL(czgemm,CZGEMM)
+#define F77_zgemmtr F77_GLOBAL(czgemmtr,CZGEMMTR)
+#define F77_zsymm F77_GLOBAL(czsymm,CZSYMM)
+#define F77_zsyrk F77_GLOBAL(czsyrk,CZSYRK)
+#define F77_zsyr2k F77_GLOBAL(czsyr2k,CZSYR2K)
+#define F77_ztrmm F77_GLOBAL(cztrmm,CZTRMM)
+#define F77_ztrsm F77_GLOBAL(cztrsm, CZTRSM)
-void get_transpose_type(char *type, enum CBLAS_TRANSPOSE *trans);
-void get_uplo_type(char *type, enum CBLAS_UPLO *uplo);
-void get_diag_type(char *type, enum CBLAS_DIAG *diag);
-void get_side_type(char *type, enum CBLAS_SIDE *side);
+void get_transpose_type(char *type, CBLAS_TRANSPOSE *trans);
+void get_uplo_type(char *type, CBLAS_UPLO *uplo);
+void get_diag_type(char *type, CBLAS_DIAG *diag);
+void get_side_type(char *type, CBLAS_SIDE *side);
#endif /* CBLAS_TEST_H */
diff --git a/ctest/cin3 b/ctest/cin3
index fbdb578570..093bf8e26a 100644
--- a/ctest/cin3
+++ b/ctest/cin3
@@ -1,12 +1,12 @@
'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.
-T LOGICAL FLAG, T TO STOP ON FAILURES.
+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 35 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
@@ -20,3 +20,4 @@ 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.
+cblas_cgemmtr T PUT F FOR NO TEST. SAME COLUMNS.
diff --git a/ctest/din3 b/ctest/din3
index 9919774ac1..350544d66f 100644
--- a/ctest/din3
+++ b/ctest/din3
@@ -1,19 +1,20 @@
'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.
-T LOGICAL FLAG, T TO STOP ON FAILURES.
+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
-7 NUMBER OF VALUES OF N
-1 2 3 5 7 9 35 VALUES OF N
+6 NUMBER OF VALUES OF N
+1 2 3 5 7 9 VALUES OF N
3 NUMBER OF VALUES OF ALPHA
0.0 1.0 0.7 VALUES OF ALPHA
3 NUMBER OF VALUES OF BETA
0.0 1.0 1.3 VALUES OF BETA
-cblas_dgemm T PUT F FOR NO TEST. SAME COLUMNS.
-cblas_dsymm T PUT F FOR NO TEST. SAME COLUMNS.
-cblas_dtrmm T PUT F FOR NO TEST. SAME COLUMNS.
-cblas_dtrsm T PUT F FOR NO TEST. SAME COLUMNS.
-cblas_dsyrk T PUT F FOR NO TEST. SAME COLUMNS.
-cblas_dsyr2k T PUT F FOR NO TEST. SAME COLUMNS.
+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.
+cblas_dgemmtr T PUT F FOR NO TEST. SAME COLUMNS.
diff --git a/ctest/sin3 b/ctest/sin3
index b74206b70c..f332c8a9e0 100644
--- a/ctest/sin3
+++ b/ctest/sin3
@@ -1,19 +1,20 @@
'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.
-T LOGICAL FLAG, T TO STOP ON FAILURES.
+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
-7 NUMBER OF VALUES OF N
-0 1 2 3 5 9 35 VALUES OF N
+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.
+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.
+cblas_sgemmtr T PUT F FOR NO TEST. SAME COLUMNS.
diff --git a/ctest/zin3 b/ctest/zin3
index ee269e8d59..7e00e13ced 100644
--- a/ctest/zin3
+++ b/ctest/zin3
@@ -1,22 +1,23 @@
'ZBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE
-1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
-T LOGICAL FLAG, T TO STOP ON FAILURES.
+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
-7 NUMBER OF VALUES OF N
-0 1 2 3 5 9 35 VALUES OF N
+6 NUMBER OF VALUES OF N
+0 1 2 3 5 9 VALUES OF N
3 NUMBER OF VALUES OF ALPHA
(0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA
3 NUMBER OF VALUES OF BETA
(0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA
-cblas_zgemm T PUT F FOR NO TEST. SAME COLUMNS.
-cblas_zhemm T PUT F FOR NO TEST. SAME COLUMNS.
-cblas_zsymm T PUT F FOR NO TEST. SAME COLUMNS.
-cblas_ztrmm T PUT F FOR NO TEST. SAME COLUMNS.
-cblas_ztrsm T PUT F FOR NO TEST. SAME COLUMNS.
-cblas_zherk T PUT F FOR NO TEST. SAME COLUMNS.
-cblas_zsyrk T PUT F FOR NO TEST. SAME COLUMNS.
-cblas_zher2k T PUT F FOR NO TEST. SAME COLUMNS.
-cblas_zsyr2k T PUT F FOR NO TEST. SAME COLUMNS.
+cblas_zgemm T PUT F FOR NO TEST. SAME COLUMNS.
+cblas_zhemm T PUT F FOR NO TEST. SAME COLUMNS.
+cblas_zsymm T PUT F FOR NO TEST. SAME COLUMNS.
+cblas_ztrmm T PUT F FOR NO TEST. SAME COLUMNS.
+cblas_ztrsm T PUT F FOR NO TEST. SAME COLUMNS.
+cblas_zherk T PUT F FOR NO TEST. SAME COLUMNS.
+cblas_zsyrk T PUT F FOR NO TEST. SAME COLUMNS.
+cblas_zher2k T PUT F FOR NO TEST. SAME COLUMNS.
+cblas_zsyr2k T PUT F FOR NO TEST. SAME COLUMNS.
+cblas_zgemmtr T PUT F FOR NO TEST. SAME COLUMNS.
From a9d24e6cb61920cccf5a50bf78a96bb96e561abb Mon Sep 17 00:00:00 2001
From: Martin Kroeker <martin@ruby.chemie.uni-freiburg.de>
Date: Thu, 20 Mar 2025 11:10:55 +0100
Subject: [PATCH 03/17] Fix source files for gemmtr and sbgemmt
---
interface/CMakeLists.txt | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/interface/CMakeLists.txt b/interface/CMakeLists.txt
index c0d5896e17..8a75b10ebf 100644
--- a/interface/CMakeLists.txt
+++ b/interface/CMakeLists.txt
@@ -109,7 +109,7 @@ endif ()
GenerateNamedObjects("trsm.c" "TRMM" "trmm" ${CBLAS_FLAG})
# gemmtr is gemmt under the name adopted by the Reference BLAS
- GenerateNamedObjects("gemm.c" "RNAME" "gemmtr" ${CBLAS_FLAG})
+ GenerateNamedObjects("gemmt.c" "RNAME" "gemmtr" ${CBLAS_FLAG})
# max and imax are compiled 4 times
GenerateNamedObjects("max.c" "" "" ${CBLAS_FLAG})
@@ -125,8 +125,8 @@ endif ()
if (BUILD_BFLOAT16)
GenerateNamedObjects("bf16dot.c" "" "sbdot" ${CBLAS_FLAG} "" "" true "BFLOAT16")
GenerateNamedObjects("gemm.c" "" "sbgemm" ${CBLAS_FLAG} "" "" true "BFLOAT16")
- GenerateNamedObjects("gemmt.c" "" "sbgemmt" ${CBLAS_FLAG} "" "" true "BFLOAT16")
- GenerateNamedObjects("gemmt.c" "RNAME" "sbgemmtr" ${CBLAS_FLAG} "" "" true "BFLOAT16")
+ GenerateNamedObjects("sbgemmt.c" "" "sbgemmt" ${CBLAS_FLAG} "" "" true "BFLOAT16")
+ GenerateNamedObjects("sbgemmt.c" "RNAME" "sbgemmtr" ${CBLAS_FLAG} "" "" true "BFLOAT16")
GenerateNamedObjects("sbgemv.c" "" "sbgemv" ${CBLAS_FLAG} "" "" true "BFLOAT16")
GenerateNamedObjects("tobf16.c" "SINGLE_PREC" "sbstobf16" ${CBLAS_FLAG} "" "" true "BFLOAT16")
GenerateNamedObjects("tobf16.c" "DOUBLE_PREC" "sbdtobf16" ${CBLAS_FLAG} "" "" true "BFLOAT16")
From 9fe2784b0cd6b367dc64ef6d881a9457f8d9dac9 Mon Sep 17 00:00:00 2001
From: Martin Kroeker <martin@ruby.chemie.uni-freiburg.de>
Date: Thu, 20 Mar 2025 11:44:10 +0100
Subject: [PATCH 04/17] Delete non-applicable header entries from
Reference-LAPACK
---
ctest/cblas_test.h | 9 ---------
1 file changed, 9 deletions(-)
diff --git a/ctest/cblas_test.h b/ctest/cblas_test.h
index 3b6ce166fe..a4a8f569ec 100644
--- a/ctest/cblas_test.h
+++ b/ctest/cblas_test.h
@@ -5,16 +5,7 @@
#ifndef CBLAS_TEST_H
#define CBLAS_TEST_H
#include "cblas.h"
-#include "cblas_mangling.h"
-/* It seems all current Fortran compilers put strlen at end.
-* Some historical compilers put strlen after the str argument
-* or make the str argument into a struct. */
-#define BLAS_FORTRAN_STRLEN_END
-
-#ifndef FORTRAN_STRLEN
- #define FORTRAN_STRLEN size_t
-#endif
#define TRUE 1
#define PASSED 1
From d1d3342fe53f639cc0abd72cfc53295e29adcda4 Mon Sep 17 00:00:00 2001
From: Martin Kroeker <martin@ruby.chemie.uni-freiburg.de>
Date: Thu, 20 Mar 2025 15:44:59 +0100
Subject: [PATCH 05/17] Restore OpenBLAS version of header and add GEMMTR
---
ctest/cblas_test.h | 665 ++++++++++++++++++++++++++++++++++-----------
1 file changed, 506 insertions(+), 159 deletions(-)
diff --git a/ctest/cblas_test.h b/ctest/cblas_test.h
index a4a8f569ec..b9a75b3ee1 100644
--- a/ctest/cblas_test.h
+++ b/ctest/cblas_test.h
@@ -6,6 +6,18 @@
#define CBLAS_TEST_H
#include "cblas.h"
+#ifdef USE64BITINT
+#define int long
+#endif
+
+#if defined(_MSC_VER) && defined(__INTEL_CLANG_COMPILER)
+//#define LAPACK_COMPLEX_STRUCTURE
+#define NOCHANGE
+#endif
+/* e.g. mingw64/x86_64-w64-mingw32/include/winerror.h */
+#ifdef FAILED
+#undef FAILED
+#endif
#define TRUE 1
#define PASSED 1
@@ -21,174 +33,509 @@
typedef struct { float real; float imag; } CBLAS_TEST_COMPLEX;
typedef struct { double real; double imag; } CBLAS_TEST_ZOMPLEX;
-//#define F77_xerbla F77_GLOBAL(xerbla,XERBLA)
+#if defined(ADD_)
+/*
+ * Level 1 BLAS
+ */
+ #define F77_srotg srotgtest_
+ #define F77_srotmg srotmgtest_
+ #define F77_srot srottest_
+ #define F77_srotm srotmtest_
+ #define F77_drotg drotgtest_
+ #define F77_drotmg drotmgtest_
+ #define F77_drot drottest_
+ #define F77_drotm drotmtest_
+ #define F77_sswap sswaptest_
+ #define F77_scopy scopytest_
+ #define F77_saxpy saxpytest_
+ #define F77_isamax isamaxtest_
+ #define F77_dswap dswaptest_
+ #define F77_dcopy dcopytest_
+ #define F77_daxpy daxpytest_
+ #define F77_idamax idamaxtest_
+ #define F77_cswap cswaptest_
+ #define F77_ccopy ccopytest_
+ #define F77_caxpy caxpytest_
+ #define F77_icamax icamaxtest_
+ #define F77_zswap zswaptest_
+ #define F77_zcopy zcopytest_
+ #define F77_zaxpy zaxpytest_
+ #define F77_izamax izamaxtest_
+ #define F77_sdot sdottest_
+ #define F77_ddot ddottest_
+ #define F77_dsdot dsdottest_
+ #define F77_sscal sscaltest_
+ #define F77_dscal dscaltest_
+ #define F77_cscal cscaltest_
+ #define F77_zscal zscaltest_
+ #define F77_csscal csscaltest_
+ #define F77_zdscal zdscaltest_
+ #define F77_cdotu cdotutest_
+ #define F77_cdotc cdotctest_
+ #define F77_zdotu zdotutest_
+ #define F77_zdotc zdotctest_
+ #define F77_snrm2 snrm2test_
+ #define F77_sasum sasumtest_
+ #define F77_dnrm2 dnrm2test_
+ #define F77_dasum dasumtest_
+ #define F77_scnrm2 scnrm2test_
+ #define F77_scasum scasumtest_
+ #define F77_dznrm2 dznrm2test_
+ #define F77_dzasum dzasumtest_
+ #define F77_sdsdot sdsdottest_
+/*
+ * Level 2 BLAS
+ */
+ #define F77_s2chke cs2chke_
+ #define F77_d2chke cd2chke_
+ #define F77_c2chke cc2chke_
+ #define F77_z2chke cz2chke_
+ #define F77_ssymv cssymv_
+ #define F77_ssbmv cssbmv_
+ #define F77_sspmv csspmv_
+ #define F77_sger csger_
+ #define F77_ssyr cssyr_
+ #define F77_sspr csspr_
+ #define F77_ssyr2 cssyr2_
+ #define F77_sspr2 csspr2_
+ #define F77_dsymv cdsymv_
+ #define F77_dsbmv cdsbmv_
+ #define F77_dspmv cdspmv_
+ #define F77_dger cdger_
+ #define F77_dsyr cdsyr_
+ #define F77_dspr cdspr_
+ #define F77_dsyr2 cdsyr2_
+ #define F77_dspr2 cdspr2_
+ #define F77_chemv cchemv_
+ #define F77_chbmv cchbmv_
+ #define F77_chpmv cchpmv_
+ #define F77_cgeru ccgeru_
+ #define F77_cgerc ccgerc_
+ #define F77_cher ccher_
+ #define F77_chpr cchpr_
+ #define F77_cher2 ccher2_
+ #define F77_chpr2 cchpr2_
+ #define F77_zhemv czhemv_
+ #define F77_zhbmv czhbmv_
+ #define F77_zhpmv czhpmv_
+ #define F77_zgeru czgeru_
+ #define F77_zgerc czgerc_
+ #define F77_zher czher_
+ #define F77_zhpr czhpr_
+ #define F77_zher2 czher2_
+ #define F77_zhpr2 czhpr2_
+ #define F77_sgemv csgemv_
+ #define F77_sgbmv csgbmv_
+ #define F77_strmv cstrmv_
+ #define F77_stbmv cstbmv_
+ #define F77_stpmv cstpmv_
+ #define F77_strsv cstrsv_
+ #define F77_stbsv cstbsv_
+ #define F77_stpsv cstpsv_
+ #define F77_dgemv cdgemv_
+ #define F77_dgbmv cdgbmv_
+ #define F77_dtrmv cdtrmv_
+ #define F77_dtbmv cdtbmv_
+ #define F77_dtpmv cdtpmv_
+ #define F77_dtrsv cdtrsv_
+ #define F77_dtbsv cdtbsv_
+ #define F77_dtpsv cdtpsv_
+ #define F77_cgemv ccgemv_
+ #define F77_cgbmv ccgbmv_
+ #define F77_ctrmv cctrmv_
+ #define F77_ctbmv cctbmv_
+ #define F77_ctpmv cctpmv_
+ #define F77_ctrsv cctrsv_
+ #define F77_ctbsv cctbsv_
+ #define F77_ctpsv cctpsv_
+ #define F77_zgemv czgemv_
+ #define F77_zgbmv czgbmv_
+ #define F77_ztrmv cztrmv_
+ #define F77_ztbmv cztbmv_
+ #define F77_ztpmv cztpmv_
+ #define F77_ztrsv cztrsv_
+ #define F77_ztbsv cztbsv_
+ #define F77_ztpsv cztpsv_
+/*
+ * Level 3 BLAS
+ */
+ #define F77_s3chke cs3chke_
+ #define F77_d3chke cd3chke_
+ #define F77_c3chke cc3chke_
+ #define F77_z3chke cz3chke_
+ #define F77_chemm cchemm_
+ #define F77_cherk ccherk_
+ #define F77_cher2k ccher2k_
+ #define F77_zhemm czhemm_
+ #define F77_zherk czherk_
+ #define F77_zher2k czher2k_
+ #define F77_sgemm csgemm_
+ #define F77_sgemmtr csgemmtr_
+ #define F77_ssymm cssymm_
+ #define F77_ssyrk cssyrk_
+ #define F77_ssyr2k cssyr2k_
+ #define F77_strmm cstrmm_
+ #define F77_strsm cstrsm_
+ #define F77_dgemm cdgemm_
+ #define F77_dgemmtr cdgemmtr_
+ #define F77_dsymm cdsymm_
+ #define F77_dsyrk cdsyrk_
+ #define F77_dsyr2k cdsyr2k_
+ #define F77_dtrmm cdtrmm_
+ #define F77_dtrsm cdtrsm_
+ #define F77_cgemm ccgemm_
+ #define F77_cgemm3m ccgemm3m_
+ #define F77_cgemmtr ccgemmtr_
+ #define F77_csymm ccsymm_
+ #define F77_csyrk ccsyrk_
+ #define F77_csyr2k ccsyr2k_
+ #define F77_ctrmm cctrmm_
+ #define F77_ctrsm cctrsm_
+ #define F77_zgemm czgemm_
+ #define F77_zgemm3m czgemm3m_
+ #define F77_zgemmtr czgemmtr_
+ #define F77_zsymm czsymm_
+ #define F77_zsyrk czsyrk_
+ #define F77_zsyr2k czsyr2k_
+ #define F77_ztrmm cztrmm_
+ #define F77_ztrsm cztrsm_
+#elif defined(UPCASE)
+/*
+ * Level 1 BLAS
+ */
+ #define F77_srotg SROTGTEST
+ #define F77_srotmg SROTMGTEST
+ #define F77_srot SROTCTEST
+ #define F77_srotm SROTMTEST
+ #define F77_drotg DROTGTEST
+ #define F77_drotmg DROTMGTEST
+ #define F77_drot DROTTEST
+ #define F77_drotm DROTMTEST
+ #define F77_sswap SSWAPTEST
+ #define F77_scopy SCOPYTEST
+ #define F77_saxpy SAXPYTEST
+ #define F77_isamax ISAMAXTEST
+ #define F77_dswap DSWAPTEST
+ #define F77_dcopy DCOPYTEST
+ #define F77_daxpy DAXPYTEST
+ #define F77_idamax IDAMAXTEST
+ #define F77_cswap CSWAPTEST
+ #define F77_ccopy CCOPYTEST
+ #define F77_caxpy CAXPYTEST
+ #define F77_icamax ICAMAXTEST
+ #define F77_zswap ZSWAPTEST
+ #define F77_zcopy ZCOPYTEST
+ #define F77_zaxpy ZAXPYTEST
+ #define F77_izamax IZAMAXTEST
+ #define F77_sdot SDOTTEST
+ #define F77_ddot DDOTTEST
+ #define F77_dsdot DSDOTTEST
+ #define F77_sscal SSCALTEST
+ #define F77_dscal DSCALTEST
+ #define F77_cscal CSCALTEST
+ #define F77_zscal ZSCALTEST
+ #define F77_csscal CSSCALTEST
+ #define F77_zdscal ZDSCALTEST
+ #define F77_cdotu CDOTUTEST
+ #define F77_cdotc CDOTCTEST
+ #define F77_zdotu ZDOTUTEST
+ #define F77_zdotc ZDOTCTEST
+ #define F77_snrm2 SNRM2TEST
+ #define F77_sasum SASUMTEST
+ #define F77_dnrm2 DNRM2TEST
+ #define F77_dasum DASUMTEST
+ #define F77_scnrm2 SCNRM2TEST
+ #define F77_scasum SCASUMTEST
+ #define F77_dznrm2 DZNRM2TEST
+ #define F77_dzasum DZASUMTEST
+ #define F77_sdsdot SDSDOTTEST
+/*
+ * Level 2 BLAS
+ */
+ #define F77_s2chke CS2CHKE
+ #define F77_d2chke CD2CHKE
+ #define F77_c2chke CC2CHKE
+ #define F77_z2chke CZ2CHKE
+ #define F77_ssymv CSSYMV
+ #define F77_ssbmv CSSBMV
+ #define F77_sspmv CSSPMV
+ #define F77_sger CSGER
+ #define F77_ssyr CSSYR
+ #define F77_sspr CSSPR
+ #define F77_ssyr2 CSSYR2
+ #define F77_sspr2 CSSPR2
+ #define F77_dsymv CDSYMV
+ #define F77_dsbmv CDSBMV
+ #define F77_dspmv CDSPMV
+ #define F77_dger CDGER
+ #define F77_dsyr CDSYR
+ #define F77_dspr CDSPR
+ #define F77_dsyr2 CDSYR2
+ #define F77_dspr2 CDSPR2
+ #define F77_chemv CCHEMV
+ #define F77_chbmv CCHBMV
+ #define F77_chpmv CCHPMV
+ #define F77_cgeru CCGERU
+ #define F77_cgerc CCGERC
+ #define F77_cher CCHER
+ #define F77_chpr CCHPR
+ #define F77_cher2 CCHER2
+ #define F77_chpr2 CCHPR2
+ #define F77_zhemv CZHEMV
+ #define F77_zhbmv CZHBMV
+ #define F77_zhpmv CZHPMV
+ #define F77_zgeru CZGERU
+ #define F77_zgerc CZGERC
+ #define F77_zher CZHER
+ #define F77_zhpr CZHPR
+ #define F77_zher2 CZHER2
+ #define F77_zhpr2 CZHPR2
+ #define F77_sgemv CSGEMV
+ #define F77_sgbmv CSGBMV
+ #define F77_strmv CSTRMV
+ #define F77_stbmv CSTBMV
+ #define F77_stpmv CSTPMV
+ #define F77_strsv CSTRSV
+ #define F77_stbsv CSTBSV
+ #define F77_stpsv CSTPSV
+ #define F77_dgemv CDGEMV
+ #define F77_dgbmv CDGBMV
+ #define F77_dtrmv CDTRMV
+ #define F77_dtbmv CDTBMV
+ #define F77_dtpmv CDTPMV
+ #define F77_dtrsv CDTRSV
+ #define F77_dtbsv CDTBSV
+ #define F77_dtpsv CDTPSV
+ #define F77_cgemv CCGEMV
+ #define F77_cgbmv CCGBMV
+ #define F77_ctrmv CCTRMV
+ #define F77_ctbmv CCTBMV
+ #define F77_ctpmv CCTPMV
+ #define F77_ctrsv CCTRSV
+ #define F77_ctbsv CCTBSV
+ #define F77_ctpsv CCTPSV
+ #define F77_zgemv CZGEMV
+ #define F77_zgbmv CZGBMV
+ #define F77_ztrmv CZTRMV
+ #define F77_ztbmv CZTBMV
+ #define F77_ztpmv CZTPMV
+ #define F77_ztrsv CZTRSV
+ #define F77_ztbsv CZTBSV
+ #define F77_ztpsv CZTPSV
+/*
+ * Level 3 BLAS
+ */
+ #define F77_s3chke CS3CHKE
+ #define F77_d3chke CD3CHKE
+ #define F77_c3chke CC3CHKE
+ #define F77_z3chke CZ3CHKE
+ #define F77_chemm CCHEMM
+ #define F77_cherk CCHERK
+ #define F77_cher2k CCHER2K
+ #define F77_zhemm CZHEMM
+ #define F77_zherk CZHERK
+ #define F77_zher2k CZHER2K
+ #define F77_sgemm CSGEMM
+ #define F77_sgemmtr CSGEMMTR
+ #define F77_ssymm CSSYMM
+ #define F77_ssyrk CSSYRK
+ #define F77_ssyr2k CSSYR2K
+ #define F77_strmm CSTRMM
+ #define F77_strsm CSTRSM
+ #define F77_dgemm CDGEMM
+ #define F77_dgemmtr CDGEMMTR
+ #define F77_dsymm CDSYMM
+ #define F77_dsyrk CDSYRK
+ #define F77_dsyr2k CDSYR2K
+ #define F77_dtrmm CDTRMM
+ #define F77_dtrsm CDTRSM
+ #define F77_cgemm CCGEMM
+ #define F77_cgemm3m CCGEMM3M
+ #define F77_cgemmtr CCGEMMTR
+ #define F77_csymm CCSYMM
+ #define F77_csyrk CCSYRK
+ #define F77_csyr2k CCSYR2K
+ #define F77_ctrmm CCTRMM
+ #define F77_ctrsm CCTRSM
+ #define F77_zgemm CZGEMM
+ #define F77_zgemm3m CZGEMM3M
+ #define F77_zgemmtr CZGEMMTR
+ #define F77_zsymm CZSYMM
+ #define F77_zsyrk CZSYRK
+ #define F77_zsyr2k CZSYR2K
+ #define F77_ztrmm CZTRMM
+ #define F77_ztrsm CZTRSM
+#elif defined(NOCHANGE)
/*
* Level 1 BLAS
*/
-#define F77_srotg F77_GLOBAL(srotgtest,SROTGTEST)
-#define F77_srotmg F77_GLOBAL(srotmgtest,SROTMGTEST)
-#define F77_srot F77_GLOBAL(srottest,SROTTEST)
-#define F77_srotm F77_GLOBAL(srotmtest,SROTMTEST)
-#define F77_drotg F77_GLOBAL(drotgtest,DROTGTEST)
-#define F77_drotmg F77_GLOBAL(drotmgtest,DROTMGTEST)
-#define F77_drot F77_GLOBAL(drottest,DROTTEST)
-#define F77_drotm F77_GLOBAL(drotmtest,DROTMTEST)
-#define F77_sswap F77_GLOBAL(sswaptest,SSWAPTEST)
-#define F77_scopy F77_GLOBAL(scopytest,SCOPYTEST)
-#define F77_saxpy F77_GLOBAL(saxpytest,SAXPYTEST)
-#define F77_isamax F77_GLOBAL(isamaxtest,ISAMAXTEST)
-#define F77_dswap F77_GLOBAL(dswaptest,DSWAPTEST)
-#define F77_dcopy F77_GLOBAL(dcopytest,DCOPYTEST)
-#define F77_daxpy F77_GLOBAL(daxpytest,DAXPYTEST)
-#define F77_idamax F77_GLOBAL(idamaxtest,IDAMAXTEST)
-#define F77_cswap F77_GLOBAL(cswaptest,CSWAPTEST)
-#define F77_ccopy F77_GLOBAL(ccopytest,CCOPYTEST)
-#define F77_caxpy F77_GLOBAL(caxpytest,CAXPYTEST)
-#define F77_icamax F77_GLOBAL(icamaxtest,ICAMAXTEST)
-#define F77_zswap F77_GLOBAL(zswaptest,ZSWAPTEST)
-#define F77_zcopy F77_GLOBAL(zcopytest,ZCOPYTEST)
-#define F77_zaxpy F77_GLOBAL(zaxpytest,ZAXPYTEST)
-#define F77_izamax F77_GLOBAL(izamaxtest,IZAMAXTEST)
-#define F77_sdot F77_GLOBAL(sdottest,SDOTTEST)
-#define F77_ddot F77_GLOBAL(ddottest,DDOTTEST)
-#define F77_dsdot F77_GLOBAL(dsdottest,DSDOTTEST)
-#define F77_sscal F77_GLOBAL(sscaltest,SSCALTEST)
-#define F77_dscal F77_GLOBAL(dscaltest,DSCALTEST)
-#define F77_cscal F77_GLOBAL(cscaltest,CSCALTEST)
-#define F77_zscal F77_GLOBAL(zscaltest,ZSCALTEST)
-#define F77_csscal F77_GLOBAL(csscaltest,CSSCALTEST)
-#define F77_zdscal F77_GLOBAL(zdscaltest,ZDSCALTEST)
-#define F77_cdotu F77_GLOBAL(cdotutest,CDOTUTEST)
-#define F77_cdotc F77_GLOBAL(cdotctest,CDOTCTEST)
-#define F77_zdotu F77_GLOBAL(zdotutest,ZDOTUTEST)
-#define F77_zdotc F77_GLOBAL(zdotctest,ZDOTCTEST)
-#define F77_snrm2 F77_GLOBAL(snrm2test,SNRM2TEST)
-#define F77_sasum F77_GLOBAL(sasumtest,SASUMTEST)
-#define F77_dnrm2 F77_GLOBAL(dnrm2test,DNRM2TEST)
-#define F77_dasum F77_GLOBAL(dasumtest,DASUMTEST)
-#define F77_scnrm2 F77_GLOBAL(scnrm2test,SCNRM2TEST)
-#define F77_scasum F77_GLOBAL(scasumtest,SCASUMTEST)
-#define F77_dznrm2 F77_GLOBAL(dznrm2test,DZNRM2TEST)
-#define F77_dzasum F77_GLOBAL(dzasumtest,DZASUMTEST)
-#define F77_sdsdot F77_GLOBAL(sdsdottest, SDSDOTTEST)
+ #define F77_srotg srotgtest
+ #define F77_srotmg srotmgtest
+ #define F77_srot srottest
+ #define F77_srotm srotmtest
+ #define F77_drotg drotgtest
+ #define F77_drotmg drotmgtest
+ #define F77_drot drottest
+ #define F77_drotm drotmtest
+ #define F77_sswap sswaptest
+ #define F77_scopy scopytest
+ #define F77_saxpy saxpytest
+ #define F77_isamax isamaxtest
+ #define F77_dswap dswaptest
+ #define F77_dcopy dcopytest
+ #define F77_daxpy daxpytest
+ #define F77_idamax idamaxtest
+ #define F77_cswap cswaptest
+ #define F77_ccopy ccopytest
+ #define F77_caxpy caxpytest
+ #define F77_icamax icamaxtest
+ #define F77_zswap zswaptest
+ #define F77_zcopy zcopytest
+ #define F77_zaxpy zaxpytest
+ #define F77_izamax izamaxtest
+ #define F77_sdot sdottest
+ #define F77_ddot ddottest
+ #define F77_dsdot dsdottest
+ #define F77_sscal sscaltest
+ #define F77_dscal dscaltest
+ #define F77_cscal cscaltest
+ #define F77_zscal zscaltest
+ #define F77_csscal csscaltest
+ #define F77_zdscal zdscaltest
+ #define F77_cdotu cdotutest
+ #define F77_cdotc cdotctest
+ #define F77_zdotu zdotutest
+ #define F77_zdotc zdotctest
+ #define F77_snrm2 snrm2test
+ #define F77_sasum sasumtest
+ #define F77_dnrm2 dnrm2test
+ #define F77_dasum dasumtest
+ #define F77_scnrm2 scnrm2test
+ #define F77_scasum scasumtest
+ #define F77_dznrm2 dznrm2test
+ #define F77_dzasum dzasumtest
+ #define F77_sdsdot sdsdottest
/*
* Level 2 BLAS
*/
-#define F77_s2chke F77_GLOBAL(cs2chke,CS2CHKE)
-#define F77_d2chke F77_GLOBAL(cd2chke,CD2CHKE)
-#define F77_c2chke F77_GLOBAL(cc2chke,CC2CHKE)
-#define F77_z2chke F77_GLOBAL(cz2chke,CZ2CHKE)
-#define F77_ssymv F77_GLOBAL(cssymv,CSSYMV)
-#define F77_ssbmv F77_GLOBAL(cssbmv,CSSBMV)
-#define F77_sspmv F77_GLOBAL(csspmv,CSSPMV)
-#define F77_sger F77_GLOBAL(csger,CSGER)
-#define F77_ssyr F77_GLOBAL(cssyr,CSSYR)
-#define F77_sspr F77_GLOBAL(csspr,CSSPR)
-#define F77_ssyr2 F77_GLOBAL(cssyr2,CSSYR2)
-#define F77_sspr2 F77_GLOBAL(csspr2,CSSPR2)
-#define F77_dsymv F77_GLOBAL(cdsymv,CDSYMV)
-#define F77_dsbmv F77_GLOBAL(cdsbmv,CDSBMV)
-#define F77_dspmv F77_GLOBAL(cdspmv,CDSPMV)
-#define F77_dger F77_GLOBAL(cdger,CDGER)
-#define F77_dsyr F77_GLOBAL(cdsyr,CDSYR)
-#define F77_dspr F77_GLOBAL(cdspr,CDSPR)
-#define F77_dsyr2 F77_GLOBAL(cdsyr2,CDSYR2)
-#define F77_dspr2 F77_GLOBAL(cdspr2,CDSPR2)
-#define F77_chemv F77_GLOBAL(cchemv,CCHEMV)
-#define F77_chbmv F77_GLOBAL(cchbmv,CCHBMV)
-#define F77_chpmv F77_GLOBAL(cchpmv,CCHPMV)
-#define F77_cgeru F77_GLOBAL(ccgeru,CCGERU)
-#define F77_cgerc F77_GLOBAL(ccgerc,CCGERC)
-#define F77_cher F77_GLOBAL(ccher,CCHER)
-#define F77_chpr F77_GLOBAL(cchpr,CCHPR)
-#define F77_cher2 F77_GLOBAL(ccher2,CCHER2)
-#define F77_chpr2 F77_GLOBAL(cchpr2,CCHPR2)
-#define F77_zhemv F77_GLOBAL(czhemv,CZHEMV)
-#define F77_zhbmv F77_GLOBAL(czhbmv,CZHBMV)
-#define F77_zhpmv F77_GLOBAL(czhpmv,CZHPMV)
-#define F77_zgeru F77_GLOBAL(czgeru,CZGERU)
-#define F77_zgerc F77_GLOBAL(czgerc,CZGERC)
-#define F77_zher F77_GLOBAL(czher,CZHER)
-#define F77_zhpr F77_GLOBAL(czhpr,CZHPR)
-#define F77_zher2 F77_GLOBAL(czher2,CZHER2)
-#define F77_zhpr2 F77_GLOBAL(czhpr2,CZHPR2)
-#define F77_sgemv F77_GLOBAL(csgemv,CSGEMV)
-#define F77_sgbmv F77_GLOBAL(csgbmv,CSGBMV)
-#define F77_strmv F77_GLOBAL(cstrmv,CSTRMV)
-#define F77_stbmv F77_GLOBAL(cstbmv,CSTBMV)
-#define F77_stpmv F77_GLOBAL(cstpmv,CSTPMV)
-#define F77_strsv F77_GLOBAL(cstrsv,CSTRSV)
-#define F77_stbsv F77_GLOBAL(cstbsv,CSTBSV)
-#define F77_stpsv F77_GLOBAL(cstpsv,CSTPSV)
-#define F77_dgemv F77_GLOBAL(cdgemv,CDGEMV)
-#define F77_dgbmv F77_GLOBAL(cdgbmv,CDGBMV)
-#define F77_dtrmv F77_GLOBAL(cdtrmv,CDTRMV)
-#define F77_dtbmv F77_GLOBAL(cdtbmv,CDTBMV)
-#define F77_dtpmv F77_GLOBAL(cdtpmv,CDTPMV)
-#define F77_dtrsv F77_GLOBAL(cdtrsv,CDTRSV)
-#define F77_dtbsv F77_GLOBAL(cdtbsv,CDTBSV)
-#define F77_dtpsv F77_GLOBAL(cdtpsv,CDTPSV)
-#define F77_cgemv F77_GLOBAL(ccgemv,CCGEMV)
-#define F77_cgbmv F77_GLOBAL(ccgbmv,CCGBMV)
-#define F77_ctrmv F77_GLOBAL(cctrmv,CCTRMV)
-#define F77_ctbmv F77_GLOBAL(cctbmv,CCTBMV)
-#define F77_ctpmv F77_GLOBAL(cctpmv,CCTPMV)
-#define F77_ctrsv F77_GLOBAL(cctrsv,CCTRSV)
-#define F77_ctbsv F77_GLOBAL(cctbsv,CCTBSV)
-#define F77_ctpsv F77_GLOBAL(cctpsv,CCTPSV)
-#define F77_zgemv F77_GLOBAL(czgemv,CZGEMV)
-#define F77_zgbmv F77_GLOBAL(czgbmv,CZGBMV)
-#define F77_ztrmv F77_GLOBAL(cztrmv,CZTRMV)
-#define F77_ztbmv F77_GLOBAL(cztbmv,CZTBMV)
-#define F77_ztpmv F77_GLOBAL(cztpmv,CZTPMV)
-#define F77_ztrsv F77_GLOBAL(cztrsv,CZTRSV)
-#define F77_ztbsv F77_GLOBAL(cztbsv,CZTBSV)
-#define F77_ztpsv F77_GLOBAL(cztpsv,CZTPSV)
+ #define F77_s2chke cs2chke
+ #define F77_d2chke cd2chke
+ #define F77_c2chke cc2chke
+ #define F77_z2chke cz2chke
+ #define F77_ssymv cssymv
+ #define F77_ssbmv cssbmv
+ #define F77_sspmv csspmv
+ #define F77_sger csger
+ #define F77_ssyr cssyr
+ #define F77_sspr csspr
+ #define F77_ssyr2 cssyr2
+ #define F77_sspr2 csspr2
+ #define F77_dsymv cdsymv
+ #define F77_dsbmv cdsbmv
+ #define F77_dspmv cdspmv
+ #define F77_dger cdger
+ #define F77_dsyr cdsyr
+ #define F77_dspr cdspr
+ #define F77_dsyr2 cdsyr2
+ #define F77_dspr2 cdspr2
+ #define F77_chemv cchemv
+ #define F77_chbmv cchbmv
+ #define F77_chpmv cchpmv
+ #define F77_cgeru ccgeru
+ #define F77_cgerc ccgerc
+ #define F77_cher ccher
+ #define F77_chpr cchpr
+ #define F77_cher2 ccher2
+ #define F77_chpr2 cchpr2
+ #define F77_zhemv czhemv
+ #define F77_zhbmv czhbmv
+ #define F77_zhpmv czhpmv
+ #define F77_zgeru czgeru
+ #define F77_zgerc czgerc
+ #define F77_zher czher
+ #define F77_zhpr czhpr
+ #define F77_zher2 czher2
+ #define F77_zhpr2 czhpr2
+ #define F77_sgemv csgemv
+ #define F77_sgbmv csgbmv
+ #define F77_strmv cstrmv
+ #define F77_stbmv cstbmv
+ #define F77_stpmv cstpmv
+ #define F77_strsv cstrsv
+ #define F77_stbsv cstbsv
+ #define F77_stpsv cstpsv
+ #define F77_dgemv cdgemv
+ #define F77_dgbmv cdgbmv
+ #define F77_dtrmv cdtrmv
+ #define F77_dtbmv cdtbmv
+ #define F77_dtpmv cdtpmv
+ #define F77_dtrsv cdtrsv
+ #define F77_dtbsv cdtbsv
+ #define F77_dtpsv cdtpsv
+ #define F77_cgemv ccgemv
+ #define F77_cgbmv ccgbmv
+ #define F77_ctrmv cctrmv
+ #define F77_ctbmv cctbmv
+ #define F77_ctpmv cctpmv
+ #define F77_ctrsv cctrsv
+ #define F77_ctbsv cctbsv
+ #define F77_ctpsv cctpsv
+ #define F77_zgemv czgemv
+ #define F77_zgbmv czgbmv
+ #define F77_ztrmv cztrmv
+ #define F77_ztbmv cztbmv
+ #define F77_ztpmv cztpmv
+ #define F77_ztrsv cztrsv
+ #define F77_ztbsv cztbsv
+ #define F77_ztpsv cztpsv
/*
* Level 3 BLAS
*/
-#define F77_s3chke F77_GLOBAL(cs3chke,CS3CHKE)
-#define F77_d3chke F77_GLOBAL(cd3chke,CD3CHKE)
-#define F77_c3chke F77_GLOBAL(cc3chke,CC3CHKE)
-#define F77_z3chke F77_GLOBAL(cz3chke,CZ3CHKE)
-#define F77_chemm F77_GLOBAL(cchemm,CCHEMM)
-#define F77_cherk F77_GLOBAL(ccherk,CCHERK)
-#define F77_cher2k F77_GLOBAL(ccher2k,CCHER2K)
-#define F77_zhemm F77_GLOBAL(czhemm,CZHEMM)
-#define F77_zherk F77_GLOBAL(czherk,CZHERK)
-#define F77_zher2k F77_GLOBAL(czher2k,CZHER2K)
-#define F77_sgemm F77_GLOBAL(csgemm,CSGEMM)
-#define F77_sgemmtr F77_GLOBAL(csgemmtr,CSGEMMTR)
-#define F77_ssymm F77_GLOBAL(cssymm,CSSYMM)
-#define F77_ssyrk F77_GLOBAL(cssyrk,CSSYRK)
-#define F77_ssyr2k F77_GLOBAL(cssyr2k,CSSYR2K)
-#define F77_strmm F77_GLOBAL(cstrmm,CSTRMM)
-#define F77_strsm F77_GLOBAL(cstrsm,CSTRSM)
-#define F77_dgemm F77_GLOBAL(cdgemm,CDGEMM)
-#define F77_dgemmtr F77_GLOBAL(cdgemmtr,CDGEMMTR)
-#define F77_dsymm F77_GLOBAL(cdsymm,CDSYMM)
-#define F77_dsyrk F77_GLOBAL(cdsyrk,CDSYRK)
-#define F77_dsyr2k F77_GLOBAL(cdsyr2k,CDSYR2K)
-#define F77_dtrmm F77_GLOBAL(cdtrmm,CDTRMM)
-#define F77_dtrsm F77_GLOBAL(cdtrsm,CDTRSM)
-#define F77_cgemm F77_GLOBAL(ccgemm,CCGEMM)
-#define F77_cgemmtr F77_GLOBAL(ccgemmtr,CCGEMMTR)
-#define F77_csymm F77_GLOBAL(ccsymm,CCSYMM)
-#define F77_csyrk F77_GLOBAL(ccsyrk,CCSYRK)
-#define F77_csyr2k F77_GLOBAL(ccsyr2k,CCSYR2K)
-#define F77_ctrmm F77_GLOBAL(cctrmm,CCTRMM)
-#define F77_ctrsm F77_GLOBAL(cctrsm,CCTRSM)
-#define F77_zgemm F77_GLOBAL(czgemm,CZGEMM)
-#define F77_zgemmtr F77_GLOBAL(czgemmtr,CZGEMMTR)
-#define F77_zsymm F77_GLOBAL(czsymm,CZSYMM)
-#define F77_zsyrk F77_GLOBAL(czsyrk,CZSYRK)
-#define F77_zsyr2k F77_GLOBAL(czsyr2k,CZSYR2K)
-#define F77_ztrmm F77_GLOBAL(cztrmm,CZTRMM)
-#define F77_ztrsm F77_GLOBAL(cztrsm, CZTRSM)
+ #define F77_s3chke cs3chke
+ #define F77_d3chke cd3chke
+ #define F77_c3chke cc3chke
+ #define F77_z3chke cz3chke
+ #define F77_chemm cchemm
+ #define F77_cherk ccherk
+ #define F77_cher2k ccher2k
+ #define F77_zhemm czhemm
+ #define F77_zherk czherk
+ #define F77_zher2k czher2k
+ #define F77_sgemm csgemm
+ #define F77_sgemmtr csgemmtr
+ #define F77_ssymm cssymm
+ #define F77_ssyrk cssyrk
+ #define F77_ssyr2k cssyr2k
+ #define F77_strmm cstrmm
+ #define F77_strsm cstrsm
+ #define F77_dgemm cdgemm
+ #define F77_dgemmtr cdgemmtr
+ #define F77_dsymm cdsymm
+ #define F77_dsyrk cdsyrk
+ #define F77_dsyr2k cdsyr2k
+ #define F77_dtrmm cdtrmm
+ #define F77_dtrsm cdtrsm
+ #define F77_cgemm ccgemm
+ #define F77_cgemm3m ccgemm3m
+ #define F77_cgemmtr ccgemmtr
+ #define F77_csymm ccsymm
+ #define F77_csyrk ccsyrk
+ #define F77_csyr2k ccsyr2k
+ #define F77_ctrmm cctrmm
+ #define F77_ctrsm cctrsm
+ #define F77_zgemm czgemm
+ #define F77_zgemm3m czgemm3m
+ #define F77_zgemmtr czgemmtr
+ #define F77_zsymm czsymm
+ #define F77_zsyrk czsyrk
+ #define F77_zsyr2k czsyr2k
+ #define F77_ztrmm cztrmm
+ #define F77_ztrsm cztrsm
+#endif
-void get_transpose_type(char *type, CBLAS_TRANSPOSE *trans);
-void get_uplo_type(char *type, CBLAS_UPLO *uplo);
-void get_diag_type(char *type, CBLAS_DIAG *diag);
-void get_side_type(char *type, CBLAS_SIDE *side);
+void get_transpose_type(char *type, enum CBLAS_TRANSPOSE *trans);
+void get_uplo_type(char *type, enum CBLAS_UPLO *uplo);
+void get_diag_type(char *type, enum CBLAS_DIAG *diag);
+void get_side_type(char *type, enum CBLAS_SIDE *side);
#endif /* CBLAS_TEST_H */
From cf4c5a6d89e13656fea12b4a10448c0ebcea4893 Mon Sep 17 00:00:00 2001
From: Martin Kroeker <martin@ruby.chemie.uni-freiburg.de>
Date: Thu, 20 Mar 2025 20:20:41 +0100
Subject: [PATCH 06/17] Update f2c-translated stand-ins to include GEMMTR
---
ctest/c_cblat3c.c | 3895 +++-----------------------------------------
ctest/c_dblat3c.c | 3284 +++----------------------------------
ctest/c_sblat3c.c | 3296 +++----------------------------------
ctest/c_zblat3c.c | 3930 +++------------------------------------------
4 files changed, 942 insertions(+), 13463 deletions(-)
diff --git a/ctest/c_cblat3c.c b/ctest/c_cblat3c.c
index 5ad9b8bd89..447b23014f 100644
--- a/ctest/c_cblat3c.c
+++ b/ctest/c_cblat3c.c
@@ -10,7 +10,25 @@
#undef I
#endif
-#include "common.h"
+#if defined(_WIN64)
+typedef long long BLASLONG;
+typedef unsigned long long BLASULONG;
+#else
+typedef long BLASLONG;
+typedef unsigned long BLASULONG;
+#endif
+
+#ifdef LAPACK_ILP64
+typedef BLASLONG blasint;
+#if defined(_WIN64)
+#define blasabs(x) llabs(x)
+#else
+#define blasabs(x) labs(x)
+#endif
+#else
+typedef int blasint;
+#define blasabs(x) abs(x)
+#endif
typedef blasint integer;
@@ -229,6 +247,7 @@ typedef struct Namelist Namelist;
#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
#define sig_die(s, kill) { exit(1); }
#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
#define z_abs(z) (cabs(Cd(z)))
#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
@@ -242,3701 +261,251 @@ typedef struct Namelist Namelist;
/* procedure parameter types for -A and -C++ */
#define F2C_proc_par_types 1
-
-
-/* Common Block Declarations */
-
-struct {
- integer infot, noutc;
- logical ok, lerr;
-} infoc_;
-
-#define infoc_1 infoc_
-
-struct {
- char srnamt[12];
-} srnamc_;
-
-#define srnamc_1 srnamc_
-
-/* Table of constant values */
-
-static complex c_b1 = {0.f,0.f};
-static complex c_b2 = {1.f,0.f};
-static integer c__1 = 1;
-static integer c__65 = 65;
-static integer c__6 = 6;
-static real c_b91 = 1.f;
-static logical c_true = TRUE_;
-static integer c__0 = 0;
-static logical c_false = FALSE_;
-
-int /* Main program */ main(void)
-{
- /* Initialized data */
-
- static char snames[9][13] = {"cblas_cgemm ", "cblas_chemm ", "cblas_csymm ",
- "cblas_ctrmm ", "cblas_ctrsm ", "cblas_cherk ", "cblas_csyrk ",
- "cblas_cher2k", "cblas_csyr2k"};
-
- /* System generated locals */
- integer i__1, i__2, i__3, i__4, i__5;
- real r__1;
-
- /* Local variables */
- integer nalf, idim[9];
- logical same;
- integer nbet, ntra;
- logical rewi;
- extern /* Subroutine */ int cchk1_(char *, real *, real *, integer *,
- integer *, logical *, logical *, logical *, integer *, integer *,
- integer *, complex *, integer *, complex *, integer *, complex *,
- complex *, complex *, complex *, complex *, complex *, complex *,
- complex *, complex *, complex *, real *, integer *),
- cchk2_(char *, real *, real *, integer *, integer *, logical *,
- logical *, logical *, integer *, integer *, integer *, complex *,
- integer *, complex *, integer *, complex *, complex *, complex *,
- complex *, complex *, complex *, complex *, complex *, complex *,
- complex *, real *, integer *), cchk3_(char *, real *,
- real *, integer *, integer *, logical *, logical *, logical *,
- integer *, integer *, integer *, complex *, integer *, complex *,
- complex *, complex *, complex *, complex *, complex *, complex *,
- real *, complex *, integer *), cchk4_(char *, real *,
- real *, integer *, integer *, logical *, logical *, logical *,
- integer *, integer *, integer *, complex *, integer *, complex *,
- integer *, complex *, complex *, complex *, complex *, complex *,
- complex *, complex *, complex *, complex *, complex *, real *,
- integer *), cchk5_(char *, real *, real *, integer *,
- integer *, logical *, logical *, logical *, integer *, integer *,
- integer *, complex *, integer *, complex *, integer *, complex *,
- complex *, complex *, complex *, complex *, complex *, complex *,
- complex *, complex *, real *, complex *, integer *);
- complex c__[4225] /* was [65][65] */;
- real g[65];
- integer i__, j, n;
- logical fatal;
- complex w[130];
- extern /* Subroutine */ int cmmch_(char *, char *, integer *, integer *,
- integer *, complex *, complex *, integer *, complex *, integer *,
- complex *, complex *, integer *, complex *, real *, complex *,
- integer *, real *, real *, logical *, integer *, logical *);
- extern real sdiff_(real *, real *);
- logical trace;
- integer nidim;
- char snaps[32];
- integer isnum;
- logical ltest[9];
- complex aa[4225], ab[8450] /* was [65][130] */, bb[4225], cc[4225], as[
- 4225], bs[4225], cs[4225], ct[65];
- logical sfatal, corder;
- char snamet[12], transa[1], transb[1];
- real thresh;
- logical rorder;
- extern /* Subroutine */ int cc3chke_(char *);
- integer layout;
- logical ltestt, tsterr;
- complex alf[7];
- extern logical lce_(complex *, complex *, integer *);
- complex bet[7];
- real eps, err;
- char tmpchar;
-
-/* Test program for the COMPLEX Level 3 Blas. */
-
-/* The program must be driven by a short data file. The first 13 records */
-/* of the file are read using list-directed input, the last 9 records */
-/* are read using the format ( A12, L2 ). An annotated example of a data */
-/* file can be obtained by deleting the first 3 characters from the */
-/* following 22 lines: */
-/* 'CBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE */
-/* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) */
-/* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. */
-/* F LOGICAL FLAG, T TO STOP ON FAILURES. */
-/* T LOGICAL FLAG, T TO TEST ERROR CALL MYEXITS. */
-/* 2 0 TO TEST COLUMN-MAJOR, 1 TO TEST ROW-MAJOR, 2 TO TEST BOTH */
-/* 16.0 THRESHOLD VALUE OF TEST RATIO */
-/* 6 NUMBER OF VALUES OF N */
-/* 0 1 2 3 5 9 VALUES OF N */
-/* 3 NUMBER OF VALUES OF ALPHA */
-/* (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA */
-/* 3 NUMBER OF VALUES OF BETA */
-/* (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA */
-/* cblas_cgemm T PUT F FOR NO TEST. SAME COLUMNS. */
-/* cblas_chemm T PUT F FOR NO TEST. SAME COLUMNS. */
-/* cblas_csymm T PUT F FOR NO TEST. SAME COLUMNS. */
-/* cblas_ctrmm T PUT F FOR NO TEST. SAME COLUMNS. */
-/* cblas_ctrsm T PUT F FOR NO TEST. SAME COLUMNS. */
-/* cblas_cherk T PUT F FOR NO TEST. SAME COLUMNS. */
-/* cblas_csyrk T PUT F FOR NO TEST. SAME COLUMNS. */
-/* cblas_cher2k T PUT F FOR NO TEST. SAME COLUMNS. */
-/* cblas_csyr2k T PUT F FOR NO TEST. SAME COLUMNS. */
-
-/* See: */
-
-/* Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. */
-/* A Set of Level 3 Basic Linear Algebra Subprograms. */
-
-/* Technical Memorandum No.88 (Revision 1), Mathematics and */
-/* Computer Science Division, Argonne National Laboratory, 9700 */
-/* South Cass Avenue, Argonne, Illinois 60439, US. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-
- infoc_1.noutc = 6;
-
-/* Read name and unit number for snapshot output file and open file. */
- char line[80];
-
- fgets(line,80,stdin);
- sscanf(line,"'%s'",snaps);
- fgets(line,80,stdin);
-#ifdef USE64BITINT
- sscanf(line,"%ld",&ntra);
-#else
- sscanf(line,"%d",&ntra);
-#endif
- trace = ntra >= 0;
- if (trace) {
-/* o__1.oerr = 0;
- o__1.ounit = ntra;
- o__1.ofnmlen = 32;
- o__1.ofnm = snaps;
- o__1.orl = 0;
- o__1.osta = 0;
- o__1.oacc = 0;
- o__1.ofm = 0;
- o__1.oblnk = 0;
- f_open(&o__1);*/
- }
-/* Read the flag that directs rewinding of the snapshot file. */
- fgets(line,80,stdin);
- sscanf(line,"%d",&rewi);
- rewi = rewi && trace;
-/* Read the flag that directs stopping on any failure. */
- fgets(line,80,stdin);
- sscanf(line,"%c",&tmpchar);
- sfatal=FALSE_;
- if (tmpchar=='T')sfatal=TRUE_;
- fgets(line,80,stdin);
- sscanf(line,"%c",&tmpchar);
- tsterr=FALSE_;
- if (tmpchar=='T')tsterr=TRUE_;
- fgets(line,80,stdin);
- sscanf(line,"%d",&layout);
- fgets(line,80,stdin);
- sscanf(line,"%f",&thresh);
-
-
-/* Read and check the parameter values for the tests. */
-
-/* Values of N */
- fgets(line,80,stdin);
-#ifdef USE64BITINT
- sscanf(line,"%ld",&nidim);
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
#else
- sscanf(line,"%d",&nidim);
+typedef logical (*L_fp)();
#endif
- if (nidim < 1 || nidim > 9) {
- fprintf(stderr,"NUMBER OF VALUES OF N IS LESS THAN 1 OR GREATER THAN 9");
- goto L220;
- }
- fgets(line,80,stdin);
-#ifdef USE64BITINT
- sscanf(line,"%ld %ld %ld %ld %ld %ld %ld %ld %ld",&idim[0],&idim[1],&idim[2],
- &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]);
-#else
- sscanf(line,"%d %d %d %d %d %d %d %d %d",&idim[0],&idim[1],&idim[2],
- &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]);
-#endif
- i__1 = nidim;
- for (i__ = 1; i__ <= i__1; ++i__) {
- if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) {
- fprintf(stderr,"VALUE OF N IS LESS THAN 0 OR GREATER THAN 65\n");
- goto L220;
- }
-/* L10: */
- }
-/* Values of ALPHA */
- fgets(line,80,stdin);
-#ifdef USE64BITINT
- sscanf(line,"%ld",&nalf);
+static float spow_ui(float x, integer n) {
+ float pow=1.0; unsigned long int u;
+ if(n != 0) {
+ if(n < 0) n = -n, x = 1/x;
+ for(u = n; ; ) {
+ if(u & 01) pow *= x;
+ if(u >>= 1) x *= x;
+ else break;
+ }
+ }
+ return pow;
+}
+static double dpow_ui(double x, integer n) {
+ double pow=1.0; unsigned long int u;
+ if(n != 0) {
+ if(n < 0) n = -n, x = 1/x;
+ for(u = n; ; ) {
+ if(u & 01) pow *= x;
+ if(u >>= 1) x *= x;
+ else break;
+ }
+ }
+ return pow;
+}
+#ifdef _MSC_VER
+static _Fcomplex cpow_ui(complex x, integer n) {
+ complex pow={1.0,0.0}; unsigned long int u;
+ if(n != 0) {
+ if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i;
+ for(u = n; ; ) {
+ if(u & 01) pow.r *= x.r, pow.i *= x.i;
+ if(u >>= 1) x.r *= x.r, x.i *= x.i;
+ else break;
+ }
+ }
+ _Fcomplex p={pow.r, pow.i};
+ return p;
+}
#else
- sscanf(line,"%d",&nalf);
+static _Complex float cpow_ui(_Complex float x, integer n) {
+ _Complex float pow=1.0; unsigned long int u;
+ if(n != 0) {
+ if(n < 0) n = -n, x = 1/x;
+ for(u = n; ; ) {
+ if(u & 01) pow *= x;
+ if(u >>= 1) x *= x;
+ else break;
+ }
+ }
+ return pow;
+}
#endif
- if (nalf < 1 || nalf > 7) {
- fprintf(stderr,"VALUE OF ALPHA IS LESS THAN 0 OR GREATER THAN 7\n");
- goto L220;
- }
- fgets(line,80,stdin);
- sscanf(line,"(%f,%f) (%f,%f) (%f,%f) (%f,%f) (%f,%f) (%f,%f) (%f,%f)",&alf[0].r,&alf[0].i,&alf[1].r,&alf[1].i,&alf[2].r,&alf[2].i,&alf[3].r,&alf[3].i,
- &alf[4].r,&alf[4].i,&alf[5].r,&alf[5].i,&alf[6].r,&alf[6].i);
-
-// i__1 = nalf;
-// for (i__ = 1; i__ <= i__1; ++i__) {
-// do_lio(&c__6, &c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(complex));
-// }
-/* Values of BETA */
- fgets(line,80,stdin);
-#ifdef USE64BITINT
- sscanf(line,"%ld",&nbet);
+#ifdef _MSC_VER
+static _Dcomplex zpow_ui(_Dcomplex x, integer n) {
+ _Dcomplex pow={1.0,0.0}; unsigned long int u;
+ if(n != 0) {
+ if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1];
+ for(u = n; ; ) {
+ if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1];
+ if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1];
+ else break;
+ }
+ }
+ _Dcomplex p = {pow._Val[0], pow._Val[1]};
+ return p;
+}
#else
- sscanf(line,"%d",&nbet);
+static _Complex double zpow_ui(_Complex double x, integer n) {
+ _Complex double pow=1.0; unsigned long int u;
+ if(n != 0) {
+ if(n < 0) n = -n, x = 1/x;
+ for(u = n; ; ) {
+ if(u & 01) pow *= x;
+ if(u >>= 1) x *= x;
+ else break;
+ }
+ }
+ return pow;
+}
#endif
- if (nalf < 1 || nbet > 7) {
- fprintf(stderr,"VALUE OF BETA IS LESS THAN 0 OR GREATER THAN 7\n");
- goto L220;
- }
- fgets(line,80,stdin);
- sscanf(line,"(%f,%f) (%f,%f) (%f,%f) (%f,%f) (%f,%f) (%f,%f) (%f,%f)",&bet[0].r,&bet[0].i,&bet[1].r,&bet[1].i,&bet[2].r,&bet[2].i,&bet[3].r,&bet[3].i,
- &bet[4].r,&bet[4].i,&bet[5].r,&bet[5].i,&bet[6].r,&bet[6].i);
-
-
-/* Report values of parameters. */
-
- printf("TESTS OF THE COMPLEX LEVEL 3 BLAS\nTHE FOLLOWING PARAMETER VALUES WILL BE USED:\n");
- printf(" FOR N");
- for (i__ =1; i__ <=nidim;++i__) printf(" %d",idim[i__-1]);
- printf("\n");
- printf(" FOR ALPHA");
- for (i__ =1; i__ <=nalf;++i__) printf(" (%f,%f)",alf[i__-1].r,alf[i__-1].i);
- printf("\n");
- printf(" FOR BETA");
- for (i__ =1; i__ <=nbet;++i__) printf(" (%f,%f)",bet[i__-1].r,bet[i__-1].i);
- printf("\n");
-
- if (! tsterr) {
- printf(" ERROR-EXITS WILL NOT BE TESTED\n");
- }
- printf("ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LESS THAN %f\n",thresh);
- rorder = FALSE_;
- corder = FALSE_;
- if (layout == 2) {
- rorder = TRUE_;
- corder = TRUE_;
- printf("COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED\n");
- } else if (layout == 1) {
- rorder = TRUE_;
- printf("ROW-MAJOR DATA LAYOUT IS TESTED\n");
- } else if (layout == 0) {
- corder = TRUE_;
- printf("COLUMN-MAJOR DATA LAYOUT IS TESTED\n");
- }
-
-/* Read names of subroutines and flags which indicate */
-/* whether they are to be tested. */
-
- for (i__ = 1; i__ <= 9; ++i__) {
- ltest[i__ - 1] = FALSE_;
-/* L20: */
- }
-L30:
- if (! fgets(line,80,stdin)) {
- goto L60;
- }
- i__1 = sscanf(line,"%12c %c",snamet,&tmpchar);
- ltestt=FALSE_;
- if (tmpchar=='T')ltestt=TRUE_;
- if (i__1 < 2) {
- goto L60;
- }
- for (i__ = 1; i__ <= 9; ++i__) {
- if (s_cmp(snamet, snames[i__ - 1] , (ftnlen)12, (ftnlen)12) ==
- 0) {
- goto L50;
- }
-/* L40: */
- }
- printf("SUBPROGRAM NAME %s NOT RECOGNIZED\n****** TESTS ABANDONED ******\n",snamet);
- exit(1);
-L50:
- ltest[i__ - 1] = ltestt;
- goto L30;
-
-L60:
-/* cl__1.cerr = 0;
- cl__1.cunit = 5;
- cl__1.csta = 0;
- f_clos(&cl__1);*/
-
-/* Compute EPS (the machine precision). */
-
- eps = 1.f;
-L70:
- r__1 = eps + 1.f;
- if (sdiff_(&r__1, &c_b91) == 0.f) {
- goto L80;
- }
- eps *= .5f;
- goto L70;
-L80:
- eps += eps;
- printf("RELATIVE MACHINE PRECISION IS TAKEN TO BE %9.1g\n",eps);
-
-/* Check the reliability of CMMCH using exact data. */
-
- n = 32;
- i__1 = n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = n;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * 65 - 66;
-/* Computing MAX */
- i__5 = i__ - j + 1;
- i__4 = f2cmax(i__5,0);
- ab[i__3].r = (real) i__4, ab[i__3].i = 0.f;
-/* L90: */
- }
- i__2 = j + 4224;
- ab[i__2].r = (real) j, ab[i__2].i = 0.f;
- i__2 = (j + 65) * 65 - 65;
- ab[i__2].r = (real) j, ab[i__2].i = 0.f;
- i__2 = j - 1;
- c__[i__2].r = 0.f, c__[i__2].i = 0.f;
-/* L100: */
- }
- i__1 = n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j - 1;
- i__3 = j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3;
- cc[i__2].r = (real) i__3, cc[i__2].i = 0.f;
-/* L110: */
- }
-/* CC holds the exact result. On exit from CMMCH CT holds */
-/* the result computed by CMMCH. */
- *(unsigned char *)transa = 'N';
- *(unsigned char *)transb = 'N';
- cmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], &
- c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal,
- &c__6, &c_true);
- same = lce_(cc, ct, &n);
- if (! same || err != 0.f) {
- printf("ERROR IN CMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n");
- printf("CMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb);
- printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err);
- printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n");
- printf("****** TESTS ABANDONED ******\n");
- exit(1);
- }
- *(unsigned char *)transb = 'C';
- cmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], &
- c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal,
- &c__6, &c_true);
- same = lce_(cc, ct, &n);
- if (! same || err != 0.f) {
- printf("ERROR IN CMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n");
- printf("CMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb);
- printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err);
- printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n");
- printf("****** TESTS ABANDONED ******\n");
- exit(1);
- }
- i__1 = n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j + 4224;
- i__3 = n - j + 1;
- ab[i__2].r = (real) i__3, ab[i__2].i = 0.f;
- i__2 = (j + 65) * 65 - 65;
- i__3 = n - j + 1;
- ab[i__2].r = (real) i__3, ab[i__2].i = 0.f;
-/* L120: */
- }
- i__1 = n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = n - j;
- i__3 = j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3;
- cc[i__2].r = (real) i__3, cc[i__2].i = 0.f;
-/* L130: */
- }
- *(unsigned char *)transa = 'C';
- *(unsigned char *)transb = 'N';
- cmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], &
- c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal,
- &c__6, &c_true);
- same = lce_(cc, ct, &n);
- if (! same || err != 0.f) {
- printf("ERROR IN CMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n");
- printf("CMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb);
- printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err);
- printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n");
- printf("****** TESTS ABANDONED ******\n");
- exit(1);
- }
- *(unsigned char *)transb = 'C';
- cmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], &
- c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal,
- &c__6, &c_true);
- same = lce_(cc, ct, &n);
- if (! same || err != 0.f) {
- printf("ERROR IN CMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n");
- printf("CMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb);
- printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err);
- printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n");
- printf("****** TESTS ABANDONED ******\n");
- exit(1);
- }
-
-/* Test each subroutine in turn. */
-
- for (isnum = 1; isnum <= 9; ++isnum) {
- if (! ltest[isnum - 1]) {
-/* Subprogram is not to be tested. */
- printf("%12s WAS NOT TESTED\n",snames[isnum-1]);
- } else {
- s_copy(srnamc_1.srnamt, snames[isnum - 1], (ftnlen)12, (
- ftnlen)12);
-/* Test error exits. */
- if (tsterr) {
- cc3chke_(snames[isnum - 1]);
- }
-/* Test computations. */
- infoc_1.infot = 0;
- infoc_1.ok = TRUE_;
- fatal = FALSE_;
- switch (isnum) {
- case 1: goto L140;
- case 2: goto L150;
- case 3: goto L150;
- case 4: goto L160;
- case 5: goto L160;
- case 6: goto L170;
- case 7: goto L170;
- case 8: goto L180;
- case 9: goto L180;
- }
-/* Test CGEMM, 01. */
-L140:
- if (corder) {
- cchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,
- cc, cs, ct, g, &c__0);
- }
- if (rorder) {
- cchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,
- cc, cs, ct, g, &c__1);
- }
- goto L190;
-/* Test CHEMM, 02, CSYMM, 03. */
-L150:
- if (corder) {
- cchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,
- cc, cs, ct, g, &c__0);
- }
- if (rorder) {
- cchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,
- cc, cs, ct, g, &c__1);
- }
- goto L190;
-/* Test CTRMM, 04, CTRSM, 05. */
-L160:
- if (corder) {
- cchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, &
- c__0);
- }
- if (rorder) {
- cchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, &
- c__1);
- }
- goto L190;
-/* Test CHERK, 06, CSYRK, 07. */
-L170:
- if (corder) {
- cchk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,
- cc, cs, ct, g, &c__0);
- }
- if (rorder) {
- cchk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,
- cc, cs, ct, g, &c__1);
- }
- goto L190;
-/* Test CHER2K, 08, CSYR2K, 09. */
-L180:
- if (corder) {
- cchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs,
- ct, g, w, &c__0);
- }
- if (rorder) {
- cchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs,
- ct, g, w, &c__1);
- }
- goto L190;
-
-L190:
- if (fatal && sfatal) {
- goto L210;
- }
- }
-/* L200: */
- }
- printf("\nEND OF TESTS\n");
- goto L230;
-
-L210:
- printf("\n****** FATAL ERROR - TESTS ABANDONED ******\n");
- goto L230;
-
-L220:
- printf("AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM\n");
- printf("****** TESTS ABANDONED ******\n");
-L230:
- if (trace) {
-/* cl__1.cerr = 0;
- cl__1.cunit = ntra;
- cl__1.csta = 0;
- f_clos(&cl__1);*/
- }
-/* cl__1.cerr = 0;
- cl__1.cunit = 6;
- cl__1.csta = 0;
- f_clos(&cl__1);
- s_stop("", (ftnlen)0);*/
- exit(0);
-
-/* End of CBLAT3. */
-
- return 0;
-} /* MAIN__ */
-
-/* Subroutine */ int cchk1_(char *sname, real *eps, real *thresh, integer *
- nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
- integer *nidim, integer *idim, integer *nalf, complex *alf, integer *
- nbet, complex *bet, integer *nmax, complex *a, complex *aa, complex *
- as, complex *b, complex *bb, complex *bs, complex *c__, complex *cc,
- complex *cs, complex *ct, real *g, integer *iorder)
-{
- /* Initialized data */
-
- static char ich[3] = "NTC";
-
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
- i__3, i__4, i__5, i__6, i__7, i__8;
-
- /* Local variables */
- complex beta;
- integer ldas, ldbs, ldcs;
- logical same, null;
- integer i__, k, m, n;
- extern /* Subroutine */ int cmake_(char *, char *, char *, integer *,
- integer *, complex *, integer *, complex *, integer *, logical *,
- complex *);
- complex alpha;
- extern /* Subroutine */ int cmmch_(char *, char *, integer *, integer *,
- integer *, complex *, complex *, integer *, complex *, integer *,
- complex *, complex *, integer *, complex *, real *, complex *,
- integer *, real *, real *, logical *, integer *, logical *);
- logical isame[13], trana, tranb;
- integer nargs;
- logical reset;
- extern /* Subroutine */ int cprcn1_(integer *, integer *, char *, integer
- *, char *, char *, integer *, integer *, integer *, complex *,
- integer *, integer *, complex *, integer *);
- integer ia, ib, ma, mb, na, nb, nc, ik, im, in;
- extern /* Subroutine */ int ccgemm_(integer *, char *, char *, integer *,
- integer *, integer *, complex *, complex *, integer *, complex *,
- integer *, complex *, complex *, integer *);
- integer ks, ms, ns;
- extern logical lceres_(char *, char *, integer *, integer *, complex *,
- complex *, integer *);
- char tranas[1], tranbs[1], transa[1], transb[1];
- real errmax;
- integer ica, icb, laa, lbb, lda, lcc, ldb, ldc;
- extern logical lce_(complex *, complex *, integer *);
- complex als, bls;
- real err;
-
-/* Tests CGEMM. */
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
- /* Parameter adjustments */
- --idim;
- --alf;
- --bet;
- --g;
- --ct;
- --cs;
- --cc;
- c_dim1 = *nmax;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
- --bs;
- --bb;
- b_dim1 = *nmax;
- b_offset = 1 + b_dim1 * 1;
- b -= b_offset;
- --as;
- --aa;
- a_dim1 = *nmax;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
-
- /* Function Body */
-
- nargs = 13;
- nc = 0;
- reset = TRUE_;
- errmax = 0.f;
-
- i__1 = *nidim;
- for (im = 1; im <= i__1; ++im) {
- m = idim[im];
-
- i__2 = *nidim;
- for (in = 1; in <= i__2; ++in) {
- n = idim[in];
-/* Set LDC to 1 more than minimum value if room. */
- ldc = m;
- if (ldc < *nmax) {
- ++ldc;
- }
-/* Skip tests if not enough room. */
- if (ldc > *nmax) {
- goto L100;
- }
- lcc = ldc * n;
- null = n <= 0 || m <= 0;
-
- i__3 = *nidim;
- for (ik = 1; ik <= i__3; ++ik) {
- k = idim[ik];
-
- for (ica = 1; ica <= 3; ++ica) {
- *(unsigned char *)transa = *(unsigned char *)&ich[ica - 1]
- ;
- trana = *(unsigned char *)transa == 'T' || *(unsigned
- char *)transa == 'C';
-
- if (trana) {
- ma = k;
- na = m;
- } else {
- ma = m;
- na = k;
- }
-/* Set LDA to 1 more than minimum value if room. */
- lda = ma;
- if (lda < *nmax) {
- ++lda;
- }
-/* Skip tests if not enough room. */
- if (lda > *nmax) {
- goto L80;
- }
- laa = lda * na;
-
-/* Generate the matrix A. */
-
- cmake_("ge", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[
- 1], &lda, &reset, &c_b1);
-
- for (icb = 1; icb <= 3; ++icb) {
- *(unsigned char *)transb = *(unsigned char *)&ich[icb
- - 1];
- tranb = *(unsigned char *)transb == 'T' || *(unsigned
- char *)transb == 'C';
-
- if (tranb) {
- mb = n;
- nb = k;
- } else {
- mb = k;
- nb = n;
- }
-/* Set LDB to 1 more than minimum value if room. */
- ldb = mb;
- if (ldb < *nmax) {
- ++ldb;
- }
-/* Skip tests if not enough room. */
- if (ldb > *nmax) {
- goto L70;
- }
- lbb = ldb * nb;
-
-/* Generate the matrix B. */
-
- cmake_("ge", " ", " ", &mb, &nb, &b[b_offset], nmax, &
- bb[1], &ldb, &reset, &c_b1);
-
- i__4 = *nalf;
- for (ia = 1; ia <= i__4; ++ia) {
- i__5 = ia;
- alpha.r = alf[i__5].r, alpha.i = alf[i__5].i;
-
- i__5 = *nbet;
- for (ib = 1; ib <= i__5; ++ib) {
- i__6 = ib;
- beta.r = bet[i__6].r, beta.i = bet[i__6].i;
-
-/* Generate the matrix C. */
-
- cmake_("ge", " ", " ", &m, &n, &c__[c_offset],
- nmax, &cc[1], &ldc, &reset, &c_b1);
-
- ++nc;
-
-/* Save every datum before calling the */
-/* subroutine. */
-
- *(unsigned char *)tranas = *(unsigned char *)
- transa;
- *(unsigned char *)tranbs = *(unsigned char *)
- transb;
- ms = m;
- ns = n;
- ks = k;
- als.r = alpha.r, als.i = alpha.i;
- i__6 = laa;
- for (i__ = 1; i__ <= i__6; ++i__) {
- i__7 = i__;
- i__8 = i__;
- as[i__7].r = aa[i__8].r, as[i__7].i = aa[
- i__8].i;
-/* L10: */
- }
- ldas = lda;
- i__6 = lbb;
- for (i__ = 1; i__ <= i__6; ++i__) {
- i__7 = i__;
- i__8 = i__;
- bs[i__7].r = bb[i__8].r, bs[i__7].i = bb[
- i__8].i;
-/* L20: */
- }
- ldbs = ldb;
- bls.r = beta.r, bls.i = beta.i;
- i__6 = lcc;
- for (i__ = 1; i__ <= i__6; ++i__) {
- i__7 = i__;
- i__8 = i__;
- cs[i__7].r = cc[i__8].r, cs[i__7].i = cc[
- i__8].i;
-/* L30: */
- }
- ldcs = ldc;
-
-/* Call the subroutine. */
-
- if (*trace) {
- cprcn1_(ntra, &nc, sname, iorder, transa,
- transb, &m, &n, &k, &alpha, &lda,
- &ldb, &beta, &ldc);
- }
- if (*rewi) {
-/* al__1.aerr = 0;
- al__1.aunit = *ntra;
- f_rew(&al__1); */
- }
- ccgemm_(iorder, transa, transb, &m, &n, &k, &
- alpha, &aa[1], &lda, &bb[1], &ldb, &
- beta, &cc[1], &ldc);
-
-/* Check if error-exit was taken incorrectly. */
-
- if (! infoc_1.ok) {
-// io___128.ciunit = *nout;
-// s_wsfe(&io___128);
-// e_wsfe();
- printf(" *** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");
- *fatal = TRUE_;
- goto L120;
- }
-
-/* See what data changed inside subroutines. */
-
- isame[0] = *(unsigned char *)transa == *(
- unsigned char *)tranas;
- isame[1] = *(unsigned char *)transb == *(
- unsigned char *)tranbs;
- isame[2] = ms == m;
- isame[3] = ns == n;
- isame[4] = ks == k;
- isame[5] = als.r == alpha.r && als.i ==
- alpha.i;
- isame[6] = lce_(&as[1], &aa[1], &laa);
- isame[7] = ldas == lda;
- isame[8] = lce_(&bs[1], &bb[1], &lbb);
- isame[9] = ldbs == ldb;
- isame[10] = bls.r == beta.r && bls.i ==
- beta.i;
- if (null) {
- isame[11] = lce_(&cs[1], &cc[1], &lcc);
- } else {
- isame[11] = lceres_("ge", " ", &m, &n, &
- cs[1], &cc[1], &ldc);
- }
- isame[12] = ldcs == ldc;
-
-/* If data was incorrectly changed, report */
-/* and return. */
-
- same = TRUE_;
- i__6 = nargs;
- for (i__ = 1; i__ <= i__6; ++i__) {
- same = same && isame[i__ - 1];
- if (! isame[i__ - 1]) {
- printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);;
- }
-/* L40: */
- }
- if (! same) {
- *fatal = TRUE_;
- goto L120;
- }
-
- if (! null) {
-
-/* Check the result. */
-
- cmmch_(transa, transb, &m, &n, &k, &alpha,
- &a[a_offset], nmax, &b[b_offset],
- nmax, &beta, &c__[c_offset],
- nmax, &ct[1], &g[1], &cc[1], &ldc,
- eps, &err, fatal, nout, &c_true);
- errmax = f2cmax(errmax,err);
-/* If got really bad answer, report and */
-/* return. */
- if (*fatal) {
- goto L120;
- }
- }
-
-/* L50: */
- }
-
-/* L60: */
- }
-
-L70:
- ;
- }
-
-L80:
- ;
- }
-
-/* L90: */
- }
-
-L100:
- ;
- }
-
-/* L110: */
- }
-
-/* Report result. */
-
- if (errmax < *thresh) {
- if (*iorder == 0) {
- printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
- }
- if (*iorder == 1) {
- printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
- }
- } else {
- if (*iorder == 0) {
- printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);
- printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);
- }
- if (*iorder == 1) {
- printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);
- printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);
- }
- }
- goto L130;
-
-L120:
- printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
- cprcn1_(nout, &nc, sname, iorder, transa, transb, &m, &n, &k, &alpha, &
- lda, &ldb, &beta, &ldc);
-
-L130:
- return 0;
-
-/* 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',', */
-/* $ 3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, */
-/* $ ',(', F4.1, ',', F4.1, '), C,', I3, ').' ) */
-
-/* End of CCHK1. */
-
-} /* cchk1_ */
-
-
-/* Subroutine */ int cprcn1_(integer *nout, integer *nc, char *sname, integer
- *iorder, char *transa, char *transb, integer *m, integer *n, integer *
- k, complex *alpha, integer *lda, integer *ldb, complex *beta, integer
- *ldc)
+static integer pow_ii(integer x, integer n) {
+ integer pow; unsigned long int u;
+ if (n <= 0) {
+ if (n == 0 || x == 1) pow = 1;
+ else if (x != -1) pow = x == 0 ? 1/x : 0;
+ else n = -n;
+ }
+ if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+ u = n;
+ for(pow = 1; ; ) {
+ if(u & 01) pow *= x;
+ if(u >>= 1) x *= x;
+ else break;
+ }
+ }
+ return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
{
- /* Local variables */
- char crc[14], cta[14], ctb[14];
-
- if (*(unsigned char *)transa == 'N') {
- s_copy(cta, " CblasNoTrans", (ftnlen)14, (ftnlen)14);
- } else if (*(unsigned char *)transa == 'T') {
- s_copy(cta, " CblasTrans", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(cta, "CblasConjTrans", (ftnlen)14, (ftnlen)14);
- }
- if (*(unsigned char *)transb == 'N') {
- s_copy(ctb, " CblasNoTrans", (ftnlen)14, (ftnlen)14);
- } else if (*(unsigned char *)transb == 'T') {
- s_copy(ctb, " CblasTrans", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(ctb, "CblasConjTrans", (ftnlen)14, (ftnlen)14);
- }
- if (*iorder == 1) {
- s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
- }
- printf("%6d: %s %s %s %s\n",*nc,sname,crc,cta,ctb);
- printf("%d %d %d (%4.1f,%4.1f) , A, %d, B, %d, (%4.1f,%4.1f) , C, %d.\n",*m,*n,*k,alpha->r,alpha->i,*lda,*ldb,beta->r,beta->i,*ldc);
- return 0;
-} /* cprcn1_ */
-
-
-/* Subroutine */ int cchk2_(char *sname, real *eps, real *thresh, integer *
- nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
- integer *nidim, integer *idim, integer *nalf, complex *alf, integer *
- nbet, complex *bet, integer *nmax, complex *a, complex *aa, complex *
- as, complex *b, complex *bb, complex *bs, complex *c__, complex *cc,
- complex *cs, complex *ct, real *g, integer *iorder)
+ double m; integer i, mi;
+ for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+ if (w[i-1]>m) mi=i ,m=w[i-1];
+ return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
{
- /* Initialized data */
-
- static char ichs[2] = "LR";
- static char ichu[2] = "UL";
-
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
- i__3, i__4, i__5, i__6, i__7;
-
- /* Local variables */
- complex beta;
- integer ldas, ldbs, ldcs;
- logical same;
- char side[1];
- logical conj, left, null;
- char uplo[1];
- integer i__, m, n;
- extern /* Subroutine */ int cmake_(char *, char *, char *, integer *,
- integer *, complex *, integer *, complex *, integer *, logical *,
- complex *);
- complex alpha;
- extern /* Subroutine */ int cmmch_(char *, char *, integer *, integer *,
- integer *, complex *, complex *, integer *, complex *, integer *,
- complex *, complex *, integer *, complex *, real *, complex *,
- integer *, real *, real *, logical *, integer *, logical *);
- logical isame[13];
- char sides[1];
- integer nargs;
- logical reset;
- char uplos[1];
- extern /* Subroutine */ int cprcn2_(integer *, integer *, char *, integer
- *, char *, char *, integer *, integer *, complex *, integer *,
- integer *, complex *, integer *);
- integer ia, ib, na, nc, im, in;
- extern /* Subroutine */ int cchemm_(integer *, char *, char *, integer *,
- integer *, complex *, complex *, integer *, complex *, integer *,
- complex *, complex *, integer *);
- integer ms, ns;
- extern logical lceres_(char *, char *, integer *, integer *, complex *,
- complex *, integer *);
- extern /* Subroutine */ int ccsymm_(integer *, char *, char *, integer *,
- integer *, complex *, complex *, integer *, complex *, integer *,
- complex *, complex *, integer *);
- real errmax;
- integer laa, lbb, lda, lcc, ldb, ldc;
- extern logical lce_(complex *, complex *, integer *);
- integer ics;
- complex als, bls;
- integer icu;
- real err;
-
-/* Tests CHEMM and CSYMM. */
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
- /* Parameter adjustments */
- --idim;
- --alf;
- --bet;
- --g;
- --ct;
- --cs;
- --cc;
- c_dim1 = *nmax;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
- --bs;
- --bb;
- b_dim1 = *nmax;
- b_offset = 1 + b_dim1 * 1;
- b -= b_offset;
- --as;
- --aa;
- a_dim1 = *nmax;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
-
- /* Function Body */
- conj = s_cmp(sname + 7, "he", (ftnlen)2, (ftnlen)2) == 0;
-
- nargs = 12;
- nc = 0;
- reset = TRUE_;
- errmax = 0.f;
-
- i__1 = *nidim;
- for (im = 1; im <= i__1; ++im) {
- m = idim[im];
-
- i__2 = *nidim;
- for (in = 1; in <= i__2; ++in) {
- n = idim[in];
-/* Set LDC to 1 more than minimum value if room. */
- ldc = m;
- if (ldc < *nmax) {
- ++ldc;
- }
-/* Skip tests if not enough room. */
- if (ldc > *nmax) {
- goto L90;
- }
- lcc = ldc * n;
- null = n <= 0 || m <= 0;
-/* Set LDB to 1 more than minimum value if room. */
- ldb = m;
- if (ldb < *nmax) {
- ++ldb;
- }
-/* Skip tests if not enough room. */
- if (ldb > *nmax) {
- goto L90;
- }
- lbb = ldb * n;
-
-/* Generate the matrix B. */
-
- cmake_("ge", " ", " ", &m, &n, &b[b_offset], nmax, &bb[1], &ldb, &
- reset, &c_b1);
-
- for (ics = 1; ics <= 2; ++ics) {
- *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1];
- left = *(unsigned char *)side == 'L';
-
- if (left) {
- na = m;
- } else {
- na = n;
- }
-/* Set LDA to 1 more than minimum value if room. */
- lda = na;
- if (lda < *nmax) {
- ++lda;
- }
-/* Skip tests if not enough room. */
- if (lda > *nmax) {
- goto L80;
+ float m; integer i, mi;
+ for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+ if (w[i-1]>m) mi=i ,m=w[i-1];
+ return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+ integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+ _Fcomplex zdotc = {0.0, 0.0};
+ if (incx == 1 && incy == 1) {
+ for (i=0;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];
}
- 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: */
+ } 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];
}
-
-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;
+ 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]);
}
- 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: */
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
}
-
-/* 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;
+ 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];
}
- 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: */
+ } 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];
}
-
-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: */
+ 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]);
}
-
-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;
- }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
}
- }
-/* 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;
+ 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 {
- if (unit) {
- ibeg = j + 1;
- } else {
- ibeg = j;
+ } 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];
}
- 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: */
- }
+ 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 {
- 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: */
- }
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
}
- }
- }
- 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);
+ 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 {
- 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;
+ 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];
}
-/* 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;
+ 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]);
}
-/* 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;
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
}
-/* 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;
+ pCd(z) = zdotc;
+}
+#endif
+/* -- translated by f2c (version 20000121).
+ You must link the resulting object file with the libraries:
+ -lf2c -lm (in that order)
+*/
-/* End of SDIFF. */
-} /* sdiff_ */
-/* Main program alias */ /*int cblat3_ () { MAIN__ (); return 0; }*/
diff --git a/ctest/c_dblat3c.c b/ctest/c_dblat3c.c
index dc3d6f9e7f..447b23014f 100644
--- a/ctest/c_dblat3c.c
+++ b/ctest/c_dblat3c.c
@@ -10,7 +10,25 @@
#undef I
#endif
-#include "common.h"
+#if defined(_WIN64)
+typedef long long BLASLONG;
+typedef unsigned long long BLASULONG;
+#else
+typedef long BLASLONG;
+typedef unsigned long BLASULONG;
+#endif
+
+#ifdef LAPACK_ILP64
+typedef BLASLONG blasint;
+#if defined(_WIN64)
+#define blasabs(x) llabs(x)
+#else
+#define blasabs(x) labs(x)
+#endif
+#else
+typedef int blasint;
+#define blasabs(x) abs(x)
+#endif
typedef blasint integer;
@@ -229,6 +247,7 @@ typedef struct Namelist Namelist;
#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
#define sig_die(s, kill) { exit(1); }
#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
#define z_abs(z) (cabs(Cd(z)))
#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
@@ -242,3098 +261,251 @@ typedef struct Namelist Namelist;
/* procedure parameter types for -A and -C++ */
#define F2C_proc_par_types 1
-
-
-/* Common Block Declarations */
-
-struct {
- integer infot, noutc;
- logical ok;
-} infoc_;
-
-#define infoc_1 infoc_
-
-struct {
- char srnamt[12];
-} srnamc_;
-
-#define srnamc_1 srnamc_
-
-/* Table of constant values */
-
-static integer c__1 = 1;
-static integer c__65 = 65;
-static doublereal c_b90 = 1.;
-static doublereal c_b104 = 0.;
-static integer c__6 = 6;
-static logical c_true = TRUE_;
-static integer c__0 = 0;
-static logical c_false = FALSE_;
-
-/* Main program MAIN__() */ int main(void)
-{
- /* Initialized data */
-
- static char snames[6][13] = {"cblas_dgemm ", "cblas_dsymm ", "cblas_dtrmm ", "cblas_dtrsm ", "cblas_dsyrk ", "cblas_dsyr2k"};
-
- /* System generated locals */
- integer i__1, i__2, i__3;
- doublereal d__1;
-
-
- /* Local variables */
- static integer nalf, idim[9];
- static logical same;
- static integer nbet, ntra;
- static logical rewi;
- extern /* Subroutine */ int dchk1_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, integer*, ftnlen);
- extern /* Subroutine */ int dchk2_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, integer*, ftnlen);
- extern /* Subroutine */ int dchk3_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, integer*, ftnlen);
- extern /* Subroutine */ int dchk4_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, integer*, ftnlen);
-/* Subroutine */ int dchk5_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublereal* alf, integer* nbet, doublereal* bet, integer* nmax, doublereal* ab, doublereal* aa, doublereal* as, doublereal* bb, doublereal* bs, doublereal* c__, doublereal* cc, doublereal* cs, doublereal* ct, doublereal* g, doublereal* w, integer* iorder, ftnlen sname_len);
- static doublereal c__[4225] /* was [65][65] */, g[65];
- static integer i__, j;
- extern doublereal ddiff_(doublereal*, doublereal*);
- static integer n;
- static logical fatal;
- static doublereal w[130];
- extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen);
- static logical trace;
- static integer nidim;
- static char snaps[32];
- static integer isnum;
- static logical ltest[6];
- static doublereal aa[4225], ab[8450] /* was [65][130] */, bb[4225],
- cc[4225], as[4225], bs[4225], cs[4225], ct[65];
- static logical sfatal, corder;
- static char snamet[12], transa[1], transb[1];
- static doublereal thresh;
- static logical rorder;
- extern /* Subroutine */ void cd3chke_(char*, ftnlen);
- static integer layout;
- static logical ltestt, tsterr;
- static doublereal alf[7];
- extern logical lde_(doublereal*, doublereal*, integer*);
- static doublereal bet[7], eps, err;
- char tmpchar;
-
-/* Test program for the DOUBLE PRECISION Level 3 Blas. */
-
-/* The program must be driven by a short data file. The first 13 records */
-/* of the file are read using list-directed input, the last 6 records */
-/* are read using the format ( A12, L2 ). An annotated example of a data */
-/* file can be obtained by deleting the first 3 characters from the */
-/* following 19 lines: */
-/* 'DBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE */
-/* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) */
-/* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. */
-/* F LOGICAL FLAG, T TO STOP ON FAILURES. */
-/* T LOGICAL FLAG, T TO TEST ERROR EXITS. */
-/* 2 0 TO TEST COLUMN-MAJOR, 1 TO TEST ROW-MAJOR, 2 TO TEST BOTH */
-/* 16.0 THRESHOLD VALUE OF TEST RATIO */
-/* 6 NUMBER OF VALUES OF N */
-/* 0 1 2 3 5 9 VALUES OF N */
-/* 3 NUMBER OF VALUES OF ALPHA */
-/* 0.0 1.0 0.7 VALUES OF ALPHA */
-/* 3 NUMBER OF VALUES OF BETA */
-/* 0.0 1.0 1.3 VALUES OF BETA */
-/* cblas_dgemm T PUT F FOR NO TEST. SAME COLUMNS. */
-/* cblas_dsymm T PUT F FOR NO TEST. SAME COLUMNS. */
-/* cblas_dtrmm T PUT F FOR NO TEST. SAME COLUMNS. */
-/* cblas_dtrsm T PUT F FOR NO TEST. SAME COLUMNS. */
-/* cblas_dsyrk T PUT F FOR NO TEST. SAME COLUMNS. */
-/* cblas_dsyr2k T PUT F FOR NO TEST. SAME COLUMNS. */
-
-/* See: */
-
-/* Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. */
-/* A Set of Level 3 Basic Linear Algebra Subprograms. */
-
-/* Technical Memorandum No.88 (Revision 1), Mathematics and */
-/* Computer Science Division, Argonne National Laboratory, 9700 */
-/* South Cass Avenue, Argonne, Illinois 60439, US. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. Local Arrays .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Scalars in Common .. */
-/* .. Common blocks .. */
-/* .. Data statements .. */
-/* .. Executable Statements .. */
-
-/* Read name and unit number for summary output file and open file. */
-
- infoc_1.noutc = 6;
-/* Read name and unit number for snapshot output file and open file. */
-
- char line[80];
-
- fgets(line,80,stdin);
- sscanf(line,"'%s'",snaps);
- fgets(line,80,stdin);
-#ifdef USE64BITINT
- sscanf(line,"%ld",&ntra);
-#else
- sscanf(line,"%d",&ntra);
-#endif
- trace = ntra >= 0;
- if (trace) {
-/* o__1.oerr = 0;
- o__1.ounit = ntra;
- o__1.ofnmlen = 32;
- o__1.ofnm = snaps;
- o__1.orl = 0;
- o__1.osta = "NEW";
- o__1.oacc = 0;
- o__1.ofm = 0;
- o__1.oblnk = 0;
- f_open(&o__1);*/
- }
-/* Read the flag that directs rewinding of the snapshot file. */
- fgets(line,80,stdin);
- sscanf(line,"%d",&rewi);
- rewi = rewi && trace;
-/* Read the flag that directs stopping on any failure. */
- fgets(line,80,stdin);
- sscanf(line,"%c",&tmpchar);
-/* Read the flag that indicates whether error exits are to be tested. */
- sfatal=FALSE_;
- if (tmpchar=='T')sfatal=TRUE_;
- fgets(line,80,stdin);
- sscanf(line,"%c",&tmpchar);
-/* Read the flag that indicates whether error exits are to be tested. */
- tsterr=FALSE_;
- if (tmpchar=='T')tsterr=TRUE_;
-/* Read the flag that indicates whether row-major data layout to be tested. */
- fgets(line,80,stdin);
- sscanf(line,"%d",&layout);
-/* Read the threshold value of the test ratio */
- fgets(line,80,stdin);
- sscanf(line,"%lf",&thresh);
-/* Read and check the parameter values for the tests. */
-
-/* Values of N */
- fgets(line,80,stdin);
-#ifdef USE64BITINT
- sscanf(line,"%ld",&nidim);
-#else
- sscanf(line,"%d",&nidim);
-#endif
-
- if (nidim < 1 || nidim > 9) {
- fprintf(stderr,"NUMBER OF VALUES OF N IS LESS THAN 1 OR GREATER THAN 9");
- goto L220;
- }
- fgets(line,80,stdin);
-#ifdef USE64BITINT
- sscanf(line,"%ld %ld %ld %ld %ld %ld %ld %ld %ld",&idim[0],&idim[1],&idim[2],
- &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]);
-#else
- sscanf(line,"%d %d %d %d %d %d %d %d %d",&idim[0],&idim[1],&idim[2],
- &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]);
-#endif
- i__1 = nidim;
- for (i__ = 1; i__ <= i__1; ++i__) {
- if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) {
- fprintf(stderr,"VALUE OF N IS LESS THAN 0 OR GREATER THAN 65\n");
- goto L220;
- }
-/* L10: */
- }
-/* Values of ALPHA */
- fgets(line,80,stdin);
-#ifdef USE64BITINT
- sscanf(line,"%ld",&nalf);
-#else
- sscanf(line,"%d",&nalf);
-#endif
- if (nalf < 1 || nalf > 7) {
- fprintf(stderr,"VALUE OF ALPHA IS LESS THAN 0 OR GREATER THAN 7\n");
- goto L220;
- }
- fgets(line,80,stdin);
- sscanf(line,"%lf %lf %lf %lf %lf %lf %lf",&alf[0],&alf[1],&alf[2],&alf[3],&alf[4],&alf[5],&alf[6]);
-
-/* Values of BETA */
- fgets(line,80,stdin);
-#ifdef USE64BITINT
- sscanf(line,"%ld",&nbet);
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
#else
- sscanf(line,"%d",&nbet);
+typedef logical (*L_fp)();
#endif
- if (nalf < 1 || nbet > 7) {
- fprintf(stderr,"VALUE OF BETA IS LESS THAN 0 OR GREATER THAN 7\n");
- goto L220;
- }
- fgets(line,80,stdin);
- sscanf(line,"%lf %lf %lf %lf %lf %lf %lf",&bet[0],&bet[1],&bet[2],&bet[3],&bet[4],&bet[5],&bet[6]);
-
-/* Report values of parameters. */
-
- printf("TESTS OF THE DOUBLE PRECISION LEVEL 3 BLAS\nTHE FOLLOWING PARAMETER VALUES WILL BE USED:\n");
- printf(" FOR N");
- for (i__ =1; i__ <=nidim;++i__) printf(" %d",idim[i__-1]);
- printf("\n");
- printf(" FOR ALPHA");
- for (i__ =1; i__ <=nalf;++i__) printf(" %f",alf[i__-1]);
- printf("\n");
- printf(" FOR BETA");
- for (i__ =1; i__ <=nbet;++i__) printf(" %f",bet[i__-1]);
- printf("\n");
-
- if (! tsterr) {
- printf(" ERROR-EXITS WILL NOT BE TESTED\n");
- }
- printf("ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LESS THAN %f\n",thresh);
-
- rorder = FALSE_;
- corder = FALSE_;
- if (layout == 2) {
- rorder = TRUE_;
- corder = TRUE_;
- printf("COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED\n");
- } else if (layout == 1) {
- rorder = TRUE_;
- printf("ROW-MAJOR DATA LAYOUT IS TESTED\n");
- } else if (layout == 0) {
- corder = TRUE_;
- printf("COLUMN-MAJOR DATA LAYOUT IS TESTED\n");
- }
-
-/* Read names of subroutines and flags which indicate */
-/* whether they are to be tested. */
-
- for (i__ = 1; i__ <= 6; ++i__) {
- ltest[i__ - 1] = FALSE_;
-/* L20: */
- }
-L30:
- if (! fgets(line,80,stdin)) {
- goto L60;
- }
- i__1 = sscanf(line,"%12c %c",snamet,&tmpchar);
- ltestt=FALSE_;
- if (tmpchar=='T')ltestt=TRUE_;
- if (i__1 < 2) {
- goto L60;
- }
- for (i__ = 1; i__ <= 6; ++i__) {
- if (s_cmp(snamet, snames[i__ - 1] , (ftnlen)12, (ftnlen)12) ==
- 0) {
- goto L50;
- }
-/* L40: */
- }
- printf("SUBPROGRAM NAME %s NOT RECOGNIZED\n****** TESTS ABANDONED ******\n",snamet);
- exit(1);
-
-
-L50:
- ltest[i__ - 1] = ltestt;
- goto L30;
-
-L60:
-/* cl__1.cerr = 0;
- cl__1.cunit = 5;
- cl__1.csta = 0;
- f_clos(&cl__1);*/
-
-/* Compute EPS (the machine precision). */
-
- eps = 1.;
-L70:
- d__1 = eps + 1.;
- if (ddiff_(&d__1, &c_b90) == 0.) {
- goto L80;
- }
- eps *= .5;
- goto L70;
-L80:
- eps += eps;
- printf("RELATIVE MACHINE PRECISION IS TAKEN TO BE %9.1g\n",eps);
-
-/* Check the reliability of DMMCH using exact data. */
-
- n = 32;
- i__1 = n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = n;
- for (i__ = 1; i__ <= i__2; ++i__) {
-/* Computing MAX */
- i__3 = i__ - j + 1;
- ab[i__ + j * 65 - 66] = (doublereal) f2cmax(i__3,0);
-/* L90: */
- }
- ab[j + 4224] = (doublereal) j;
- ab[(j + 65) * 65 - 65] = (doublereal) j;
- c__[j - 1] = 0.;
-/* L100: */
- }
- i__1 = n;
- for (j = 1; j <= i__1; ++j) {
- cc[j - 1] = (doublereal) (j * ((j + 1) * j) / 2 - (j + 1) * j * (j -
- 1) / 3);
-/* L110: */
- }
-/* CC holds the exact result. On exit from DMMCH CT holds */
-/* the result computed by DMMCH. */
- *(unsigned char *)transa = 'N';
- *(unsigned char *)transb = 'N';
- dmmch_(transa, transb, &n, &c__1, &n, &c_b90, ab, &c__65, &ab[4225], &
- c__65, &c_b104, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &
- fatal, &c__6, &c_true, (ftnlen)1, (ftnlen)1);
- same = lde_(cc, ct, &n);
- if (! same || err != 0.) {
- printf("ERROR IN DMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n");
- printf("DMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb);
- printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err);
- printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n");
- printf("****** TESTS ABANDONED ******\n");
- exit(1);
- }
- *(unsigned char *)transb = 'T';
- dmmch_(transa, transb, &n, &c__1, &n, &c_b90, ab, &c__65, &ab[4225], &
- c__65, &c_b104, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &
- fatal, &c__6, &c_true, (ftnlen)1, (ftnlen)1);
- same = lde_(cc, ct, &n);
- if (! same || err != 0.) {
- printf("ERROR IN DMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n");
- printf("DMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb);
- printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err);
- printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n");
- printf("****** TESTS ABANDONED ******\n");
- exit(1);
- }
- i__1 = n;
- for (j = 1; j <= i__1; ++j) {
- ab[j + 4224] = (doublereal) (n - j + 1);
- ab[(j + 65) * 65 - 65] = (doublereal) (n - j + 1);
-/* L120: */
- }
- i__1 = n;
- for (j = 1; j <= i__1; ++j) {
- cc[n - j] = (doublereal) (j * ((j + 1) * j) / 2 - (j + 1) * j * (j -
- 1) / 3);
-/* L130: */
- }
- *(unsigned char *)transa = 'T';
- *(unsigned char *)transb = 'N';
- dmmch_(transa, transb, &n, &c__1, &n, &c_b90, ab, &c__65, &ab[4225], &
- c__65, &c_b104, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &
- fatal, &c__6, &c_true, (ftnlen)1, (ftnlen)1);
- same = lde_(cc, ct, &n);
- if (! same || err != 0.) {
- printf("ERROR IN DMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n");
- printf("DMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb);
- printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err);
- printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n");
- printf("****** TESTS ABANDONED ******\n");
- exit(1);
- }
- *(unsigned char *)transb = 'T';
- dmmch_(transa, transb, &n, &c__1, &n, &c_b90, ab, &c__65, &ab[4225], &
- c__65, &c_b104, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &
- fatal, &c__6, &c_true, (ftnlen)1, (ftnlen)1);
- same = lde_(cc, ct, &n);
- if (! same || err != 0.) {
- }
-
-/* Test each subroutine in turn. */
-
- for (isnum = 1; isnum <= 6; ++isnum) {
- if (! ltest[isnum - 1]) {
-/* Subprogram is not to be tested. */
- printf("%12s WAS NOT TESTED\n",snames[isnum-1]);
- } else {
- s_copy(srnamc_1.srnamt, snames[isnum - 1], (ftnlen)12, (
- ftnlen)12);
-/* Test error exits. */
- if (tsterr) {
- cd3chke_(snames[isnum - 1], (ftnlen)12);
- }
-/* Test computations. */
- infoc_1.infot = 0;
- infoc_1.ok = TRUE_;
- fatal = FALSE_;
- switch ((int)isnum) {
- case 1: goto L140;
- case 2: goto L150;
- case 3: goto L160;
- case 4: goto L160;
- case 5: goto L170;
- case 6: goto L180;
- }
-/* Test DGEMM, 01. */
-L140:
- if (corder) {
- dchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,
- cc, cs, ct, g, &c__0, (ftnlen)12);
- }
- if (rorder) {
- dchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,
- cc, cs, ct, g, &c__1, (ftnlen)12);
- }
- goto L190;
-/* Test DSYMM, 02. */
-L150:
- if (corder) {
- dchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,
- cc, cs, ct, g, &c__0, (ftnlen)12);
- }
- if (rorder) {
- dchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,
- cc, cs, ct, g, &c__1, (ftnlen)12);
- }
- goto L190;
-/* Test DTRMM, 03, DTRSM, 04. */
-L160:
- if (corder) {
- dchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, &
- c__0, (ftnlen)12);
- }
- if (rorder) {
- dchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, &
- c__1, (ftnlen)12);
- }
- goto L190;
-/* Test DSYRK, 05. */
-L170:
- if (corder) {
- dchk4_(snames[isnum -1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,
- cc, cs, ct, g, &c__0, (ftnlen)12);
- }
- if (rorder) {
- dchk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,
- cc, cs, ct, g, &c__1, (ftnlen)12);
- }
- goto L190;
-/* Test DSYR2K, 06. */
-L180:
- if (corder) {
- dchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs,
- ct, g, w, &c__0, (ftnlen)12);
- }
- if (rorder) {
- dchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs,
- ct, g, w, &c__1, (ftnlen)12);
- }
- goto L190;
-
-L190:
- if (fatal && sfatal) {
- goto L210;
- }
- }
-/* L200: */
- }
- printf("\nEND OF TESTS\n");
- goto L230;
-
-L210:
- printf("\n****** FATAL ERROR - TESTS ABANDONED ******\n");
- goto L230;
-
-L220:
- printf("AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM\n");
- printf("****** TESTS ABANDONED ******\n");
-
-L230:
- if (trace) {
-/* cl__1.cerr = 0;
- cl__1.cunit = ntra;
- cl__1.csta = 0;
- f_clos(&cl__1);*/
- }
-/* cl__1.cerr = 0;
- cl__1.cunit = 6;
- cl__1.csta = 0;
- f_clos(&cl__1);*/
- exit(0);
-/* End of DBLAT3. */
-
-} /* MAIN__ */
-
-/* Subroutine */ int dchk1_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublereal* alf, integer* nbet, doublereal* bet, integer* nmax, doublereal* a, doublereal* aa, doublereal* as, doublereal* b, doublereal* bb, doublereal* bs, doublereal* c__, doublereal* cc, doublereal* cs, doublereal* ct, doublereal* g, integer* iorder, ftnlen sname_len)
-{
- /* Initialized data */
-
- static char ich[3+1] = "NTC";
-
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
- i__3, i__4, i__5, i__6;
-
-
- /* Local variables */
- static doublereal beta;
- static integer ldas, ldbs, ldcs;
- static logical same, null;
- static integer i__, k, m, n;
- extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*, ftnlen, ftnlen, ftnlen);
- static doublereal alpha;
- extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen);
- static logical isame[13], trana, tranb;
- static integer nargs;
- static logical reset;
- extern /* Subroutine */ void dprcn1_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, integer*, doublereal*, integer*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen);
- static integer ia, ib, ma, mb, na, nb, nc, ik, im, in;
- extern /* Subroutine */ void cdgemm_(integer*, char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen);
- static integer ks, ms, ns;
- extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen);
- static char tranas[1], tranbs[1], transa[1], transb[1];
- static doublereal errmax;
- static integer ica, icb, laa, lbb, lda, lcc, ldb, ldc;
- extern logical lde_(doublereal*, doublereal*, integer*);
- static doublereal als, bls, err;
-
-/* Tests DGEMM. */
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Parameters .. */
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. Local Scalars .. */
-/* .. Local Arrays .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Scalars in Common .. */
-/* .. Common blocks .. */
-/* .. Data statements .. */
- /* Parameter adjustments */
- --idim;
- --alf;
- --bet;
- --g;
- --ct;
- --cs;
- --cc;
- c_dim1 = *nmax;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
- --bs;
- --bb;
- b_dim1 = *nmax;
- b_offset = 1 + b_dim1 * 1;
- b -= b_offset;
- --as;
- --aa;
- a_dim1 = *nmax;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
-
- /* Function Body */
-/* .. Executable Statements .. */
-
- nargs = 13;
- nc = 0;
- reset = TRUE_;
- errmax = 0.;
-
- i__1 = *nidim;
- for (im = 1; im <= i__1; ++im) {
- m = idim[im];
-
- i__2 = *nidim;
- for (in = 1; in <= i__2; ++in) {
- n = idim[in];
-/* Set LDC to 1 more than minimum value if room. */
- ldc = m;
- if (ldc < *nmax) {
- ++ldc;
- }
-/* Skip tests if not enough room. */
- if (ldc > *nmax) {
- goto L100;
- }
- lcc = ldc * n;
- null = n <= 0 || m <= 0;
-
- i__3 = *nidim;
- for (ik = 1; ik <= i__3; ++ik) {
- k = idim[ik];
-
- for (ica = 1; ica <= 3; ++ica) {
- *(unsigned char *)transa = *(unsigned char *)&ich[ica - 1]
- ;
- trana = *(unsigned char *)transa == 'T' || *(unsigned
- char *)transa == 'C';
-
- if (trana) {
- ma = k;
- na = m;
- } else {
- ma = m;
- na = k;
- }
-/* Set LDA to 1 more than minimum value if room. */
- lda = ma;
- if (lda < *nmax) {
- ++lda;
- }
-/* Skip tests if not enough room. */
- if (lda > *nmax) {
- goto L80;
- }
- laa = lda * na;
-
-/* Generate the matrix A. */
-
- dmake_("GE", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[
- 1], &lda, &reset, &c_b104, (ftnlen)2, (ftnlen)1, (
- ftnlen)1);
-
- for (icb = 1; icb <= 3; ++icb) {
- *(unsigned char *)transb = *(unsigned char *)&ich[icb
- - 1];
- tranb = *(unsigned char *)transb == 'T' || *(unsigned
- char *)transb == 'C';
-
- if (tranb) {
- mb = n;
- nb = k;
- } else {
- mb = k;
- nb = n;
- }
-/* Set LDB to 1 more than minimum value if room. */
- ldb = mb;
- if (ldb < *nmax) {
- ++ldb;
- }
-/* Skip tests if not enough room. */
- if (ldb > *nmax) {
- goto L70;
- }
- lbb = ldb * nb;
-
-/* Generate the matrix B. */
-
- dmake_("GE", " ", " ", &mb, &nb, &b[b_offset], nmax, &
- bb[1], &ldb, &reset, &c_b104, (ftnlen)2, (
- ftnlen)1, (ftnlen)1);
-
- i__4 = *nalf;
- for (ia = 1; ia <= i__4; ++ia) {
- alpha = alf[ia];
-
- i__5 = *nbet;
- for (ib = 1; ib <= i__5; ++ib) {
- beta = bet[ib];
-
-/* Generate the matrix C. */
-
- dmake_("GE", " ", " ", &m, &n, &c__[c_offset],
- nmax, &cc[1], &ldc, &reset, &c_b104,
- (ftnlen)2, (ftnlen)1, (ftnlen)1);
-
- ++nc;
-
-/* Save every datum before calling the */
-/* subroutine. */
-
- *(unsigned char *)tranas = *(unsigned char *)
- transa;
- *(unsigned char *)tranbs = *(unsigned char *)
- transb;
- ms = m;
- ns = n;
- ks = k;
- als = alpha;
- i__6 = laa;
- for (i__ = 1; i__ <= i__6; ++i__) {
- as[i__] = aa[i__];
-/* L10: */
- }
- ldas = lda;
- i__6 = lbb;
- for (i__ = 1; i__ <= i__6; ++i__) {
- bs[i__] = bb[i__];
-/* L20: */
- }
- ldbs = ldb;
- bls = beta;
- i__6 = lcc;
- for (i__ = 1; i__ <= i__6; ++i__) {
- cs[i__] = cc[i__];
-/* L30: */
- }
- ldcs = ldc;
-
-/* Call the subroutine. */
-
- if (*trace) {
- dprcn1_(ntra, &nc, sname, iorder, transa,
- transb, &m, &n, &k, &alpha, &lda,
- &ldb, &beta, &ldc, (ftnlen)12, (
- ftnlen)1, (ftnlen)1);
- }
- if (*rewi) {
-/* al__1.aerr = 0;
- al__1.aunit = *ntra;
- f_rew(&al__1);*/
- }
- cdgemm_(iorder, transa, transb, &m, &n, &k, &
- alpha, &aa[1], &lda, &bb[1], &ldb, &
- beta, &cc[1], &ldc, (ftnlen)1, (
- ftnlen)1);
-
-/* Check if error-exit was taken incorrectly. */
-
- if (! infoc_1.ok) {
- printf(" *** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");
- *fatal = TRUE_;
- goto L120;
- }
-
-/* See what data changed inside subroutines. */
-
- isame[0] = *(unsigned char *)transa == *(
- unsigned char *)tranas;
- isame[1] = *(unsigned char *)transb == *(
- unsigned char *)tranbs;
- isame[2] = ms == m;
- isame[3] = ns == n;
- isame[4] = ks == k;
- isame[5] = als == alpha;
- isame[6] = lde_(&as[1], &aa[1], &laa);
- isame[7] = ldas == lda;
- isame[8] = lde_(&bs[1], &bb[1], &lbb);
- isame[9] = ldbs == ldb;
- isame[10] = bls == beta;
- if (null) {
- isame[11] = lde_(&cs[1], &cc[1], &lcc);
- } else {
- isame[11] = lderes_("GE", " ", &m, &n, &
- cs[1], &cc[1], &ldc, (ftnlen)2, (
- ftnlen)1);
- }
- isame[12] = ldcs == ldc;
-
-/* If data was incorrectly changed, report */
-/* and return. */
-
- same = TRUE_;
- i__6 = nargs;
- for (i__ = 1; i__ <= i__6; ++i__) {
- same = same && isame[i__ - 1];
- if (! isame[i__ - 1]) {
- printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
- }
-/* L40: */
- }
- if (! same) {
- *fatal = TRUE_;
- goto L120;
- }
-
- if (! null) {
-
-/* Check the result. */
-
- dmmch_(transa, transb, &m, &n, &k, &alpha,
- &a[a_offset], nmax, &b[b_offset],
- nmax, &beta, &c__[c_offset],
- nmax, &ct[1], &g[1], &cc[1], &ldc,
- eps, &err, fatal, nout, &c_true,
- (ftnlen)1, (ftnlen)1);
- errmax = f2cmax(errmax,err);
-/* If got really bad answer, report and */
-/* return. */
- if (*fatal) {
- goto L120;
- }
- }
-
-/* L50: */
- }
-
-/* L60: */
- }
-
-L70:
- ;
- }
-
-L80:
- ;
+static float spow_ui(float x, integer n) {
+ float pow=1.0; unsigned long int u;
+ if(n != 0) {
+ if(n < 0) n = -n, x = 1/x;
+ for(u = n; ; ) {
+ if(u & 01) pow *= x;
+ if(u >>= 1) x *= x;
+ else break;
}
-
-/* L90: */
- }
-
-L100:
- ;
}
-
-/* L110: */
- }
-
-/* Report result. */
-
- if (errmax < *thresh) {
- if (*iorder == 0) {
- printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
- }
- if (*iorder == 1) {
- printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
- }
- } else {
- if (*iorder == 0) {
- printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);
- printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);
- }
- if (*iorder == 1) {
- printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);
- printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);
- }
- }
- goto L130;
-
-L120:
- printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
- dprcn1_(nout, &nc, sname, iorder, transa, transb, &m, &n, &k, &alpha, &
- lda, &ldb, &beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1);
-
-L130:
- return 0;
-
-/* 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',', */
-/* $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ', */
-/* $ 'C,', I3, ').' ) */
-
-/* End of DCHK1. */
-
-} /* dchk1_ */
-
-/* Subroutine */ void dprcn1_(integer* nout, integer* nc, char* sname, integer* iorder, char* transa, char* transb, integer* m, integer* n, integer* k, doublereal* alpha, integer* lda, integer* ldb, doublereal* beta, integer* ldc, ftnlen sname_len, ftnlen transa_len, ftnlen transb_len)
-{
-
- /* Local variables */
- static char crc[14], cta[14], ctb[14];
-
- if (*(unsigned char *)transa == 'N') {
- s_copy(cta, " CblasNoTrans", (ftnlen)14, (ftnlen)14);
- } else if (*(unsigned char *)transa == 'T') {
- s_copy(cta, " CblasTrans", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(cta, "CblasConjTrans", (ftnlen)14, (ftnlen)14);
- }
- if (*(unsigned char *)transb == 'N') {
- s_copy(ctb, " CblasNoTrans", (ftnlen)14, (ftnlen)14);
- } else if (*(unsigned char *)transb == 'T') {
- s_copy(ctb, " CblasTrans", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(ctb, "CblasConjTrans", (ftnlen)14, (ftnlen)14);
- }
- if (*iorder == 1) {
- s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
- }
- printf("%6d: %s %s %s %s\n",*nc,sname,crc,cta,ctb);
- printf("%d %d %d %4.1f A, %d, B, %d, %4.1f, C, %d.\n",*m,*n,*k,*alpha,*lda,*ldb,*beta,*ldc);
-} /* dprcn1_ */
-
-
-/* Subroutine */ int dchk2_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublereal* alf, integer* nbet, doublereal* bet, integer* nmax, doublereal* a, doublereal* aa, doublereal* as, doublereal* b, doublereal* bb, doublereal* bs, doublereal* c__, doublereal* cc, doublereal* cs, doublereal* ct, doublereal* g, integer* iorder, ftnlen sname_len)
-{
- /* Initialized data */
-
- static char ichs[2+1] = "LR";
- static char ichu[2+1] = "UL";
-
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
- i__3, i__4, i__5;
-
-
- /* Local variables */
- static doublereal beta;
- static integer ldas, ldbs, ldcs;
- static logical same;
- static char side[1];
- static logical left, null;
- static char uplo[1];
- static integer i__, m, n;
- extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*, ftnlen, ftnlen, ftnlen);
- static doublereal alpha;
- extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen);
- static logical isame[13];
- static char sides[1];
- static integer nargs;
- static logical reset;
- static char uplos[1];
- extern /* Subroutine */ void dprcn2_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublereal*, integer*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen);
- static integer ia, ib, na, nc, im, in, ms, ns;
- extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen);
- extern /* Subroutine */ void cdsymm_(integer*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen);
- static doublereal errmax;
- static integer laa, lbb, lda, lcc, ldb, ldc;
- extern logical lde_(doublereal*, doublereal*, integer*);
- static integer ics;
- static doublereal als, bls;
- static integer icu;
- static doublereal err;
-
-/* Tests DSYMM. */
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Parameters .. */
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. Local Scalars .. */
-/* .. Local Arrays .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Scalars in Common .. */
-/* .. Common blocks .. */
-/* .. Data statements .. */
- /* Parameter adjustments */
- --idim;
- --alf;
- --bet;
- --g;
- --ct;
- --cs;
- --cc;
- c_dim1 = *nmax;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
- --bs;
- --bb;
- b_dim1 = *nmax;
- b_offset = 1 + b_dim1 * 1;
- b -= b_offset;
- --as;
- --aa;
- a_dim1 = *nmax;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
-
- /* Function Body */
-/* .. Executable Statements .. */
-
- nargs = 12;
- nc = 0;
- reset = TRUE_;
- errmax = 0.;
-
- i__1 = *nidim;
- for (im = 1; im <= i__1; ++im) {
- m = idim[im];
-
- i__2 = *nidim;
- for (in = 1; in <= i__2; ++in) {
- n = idim[in];
-/* Set LDC to 1 more than minimum value if room. */
- ldc = m;
- if (ldc < *nmax) {
- ++ldc;
- }
-/* Skip tests if not enough room. */
- if (ldc > *nmax) {
- goto L90;
- }
- lcc = ldc * n;
- null = n <= 0 || m <= 0;
-
-/* Set LDB to 1 more than minimum value if room. */
- ldb = m;
- if (ldb < *nmax) {
- ++ldb;
- }
-/* Skip tests if not enough room. */
- if (ldb > *nmax) {
- goto L90;
- }
- lbb = ldb * n;
-
-/* Generate the matrix B. */
-
- dmake_("GE", " ", " ", &m, &n, &b[b_offset], nmax, &bb[1], &ldb, &
- reset, &c_b104, (ftnlen)2, (ftnlen)1, (ftnlen)1);
-
- for (ics = 1; ics <= 2; ++ics) {
- *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1];
- left = *(unsigned char *)side == 'L';
-
- if (left) {
- na = m;
- } else {
- na = n;
- }
-/* Set LDA to 1 more than minimum value if room. */
- lda = na;
- if (lda < *nmax) {
- ++lda;
- }
-/* Skip tests if not enough room. */
- if (lda > *nmax) {
- goto L80;
- }
- laa = lda * na;
-
- for (icu = 1; icu <= 2; ++icu) {
- *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];
-
-/* Generate the symmetric matrix A. */
-
- dmake_("SY", uplo, " ", &na, &na, &a[a_offset], nmax, &aa[
- 1], &lda, &reset, &c_b104, (ftnlen)2, (ftnlen)1, (
- ftnlen)1);
-
- i__3 = *nalf;
- for (ia = 1; ia <= i__3; ++ia) {
- alpha = alf[ia];
-
- i__4 = *nbet;
- for (ib = 1; ib <= i__4; ++ib) {
- beta = bet[ib];
-
-/* Generate the matrix C. */
-
- dmake_("GE", " ", " ", &m, &n, &c__[c_offset],
- nmax, &cc[1], &ldc, &reset, &c_b104, (
- ftnlen)2, (ftnlen)1, (ftnlen)1);
-
- ++nc;
-
-/* Save every datum before calling the */
-/* subroutine. */
-
- *(unsigned char *)sides = *(unsigned char *)side;
- *(unsigned char *)uplos = *(unsigned char *)uplo;
- ms = m;
- ns = n;
- als = alpha;
- i__5 = laa;
- for (i__ = 1; i__ <= i__5; ++i__) {
- as[i__] = aa[i__];
-/* L10: */
- }
- ldas = lda;
- i__5 = lbb;
- for (i__ = 1; i__ <= i__5; ++i__) {
- bs[i__] = bb[i__];
-/* L20: */
- }
- ldbs = ldb;
- bls = beta;
- i__5 = lcc;
- for (i__ = 1; i__ <= i__5; ++i__) {
- cs[i__] = cc[i__];
-/* L30: */
- }
- ldcs = ldc;
-
-/* Call the subroutine. */
-
- if (*trace) {
- dprcn2_(ntra, &nc, sname, iorder, side, uplo,
- &m, &n, &alpha, &lda, &ldb, &beta, &
- ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1)
- ;
- }
- if (*rewi) {
-/* al__1.aerr = 0;
- al__1.aunit = *ntra;
- f_rew(&al__1);*/
- }
- cdsymm_(iorder, side, uplo, &m, &n, &alpha, &aa[1]
- , &lda, &bb[1], &ldb, &beta, &cc[1], &ldc,
- (ftnlen)1, (ftnlen)1);
-
-/* Check if error-exit was taken incorrectly. */
-
- if (! infoc_1.ok) {
- printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");
- *fatal = TRUE_;
- goto L110;
- }
-
-/* See what data changed inside subroutines. */
-
- isame[0] = *(unsigned char *)sides == *(unsigned
- char *)side;
- isame[1] = *(unsigned char *)uplos == *(unsigned
- char *)uplo;
- isame[2] = ms == m;
- isame[3] = ns == n;
- isame[4] = als == alpha;
- isame[5] = lde_(&as[1], &aa[1], &laa);
- isame[6] = ldas == lda;
- isame[7] = lde_(&bs[1], &bb[1], &lbb);
- isame[8] = ldbs == ldb;
- isame[9] = bls == beta;
- if (null) {
- isame[10] = lde_(&cs[1], &cc[1], &lcc);
- } else {
- isame[10] = lderes_("GE", " ", &m, &n, &cs[1],
- &cc[1], &ldc, (ftnlen)2, (ftnlen)1);
- }
- isame[11] = ldcs == ldc;
-
-/* If data was incorrectly changed, report and */
-/* return. */
-
- same = TRUE_;
- i__5 = nargs;
- for (i__ = 1; i__ <= i__5; ++i__) {
- same = same && isame[i__ - 1];
- if (! isame[i__ - 1]) {
- printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
- }
-/* L40: */
- }
- if (! same) {
- *fatal = TRUE_;
- goto L110;
- }
-
- if (! null) {
-
-/* Check the result. */
-
- if (left) {
- dmmch_("N", "N", &m, &n, &m, &alpha, &a[
- a_offset], nmax, &b[b_offset],
- nmax, &beta, &c__[c_offset], nmax,
- &ct[1], &g[1], &cc[1], &ldc, eps,
- &err, fatal, nout, &c_true, (
- ftnlen)1, (ftnlen)1);
- } else {
- dmmch_("N", "N", &m, &n, &n, &alpha, &b[
- b_offset], nmax, &a[a_offset],
- nmax, &beta, &c__[c_offset], nmax,
- &ct[1], &g[1], &cc[1], &ldc, eps,
- &err, fatal, nout, &c_true, (
- ftnlen)1, (ftnlen)1);
- }
- errmax = f2cmax(errmax,err);
-/* If got really bad answer, report and */
-/* return. */
- if (*fatal) {
- goto L110;
- }
- }
-
-/* L50: */
- }
-
-/* L60: */
- }
-
-/* L70: */
+ return pow;
+}
+static double dpow_ui(double x, integer n) {
+ double pow=1.0; unsigned long int u;
+ if(n != 0) {
+ if(n < 0) n = -n, x = 1/x;
+ for(u = n; ; ) {
+ if(u & 01) pow *= x;
+ if(u >>= 1) x *= x;
+ else break;
}
-
-L80:
- ;
- }
-
-L90:
- ;
- }
-
-/* L100: */
- }
-
-/* Report result. */
-
- if (errmax < *thresh) {
- if (*iorder == 0) {
- printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
- }
- if (*iorder == 1) {
- printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
- }
- } else {
- if (*iorder == 0) {
- printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);
- printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);
}
- if (*iorder == 1) {
- printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);
- printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);
- }
- }
- goto L120;
-
-L110:
- printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
- dprcn2_(nout, &nc, sname, iorder, side, uplo, &m, &n, &alpha, &lda, &ldb,
- &beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1);
-
-L120:
- return 0;
-
-/* 9995 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */
-/* $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', */
-/* $ ' .' ) */
-
-/* End of DCHK2. */
-
-} /* dchk2_ */
-
-
-/* Subroutine */ void dprcn2_(integer* nout, integer* nc, char* sname, integer* iorder, char* side, char* uplo, integer* m, integer* n, doublereal* alpha, integer* lda, integer* ldb, doublereal* beta, integer* ldc, ftnlen sname_len, ftnlen side_len, ftnlen uplo_len)
-{
-
- /* Local variables */
- static char cs[14], cu[14], crc[14];
-
- if (*(unsigned char *)side == 'L') {
- s_copy(cs, " CblasLeft", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(cs, " CblasRight", (ftnlen)14, (ftnlen)14);
- }
- if (*(unsigned char *)uplo == 'U') {
- s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14);
- }
- if (*iorder == 1) {
- s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
- }
- printf("%6d: %s %s %s %s\n",*nc,sname,crc,cs,cu);
- printf("%d %d %4.1f A, %d, B, %d, %4.1f C, %d.\n",*m,*n,*alpha,*lda,*ldb,*beta,*ldc);
-} /* dprcn2_ */
-
-
-/* Subroutine */ int dchk3_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublereal* alf, integer* nmax, doublereal* a, doublereal* aa, doublereal* as, doublereal* b, doublereal* bb, doublereal* bs, doublereal* ct, doublereal* g, doublereal* c__, integer* iorder, ftnlen sname_len)
-{
- /* Initialized data */
-
- static char ichu[2+1] = "UL";
- static char icht[3+1] = "NTC";
- static char ichd[2+1] = "UN";
- static char ichs[2+1] = "LR";
-
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
- i__3, i__4, i__5;
-
- /* Local variables */
- static char diag[1];
- static integer ldas, ldbs;
- static logical same;
- static char side[1];
- static logical left, null;
- static char uplo[1];
- static integer i__, j, m, n;
- extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*, ftnlen, ftnlen, ftnlen);
- static doublereal alpha;
- static char diags[1];
- extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen);
- static logical isame[13];
- static char sides[1];
- static integer nargs;
- static logical reset;
- static char uplos[1];
- extern /* Subroutine */ void dprcn3_(integer*, integer*, char*, integer*, char*, char*, char*, char*, integer*, integer*, doublereal*, integer*, integer*, ftnlen, ftnlen, ftnlen, ftnlen, ftnlen);
- static integer ia, na, nc, im, in, ms, ns;
- extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen);
- extern /* Subroutine */ void cdtrmm_(integer*, char*, char*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen, ftnlen);
- static char tranas[1], transa[1];
- extern /* Subroutine */ void cdtrsm_(integer*, char*, char*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen, ftnlen);
- static doublereal errmax;
- static integer laa, icd, lbb, lda, ldb;
- extern logical lde_(doublereal*, doublereal*, integer*);
- static integer ics;
- static doublereal als;
- static integer ict, icu;
- static doublereal err;
-
-/* Tests DTRMM and DTRSM. */
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Parameters .. */
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. Local Scalars .. */
-/* .. Local Arrays .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Scalars in Common .. */
-/* .. Common blocks .. */
-/* .. Data statements .. */
- /* Parameter adjustments */
- --idim;
- --alf;
- c_dim1 = *nmax;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
- --g;
- --ct;
- --bs;
- --bb;
- b_dim1 = *nmax;
- b_offset = 1 + b_dim1 * 1;
- b -= b_offset;
- --as;
- --aa;
- a_dim1 = *nmax;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
-
- /* Function Body */
-/* .. Executable Statements .. */
-
- nargs = 11;
- nc = 0;
- reset = TRUE_;
- errmax = 0.;
-/* Set up zero matrix for DMMCH. */
- i__1 = *nmax;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *nmax;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = 0.;
-/* L10: */
- }
-/* L20: */
- }
-
- i__1 = *nidim;
- for (im = 1; im <= i__1; ++im) {
- m = idim[im];
-
- i__2 = *nidim;
- for (in = 1; in <= i__2; ++in) {
- n = idim[in];
-/* Set LDB to 1 more than minimum value if room. */
- ldb = m;
- if (ldb < *nmax) {
- ++ldb;
- }
-/* Skip tests if not enough room. */
- if (ldb > *nmax) {
- goto L130;
- }
- lbb = ldb * n;
- null = m <= 0 || n <= 0;
-
- for (ics = 1; ics <= 2; ++ics) {
- *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1];
- left = *(unsigned char *)side == 'L';
- if (left) {
- na = m;
- } else {
- na = n;
- }
-/* Set LDA to 1 more than minimum value if room. */
- lda = na;
- if (lda < *nmax) {
- ++lda;
- }
-/* Skip tests if not enough room. */
- if (lda > *nmax) {
- goto L130;
- }
- laa = lda * na;
-
- for (icu = 1; icu <= 2; ++icu) {
- *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];
-
- for (ict = 1; ict <= 3; ++ict) {
- *(unsigned char *)transa = *(unsigned char *)&icht[
- ict - 1];
-
- for (icd = 1; icd <= 2; ++icd) {
- *(unsigned char *)diag = *(unsigned char *)&ichd[
- icd - 1];
-
- i__3 = *nalf;
- for (ia = 1; ia <= i__3; ++ia) {
- alpha = alf[ia];
-
-/* Generate the matrix A. */
-
- dmake_("TR", uplo, diag, &na, &na, &a[
- a_offset], nmax, &aa[1], &lda, &reset,
- &c_b104, (ftnlen)2, (ftnlen)1, (
- ftnlen)1);
-
-/* Generate the matrix B. */
-
- dmake_("GE", " ", " ", &m, &n, &b[b_offset],
- nmax, &bb[1], &ldb, &reset, &c_b104, (
- ftnlen)2, (ftnlen)1, (ftnlen)1);
-
- ++nc;
-
-/* Save every datum before calling the */
-/* subroutine. */
-
- *(unsigned char *)sides = *(unsigned char *)
- side;
- *(unsigned char *)uplos = *(unsigned char *)
- uplo;
- *(unsigned char *)tranas = *(unsigned char *)
- transa;
- *(unsigned char *)diags = *(unsigned char *)
- diag;
- ms = m;
- ns = n;
- als = alpha;
- i__4 = laa;
- for (i__ = 1; i__ <= i__4; ++i__) {
- as[i__] = aa[i__];
-/* L30: */
- }
- ldas = lda;
- i__4 = lbb;
- for (i__ = 1; i__ <= i__4; ++i__) {
- bs[i__] = bb[i__];
-/* L40: */
- }
- ldbs = ldb;
-
-/* Call the subroutine. */
-
- if (s_cmp(sname + 9, "mm", (ftnlen)2, (ftnlen)
- 2) == 0) {
- if (*trace) {
- dprcn3_(ntra, &nc, sname, iorder,
- side, uplo, transa, diag, &m,
- &n, &alpha, &lda, &ldb, (
- ftnlen)12, (ftnlen)1, (ftnlen)
- 1, (ftnlen)1, (ftnlen)1);
- }
- if (*rewi) {
-/* al__1.aerr = 0;
- al__1.aunit = *ntra;
- f_rew(&al__1);*/
- }
- cdtrmm_(iorder, side, uplo, transa, diag,
- &m, &n, &alpha, &aa[1], &lda, &bb[
- 1], &ldb, (ftnlen)1, (ftnlen)1, (
- ftnlen)1, (ftnlen)1);
- } else if (s_cmp(sname + 9, "sm", (ftnlen)2, (
- ftnlen)2) == 0) {
- if (*trace) {
- dprcn3_(ntra, &nc, sname, iorder,
- side, uplo, transa, diag, &m,
- &n, &alpha, &lda, &ldb, (
- ftnlen)12, (ftnlen)1, (ftnlen)
- 1, (ftnlen)1, (ftnlen)1);
- }
- if (*rewi) {
-/* al__1.aerr = 0;
- al__1.aunit = *ntra;
- f_rew(&al__1);*/
- }
- cdtrsm_(iorder, side, uplo, transa, diag,
- &m, &n, &alpha, &aa[1], &lda, &bb[
- 1], &ldb, (ftnlen)1, (ftnlen)1, (
- ftnlen)1, (ftnlen)1);
- }
-
-/* Check if error-exit was taken incorrectly. */
-
- if (! infoc_1.ok) {
- printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");
- *fatal = TRUE_;
- goto L150;
- }
-
-/* See what data changed inside subroutines. */
-
- isame[0] = *(unsigned char *)sides == *(
- unsigned char *)side;
- isame[1] = *(unsigned char *)uplos == *(
- unsigned char *)uplo;
- isame[2] = *(unsigned char *)tranas == *(
- unsigned char *)transa;
- isame[3] = *(unsigned char *)diags == *(
- unsigned char *)diag;
- isame[4] = ms == m;
- isame[5] = ns == n;
- isame[6] = als == alpha;
- isame[7] = lde_(&as[1], &aa[1], &laa);
- isame[8] = ldas == lda;
- if (null) {
- isame[9] = lde_(&bs[1], &bb[1], &lbb);
- } else {
- isame[9] = lderes_("GE", " ", &m, &n, &bs[
- 1], &bb[1], &ldb, (ftnlen)2, (
- ftnlen)1);
- }
- isame[10] = ldbs == ldb;
-
-/* If data was incorrectly changed, report and */
-/* return. */
-
- same = TRUE_;
- i__4 = nargs;
- for (i__ = 1; i__ <= i__4; ++i__) {
- same = same && isame[i__ - 1];
- if (! isame[i__ - 1]) {
- printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
- }
-/* L50: */
- }
- if (! same) {
- *fatal = TRUE_;
- goto L150;
- }
-
- if (! null) {
- if (s_cmp(sname + 9, "mm", (ftnlen)2, (
- ftnlen)2) == 0) {
-
-/* Check the result. */
-
- if (left) {
- dmmch_(transa, "N", &m, &n, &m, &
- alpha, &a[a_offset], nmax,
- &b[b_offset], nmax, &
- c_b104, &c__[c_offset],
- nmax, &ct[1], &g[1], &bb[
- 1], &ldb, eps, &err,
- fatal, nout, &c_true, (
- ftnlen)1, (ftnlen)1);
- } else {
- dmmch_("N", transa, &m, &n, &n, &
- alpha, &b[b_offset], nmax,
- &a[a_offset], nmax, &
- c_b104, &c__[c_offset],
- nmax, &ct[1], &g[1], &bb[
- 1], &ldb, eps, &err,
- fatal, nout, &c_true, (
- ftnlen)1, (ftnlen)1);
- }
- } else if (s_cmp(sname + 9, "sm", (ftnlen)
- 2, (ftnlen)2) == 0) {
-
-/* Compute approximation to original */
-/* matrix. */
-
- i__4 = n;
- for (j = 1; j <= i__4; ++j) {
- i__5 = m;
- for (i__ = 1; i__ <= i__5; ++i__)
- {
- c__[i__ + j * c_dim1] = bb[i__ + (j - 1) * ldb];
- bb[i__ + (j - 1) * ldb] = alpha * b[i__ + j *
- b_dim1];
-/* L60: */
- }
-/* L70: */
- }
-
- if (left) {
- dmmch_(transa, "N", &m, &n, &m, &
- c_b90, &a[a_offset], nmax,
- &c__[c_offset], nmax, &
- c_b104, &b[b_offset],
- nmax, &ct[1], &g[1], &bb[
- 1], &ldb, eps, &err,
- fatal, nout, &c_false, (
- ftnlen)1, (ftnlen)1);
- } else {
- dmmch_("N", transa, &m, &n, &n, &
- c_b90, &c__[c_offset],
- nmax, &a[a_offset], nmax,
- &c_b104, &b[b_offset],
- nmax, &ct[1], &g[1], &bb[
- 1], &ldb, eps, &err,
- fatal, nout, &c_false, (
- ftnlen)1, (ftnlen)1);
- }
- }
- errmax = f2cmax(errmax,err);
-/* If got really bad answer, report and */
-/* return. */
- if (*fatal) {
- goto L150;
- }
- }
-
-/* L80: */
- }
-
-/* L90: */
- }
-
-/* L100: */
- }
-
-/* L110: */
+ return pow;
+}
+#ifdef _MSC_VER
+static _Fcomplex cpow_ui(complex x, integer n) {
+ complex pow={1.0,0.0}; unsigned long int u;
+ if(n != 0) {
+ if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i;
+ for(u = n; ; ) {
+ if(u & 01) pow.r *= x.r, pow.i *= x.i;
+ if(u >>= 1) x.r *= x.r, x.i *= x.i;
+ else break;
}
-
-/* L120: */
- }
-
-L130:
- ;
}
-
-/* L140: */
- }
-
-/* Report result. */
-
- if (errmax < *thresh) {
- if (*iorder == 0) {
- printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
- }
- if (*iorder == 1) {
- printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
- }
- } else {
- if (*iorder == 0) {
- printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);
- printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);
- }
- if (*iorder == 1) {
- printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);
- printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);
- }
- }
- goto L160;
-
-L150:
- printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
- if (*trace) {
- dprcn3_(ntra, &nc, sname, iorder, side, uplo, transa, diag, &m, &n, &
- alpha, &lda, &ldb, (ftnlen)12, (ftnlen)1, (ftnlen)1, (ftnlen)
- 1, (ftnlen)1);
- }
-
-L160:
- return 0;
-
-/* 9995 FORMAT( 1X, I6, ': ', A12,'(', 4( '''', A1, ''',' ), 2( I3, ',' ), */
-/* $ F4.1, ', A,', I3, ', B,', I3, ') .' ) */
-
-/* End of DCHK3. */
-
-} /* dchk3_ */
-
-
-/* Subroutine */ void dprcn3_(integer* nout, integer* nc, char* sname, integer* iorder, char* side, char* uplo, char* transa, char* diag, integer* m, integer* n, doublereal* alpha, integer* lda, integer* ldb, ftnlen sname_len, ftnlen side_len, ftnlen uplo_len, ftnlen transa_len, ftnlen diag_len)
-{
-
- /* Local variables */
- static char ca[14], cd[14], cs[14], cu[14], crc[14];
-
- if (*(unsigned char *)side == 'L') {
- s_copy(cs, " CblasLeft", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(cs, " CblasRight", (ftnlen)14, (ftnlen)14);
- }
- if (*(unsigned char *)uplo == 'U') {
- s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14);
- }
- if (*(unsigned char *)transa == 'N') {
- s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14);
- } else if (*(unsigned char *)transa == 'T') {
- s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14);
- }
- if (*(unsigned char *)diag == 'N') {
- s_copy(cd, " CblasNonUnit", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(cd, " CblasUnit", (ftnlen)14, (ftnlen)14);
- }
- if (*iorder == 1) {
- s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
- }
- printf("%6d: %s %s %s %s\n",*nc,sname,crc,cs,cu);
- printf(" %s %s %d %d %4.1f A %d B %d\n",ca,cd,*m,*n,*alpha,*lda,*ldb);
-} /* dprcn3_ */
-
-
-/* Subroutine */ int dchk4_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublereal* alf, integer* nbet, doublereal* bet, integer* nmax, doublereal* a, doublereal* aa, doublereal* as, doublereal* b, doublereal* bb, doublereal* bs, doublereal* c__, doublereal* cc, doublereal* cs, doublereal* ct, doublereal* g, integer* iorder, ftnlen sname_len)
-{
- /* Initialized data */
-
- static char icht[3+1] = "NTC";
- static char ichu[2+1] = "UL";
-
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
- i__3, i__4, i__5;
-
-
- /* Local variables */
- static doublereal beta;
- static integer ldas, ldcs;
- static logical same;
- static doublereal bets;
- static logical tran, null;
- static char uplo[1];
- static integer i__, j, k, n;
- extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*, ftnlen, ftnlen, ftnlen);
- static doublereal alpha;
- extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen);
- static logical isame[13];
- static integer nargs;
- static logical reset;
- static char trans[1];
- static logical upper;
- static char uplos[1];
- extern /* Subroutine */ void dprcn4_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen);
- static integer ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns;
- extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen);
- static doublereal errmax;
- extern /* Subroutine */ void cdsyrk_(integer*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen);
- static char transs[1];
- static integer laa, lda, lcc, ldc;
- extern logical lde_(doublereal*, doublereal*, integer*);
- static doublereal als;
- static integer ict, icu;
- static doublereal err;
-
-/* Tests DSYRK. */
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Parameters .. */
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. Local Scalars .. */
-/* .. Local Arrays .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Scalars in Common .. */
-/* .. Common blocks .. */
-/* .. Data statements .. */
- /* Parameter adjustments */
- --idim;
- --alf;
- --bet;
- --g;
- --ct;
- --cs;
- --cc;
- c_dim1 = *nmax;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
- --bs;
- --bb;
- b_dim1 = *nmax;
- b_offset = 1 + b_dim1 * 1;
- b -= b_offset;
- --as;
- --aa;
- a_dim1 = *nmax;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
-
- /* Function Body */
-/* .. Executable Statements .. */
-
- nargs = 10;
- nc = 0;
- reset = TRUE_;
- errmax = 0.;
-
- i__1 = *nidim;
- for (in = 1; in <= i__1; ++in) {
- n = idim[in];
-/* Set LDC to 1 more than minimum value if room. */
- ldc = n;
- if (ldc < *nmax) {
- ++ldc;
- }
-/* Skip tests if not enough room. */
- if (ldc > *nmax) {
- goto L100;
- }
- lcc = ldc * n;
- null = n <= 0;
-
- i__2 = *nidim;
- for (ik = 1; ik <= i__2; ++ik) {
- k = idim[ik];
-
- for (ict = 1; ict <= 3; ++ict) {
- *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1];
- tran = *(unsigned char *)trans == 'T' || *(unsigned char *)
- trans == 'C';
- if (tran) {
- ma = k;
- na = n;
- } else {
- ma = n;
- na = k;
- }
-/* Set LDA to 1 more than minimum value if room. */
- lda = ma;
- if (lda < *nmax) {
- ++lda;
- }
-/* Skip tests if not enough room. */
- if (lda > *nmax) {
- goto L80;
- }
- laa = lda * na;
-
-/* Generate the matrix A. */
-
- dmake_("GE", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[1], &
- lda, &reset, &c_b104, (ftnlen)2, (ftnlen)1, (ftnlen)1)
- ;
-
- for (icu = 1; icu <= 2; ++icu) {
- *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];
- upper = *(unsigned char *)uplo == 'U';
-
- i__3 = *nalf;
- for (ia = 1; ia <= i__3; ++ia) {
- alpha = alf[ia];
-
- i__4 = *nbet;
- for (ib = 1; ib <= i__4; ++ib) {
- beta = bet[ib];
-
-/* Generate the matrix C. */
-
- dmake_("SY", uplo, " ", &n, &n, &c__[c_offset],
- nmax, &cc[1], &ldc, &reset, &c_b104, (
- ftnlen)2, (ftnlen)1, (ftnlen)1);
-
- ++nc;
-
-/* Save every datum before calling the subroutine. */
-
- *(unsigned char *)uplos = *(unsigned char *)uplo;
- *(unsigned char *)transs = *(unsigned char *)
- trans;
- ns = n;
- ks = k;
- als = alpha;
- i__5 = laa;
- for (i__ = 1; i__ <= i__5; ++i__) {
- as[i__] = aa[i__];
-/* L10: */
- }
- ldas = lda;
- bets = beta;
- i__5 = lcc;
- for (i__ = 1; i__ <= i__5; ++i__) {
- cs[i__] = cc[i__];
-/* L20: */
- }
- ldcs = ldc;
-
-/* Call the subroutine. */
-
- if (*trace) {
- dprcn4_(ntra, &nc, sname, iorder, uplo, trans,
- &n, &k, &alpha, &lda, &beta, &ldc, (
- ftnlen)12, (ftnlen)1, (ftnlen)1);
- }
- if (*rewi) {
-/* al__1.aerr = 0;
- al__1.aunit = *ntra;
- f_rew(&al__1);*/
- }
- cdsyrk_(iorder, uplo, trans, &n, &k, &alpha, &aa[
- 1], &lda, &beta, &cc[1], &ldc, (ftnlen)1,
- (ftnlen)1);
-
-/* Check if error-exit was taken incorrectly. */
-
- if (! infoc_1.ok) {
- printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");
- *fatal = TRUE_;
- goto L120;
- }
-
-/* See what data changed inside subroutines. */
-
- isame[0] = *(unsigned char *)uplos == *(unsigned
- char *)uplo;
- isame[1] = *(unsigned char *)transs == *(unsigned
- char *)trans;
- isame[2] = ns == n;
- isame[3] = ks == k;
- isame[4] = als == alpha;
- isame[5] = lde_(&as[1], &aa[1], &laa);
- isame[6] = ldas == lda;
- isame[7] = bets == beta;
- if (null) {
- isame[8] = lde_(&cs[1], &cc[1], &lcc);
- } else {
- isame[8] = lderes_("SY", uplo, &n, &n, &cs[1],
- &cc[1], &ldc, (ftnlen)2, (ftnlen)1);
- }
- isame[9] = ldcs == ldc;
-
-/* If data was incorrectly changed, report and */
-/* return. */
-
- same = TRUE_;
- i__5 = nargs;
- for (i__ = 1; i__ <= i__5; ++i__) {
- same = same && isame[i__ - 1];
- if (! isame[i__ - 1]) {
- printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
- }
-/* L30: */
- }
- if (! same) {
- *fatal = TRUE_;
- goto L120;
- }
-
- if (! null) {
-
-/* Check the result column by column. */
-
- jc = 1;
- i__5 = n;
- for (j = 1; j <= i__5; ++j) {
- if (upper) {
- jj = 1;
- lj = j;
- } else {
- jj = j;
- lj = n - j + 1;
- }
- if (tran) {
- dmmch_("T", "N", &lj, &c__1, &k, &
- alpha, &a[jj * a_dim1 + 1],
- nmax, &a[j * a_dim1 + 1],
- nmax, &beta, &c__[jj + j *
- c_dim1], nmax, &ct[1], &g[1],
- &cc[jc], &ldc, eps, &err,
- fatal, nout, &c_true, (ftnlen)
- 1, (ftnlen)1);
- } else {
- dmmch_("N", "T", &lj, &c__1, &k, &
- alpha, &a[jj + a_dim1], nmax,
- &a[j + a_dim1], nmax, &beta, &
- c__[jj + j * c_dim1], nmax, &
- ct[1], &g[1], &cc[jc], &ldc,
- eps, &err, fatal, nout, &
- c_true, (ftnlen)1, (ftnlen)1);
- }
- if (upper) {
- jc += ldc;
- } else {
- jc = jc + ldc + 1;
- }
- errmax = f2cmax(errmax,err);
-/* If got really bad answer, report and */
-/* return. */
- if (*fatal) {
- goto L110;
- }
-/* L40: */
- }
- }
-
-/* L50: */
- }
-
-/* L60: */
- }
-
-/* L70: */
+ _Fcomplex p={pow.r, pow.i};
+ return p;
+}
+#else
+static _Complex float cpow_ui(_Complex float x, integer n) {
+ _Complex float pow=1.0; unsigned long int u;
+ if(n != 0) {
+ if(n < 0) n = -n, x = 1/x;
+ for(u = n; ; ) {
+ if(u & 01) pow *= x;
+ if(u >>= 1) x *= x;
+ else break;
}
-
-L80:
- ;
- }
-
-/* L90: */
}
-
-L100:
- ;
- }
-
-/* Report result. */
-
- if (errmax < *thresh) {
- if (*iorder == 0) {
- printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
- }
- if (*iorder == 1) {
- printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
+ return pow;
+}
+#endif
+#ifdef _MSC_VER
+static _Dcomplex zpow_ui(_Dcomplex x, integer n) {
+ _Dcomplex pow={1.0,0.0}; unsigned long int u;
+ if(n != 0) {
+ if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1];
+ for(u = n; ; ) {
+ if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1];
+ if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1];
+ else break;
+ }
}
- } else {
- if (*iorder == 0) {
- printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);
- printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);
+ _Dcomplex p = {pow._Val[0], pow._Val[1]};
+ return p;
+}
+#else
+static _Complex double zpow_ui(_Complex double x, integer n) {
+ _Complex double pow=1.0; unsigned long int u;
+ if(n != 0) {
+ if(n < 0) n = -n, x = 1/x;
+ for(u = n; ; ) {
+ if(u & 01) pow *= x;
+ if(u >>= 1) x *= x;
+ else break;
+ }
}
- if (*iorder == 1) {
- printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);
- printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);
+ return pow;
+}
+#endif
+static integer pow_ii(integer x, integer n) {
+ integer pow; unsigned long int u;
+ if (n <= 0) {
+ if (n == 0 || x == 1) pow = 1;
+ else if (x != -1) pow = x == 0 ? 1/x : 0;
+ else n = -n;
+ }
+ if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+ u = n;
+ for(pow = 1; ; ) {
+ if(u & 01) pow *= x;
+ if(u >>= 1) x *= x;
+ else break;
+ }
}
- }
- goto L130;
-
-L110:
- if (n > 1) {
- printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j);
- }
-
-L120:
- printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
- dprcn4_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &
- beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1);
-
-L130:
- return 0;
-
-/* 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */
-/* $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' ) */
-
-/* End of DCHK4. */
-
-} /* dchk4_ */
-
-
-/* Subroutine */ void dprcn4_(integer* nout, integer* nc, char* sname, integer* iorder, char* uplo, char* transa, integer* n, integer* k, doublereal* alpha, integer* lda, doublereal* beta, integer* ldc, ftnlen sname_len, ftnlen uplo_len, ftnlen transa_len)
+ return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
{
-
- /* Local variables */
- static char ca[14], cu[14], crc[14];
-
- if (*(unsigned char *)uplo == 'U') {
- s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14);
- }
- if (*(unsigned char *)transa == 'N') {
- s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14);
- } else if (*(unsigned char *)transa == 'T') {
- s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14);
- }
- if (*iorder == 1) {
- s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
- }
- printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca);
- printf("( %d %d %4.1f A %d %4.1f C %d\n",*n,*k,*alpha,*lda,*beta,*ldc);
-} /* dprcn4_ */
-
-
-/* Subroutine */ int dchk5_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublereal* alf, integer* nbet, doublereal* bet, integer* nmax, doublereal* ab, doublereal* aa, doublereal* as, doublereal* bb, doublereal* bs, doublereal* c__, doublereal* cc, doublereal* cs, doublereal* ct, doublereal* g, doublereal* w, integer* iorder, ftnlen sname_len)
+ double m; integer i, mi;
+ for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+ if (w[i-1]>m) mi=i ,m=w[i-1];
+ return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
{
- /* Initialized data */
-
- static char icht[3+1] = "NTC";
- static char ichu[2+1] = "UL";
-
- /* System generated locals */
- integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8;
-
-
- /* Local variables */
- static integer jjab;
- static doublereal beta;
- static integer ldas, ldbs, ldcs;
- static logical same;
- static doublereal bets;
- static logical tran, null;
- static char uplo[1];
- static integer i__, j, k, n;
- extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*, ftnlen, ftnlen, ftnlen);
- static doublereal alpha;
- extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen);
- static logical isame[13];
- static integer nargs;
- static logical reset;
- static char trans[1];
- static logical upper;
- static char uplos[1];
- extern /* Subroutine */ void dprcn5_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublereal*, integer*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen);
- static integer ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns;
- extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen);
- static doublereal errmax;
- static char transs[1];
- static integer laa, lbb, lda, lcc, ldb, ldc;
- extern logical lde_(doublereal*, doublereal*, integer*);
- extern /* Subroutine */ void cdsyr2k_(integer*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen);
- static doublereal als;
- static integer ict, icu;
- static doublereal err;
-
-/* Tests DSYR2K. */
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Parameters .. */
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. Local Scalars .. */
-/* .. Local Arrays .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Scalars in Common .. */
-/* .. Common blocks .. */
-/* .. Data statements .. */
- /* Parameter adjustments */
- --idim;
- --alf;
- --bet;
- --w;
- --g;
- --ct;
- --cs;
- --cc;
- c_dim1 = *nmax;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
- --bs;
- --bb;
- --as;
- --aa;
- --ab;
-
- /* Function Body */
-/* .. Executable Statements .. */
-
- nargs = 12;
- nc = 0;
- reset = TRUE_;
- errmax = 0.;
-
- i__1 = *nidim;
- for (in = 1; in <= i__1; ++in) {
- n = idim[in];
-/* Set LDC to 1 more than minimum value if room. */
- ldc = n;
- if (ldc < *nmax) {
- ++ldc;
- }
-/* Skip tests if not enough room. */
- if (ldc > *nmax) {
- goto L130;
- }
- lcc = ldc * n;
- null = n <= 0;
-
- i__2 = *nidim;
- for (ik = 1; ik <= i__2; ++ik) {
- k = idim[ik];
-
- for (ict = 1; ict <= 3; ++ict) {
- *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1];
- tran = *(unsigned char *)trans == 'T' || *(unsigned char *)
- trans == 'C';
- if (tran) {
- ma = k;
- na = n;
- } else {
- ma = n;
- na = k;
- }
-/* Set LDA to 1 more than minimum value if room. */
- lda = ma;
- if (lda < *nmax) {
- ++lda;
- }
-/* Skip tests if not enough room. */
- if (lda > *nmax) {
- goto L110;
+ float m; integer i, mi;
+ for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+ if (w[i-1]>m) mi=i ,m=w[i-1];
+ return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+ integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+ _Fcomplex zdotc = {0.0, 0.0};
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<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];
}
- 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);
+ } 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];
}
-
-/* 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);
+ }
+ 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]);
}
-
- 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: */
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
}
-
-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_(integer* nout, integer* nc, char* sname, integer* iorder, char* uplo, char* transa, integer* n, integer* k, doublereal* alpha, integer* lda, integer* ldb, doublereal* beta, integer* ldc, ftnlen sname_len, ftnlen uplo_len, ftnlen transa_len)
-{
-
- /* Local variables */
- static char ca[14], cu[14], crc[14];
-
- if (*(unsigned char *)uplo == 'U') {
- s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14);
- }
- if (*(unsigned char *)transa == 'N') {
- s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14);
- } else if (*(unsigned char *)transa == 'T') {
- s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14);
- }
- if (*iorder == 1) {
- s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
- }
- printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca);
- printf("%d %d %4.1f , A, %d, B, %d, %4.1f , C, %d.\n",*n,*k,*alpha,*lda,*ldb,*beta,*ldc);
-} /* dprcn5_ */
-
-
-/* Subroutine */ int dmake_(char* type__, char* uplo, char* diag, integer* m, integer* n, doublereal* a, integer* nmax, doublereal* aa, integer* lda, logical* reset, doublereal* transl, ftnlen type_len, ftnlen uplo_len, ftnlen diag_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2;
-
- /* Local variables */
- extern doublereal dbeg_(logical*);
- static integer ibeg, iend;
- static logical unit;
- static integer i__, j;
- static logical lower, upper, gen, tri, sym;
-
-
-/* Generates values for an M by N matrix A. */
-/* Stores the values in the array AA in the data structure required */
-/* by the routine, with unwanted elements set to rogue value. */
-
-/* TYPE is 'GE', 'SY' or 'TR'. */
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Parameters .. */
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. Executable Statements .. */
- /* Parameter adjustments */
- a_dim1 = *nmax;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- --aa;
-
- /* Function Body */
- gen = s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0;
- sym = s_cmp(type__, "SY", (ftnlen)2, (ftnlen)2) == 0;
- tri = s_cmp(type__, "TR", (ftnlen)2, (ftnlen)2) == 0;
- upper = (sym || tri) && *(unsigned char *)uplo == 'U';
- lower = (sym || tri) && *(unsigned char *)uplo == 'L';
- unit = tri && *(unsigned char *)diag == 'U';
-
-/* Generate data in array A. */
-
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- if (gen || (upper && i__ <= j) || (lower && i__ >= j)) {
- a[i__ + j * a_dim1] = dbeg_(reset) + *transl;
- if (i__ != j) {
-/* Set some elements to zero */
- if (*n > 3 && j == *n / 2) {
- a[i__ + j * a_dim1] = 0.;
- }
- if (sym) {
- a[j + i__ * a_dim1] = a[i__ + j * a_dim1];
- } else if (tri) {
- a[j + i__ * a_dim1] = 0.;
- }
+ pCf(z) = zdotc;
+}
+#endif
+static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
+ integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+ _Dcomplex zdotc = {0.0, 0.0};
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<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];
}
- }
-/* 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;
+ 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 {
- if (unit) {
- ibeg = j + 1;
- } else {
- ibeg = j;
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
}
- 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_(char* transa, char* transb, integer* m, integer* n, integer* kk, doublereal* alpha, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* beta, doublereal* c__, integer* ldc, doublereal* ct, doublereal* g, doublereal* cc, integer* ldcc, doublereal* eps, doublereal* err, logical* fatal, integer* nout, logical* mv, ftnlen transa_len, ftnlen transb_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, cc_dim1,
- cc_offset, i__1, i__2, i__3;
- doublereal d__1, d__2;
-
- /* Builtin functions */
- double sqrt(double);
-
- /* 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: */
+ 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];
}
-/* 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: */
+ } 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];
}
-/* 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: */
+ }
+ 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]);
}
-/* 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: */
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
}
-/* 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]);
+ 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 {
- 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_(doublereal* ri, doublereal* rj, integer* lr)
-{
- /* System generated locals */
- integer i__1;
- logical ret_val;
-
- /* Local variables */
- static integer i__;
-
-
-/* Tests if two arrays are identical. */
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. Local Scalars .. */
-/* .. Executable Statements .. */
- /* Parameter adjustments */
- --rj;
- --ri;
-
- /* Function Body */
- i__1 = *lr;
- for (i__ = 1; i__ <= i__1; ++i__) {
- if (ri[i__] != rj[i__]) {
- goto L20;
- }
-/* L10: */
- }
- ret_val = TRUE_;
- goto L30;
-L20:
- ret_val = FALSE_;
-L30:
- return ret_val;
-
-/* End of LDE. */
-
-} /* lde_ */
-
-logical lderes_(char* type__, char* uplo, integer* m, integer* n, doublereal* aa, doublereal* as, integer* lda, ftnlen type_len, ftnlen uplo_len)
-{
- /* System generated locals */
- integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2;
- logical ret_val;
-
- /* Local variables */
- static integer ibeg, iend, i__, j;
- static logical upper;
-
-
-/* Tests if selected elements in two arrays are equal. */
-
-/* TYPE is 'GE' or 'SY'. */
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. Local Scalars .. */
-/* .. Executable Statements .. */
- /* Parameter adjustments */
- as_dim1 = *lda;
- as_offset = 1 + as_dim1 * 1;
- as -= as_offset;
- aa_dim1 = *lda;
- aa_offset = 1 + aa_dim1 * 1;
- aa -= aa_offset;
-
- /* Function Body */
- upper = *(unsigned char *)uplo == 'U';
- if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *lda;
- for (i__ = *m + 1; i__ <= i__2; ++i__) {
- if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) {
- goto L70;
+ for (i=0;i<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];
}
-/* 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;
+ 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]);
}
-/* 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;
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
}
-/* L40: */
- }
-/* L50: */
}
- }
-
-/* 60 CONTINUE */
- ret_val = TRUE_;
- goto L80;
-L70:
- ret_val = FALSE_;
-L80:
- return ret_val;
-
-/* End of LDERES. */
-
-} /* lderes_ */
-
-doublereal dbeg_(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_(doublereal* x, doublereal* y)
-{
- /* System generated locals */
- doublereal ret_val;
-
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Scalar Arguments .. */
-/* .. Executable Statements .. */
- ret_val = *x - *y;
- return ret_val;
+ pCd(z) = zdotc;
+}
+#endif
+/* -- translated by f2c (version 20000121).
+ You must link the resulting object file with the libraries:
+ -lf2c -lm (in that order)
+*/
-/* End of DDIFF. */
-} /* ddiff_ */
-/* Main program alias */ /*int dblat3_ () { MAIN__ (); }*/
diff --git a/ctest/c_sblat3c.c b/ctest/c_sblat3c.c
index 402c58c8b5..447b23014f 100644
--- a/ctest/c_sblat3c.c
+++ b/ctest/c_sblat3c.c
@@ -10,7 +10,25 @@
#undef I
#endif
-#include "common.h"
+#if defined(_WIN64)
+typedef long long BLASLONG;
+typedef unsigned long long BLASULONG;
+#else
+typedef long BLASLONG;
+typedef unsigned long BLASULONG;
+#endif
+
+#ifdef LAPACK_ILP64
+typedef BLASLONG blasint;
+#if defined(_WIN64)
+#define blasabs(x) llabs(x)
+#else
+#define blasabs(x) labs(x)
+#endif
+#else
+typedef int blasint;
+#define blasabs(x) abs(x)
+#endif
typedef blasint integer;
@@ -229,6 +247,7 @@ typedef struct Namelist Namelist;
#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
#define sig_die(s, kill) { exit(1); }
#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
#define z_abs(z) (cabs(Cd(z)))
#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
@@ -242,3092 +261,251 @@ typedef struct Namelist Namelist;
/* procedure parameter types for -A and -C++ */
#define F2C_proc_par_types 1
-
-
-/* Common Block Declarations */
-
-struct {
- integer infot, noutc;
- logical ok;
-} infoc_;
-
-#define infoc_1 infoc_
-
-struct {
- char srnamt[12];
-} srnamc_;
-
-#define srnamc_1 srnamc_
-
-/* Table of constant values */
-
-static integer c__1 = 1;
-static integer c__65 = 65;
-static real c_b89 = (float)1.;
-static real c_b103 = (float)0.;
-static integer c__6 = 6;
-static logical c_true = TRUE_;
-static integer c__0 = 0;
-static logical c_false = FALSE_;
-
-/* Main program MAIN__() */ int main(void)
-{
- /* Initialized data */
-
- static char snames[6][13] = {"cblas_sgemm ", "cblas_ssymm ", "cblas_strmm ", "cblas_strsm ", "cblas_ssyrk ", "cblas_ssyr2k"};
-
- /* System generated locals */
- integer i__1, i__2, i__3;
- real r__1;
-
- /* Local variables */
- static integer nalf, idim[9];
- static logical same;
- static integer nbet, ntra;
- static logical rewi;
- extern /* Subroutine */ int schk1_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, real*, integer*, real*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*, ftnlen);
- extern /* Subroutine */ int schk2_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, real*, integer*, real*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*, ftnlen);
- extern /* Subroutine */ int schk3_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, real*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*, ftnlen);
- extern /* Subroutine */ int schk4_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, real*, integer*, real*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*, ftnlen);
- extern /* Subroutine */ int schk5_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, real*, integer*, real*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*, ftnlen);
- static real c__[4225] /* was [65][65] */, g[65];
- static integer i__, j, n;
- static logical fatal;
- static real w[130];
- extern doublereal sdiff_(real*, real*);
- static logical trace;
- static integer nidim;
- extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*, ftnlen, ftnlen);
- static char snaps[32];
- static integer isnum;
- static logical ltest[6];
- static real aa[4225], ab[8450] /* was [65][130] */, bb[4225], cc[
- 4225], as[4225], bs[4225], cs[4225], ct[65];
- static logical sfatal, corder;
- static char snamet[12], transa[1], transb[1];
- static real thresh;
- static logical rorder;
- static integer layout;
- static logical ltestt, tsterr;
- extern /* Subroutine */ void cs3chke_(char*, ftnlen);
- static real alf[7], bet[7];
- extern logical lse_(real*, real*, integer*);
- static real eps, err;
- char tmpchar;
-
-/* Test program for the REAL Level 3 Blas. */
-
-/* The program must be driven by a short data file. The first 13 records */
-/* of the file are read using list-directed input, the last 6 records */
-/* are read using the format ( A12, L2 ). An annotated example of a data */
-/* file can be obtained by deleting the first 3 characters from the */
-/* following 19 lines: */
-/* 'SBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE */
-/* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) */
-/* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. */
-/* F LOGICAL FLAG, T TO STOP ON FAILURES. */
-/* T LOGICAL FLAG, T TO TEST ERROR EXITS. */
-/* 2 0 TO TEST COLUMN-MAJOR, 1 TO TEST ROW-MAJOR, 2 TO TEST BOTH */
-/* 16.0 THRESHOLD VALUE OF TEST RATIO */
-/* 6 NUMBER OF VALUES OF N */
-/* 0 1 2 3 5 9 VALUES OF N */
-/* 3 NUMBER OF VALUES OF ALPHA */
-/* 0.0 1.0 0.7 VALUES OF ALPHA */
-/* 3 NUMBER OF VALUES OF BETA */
-/* 0.0 1.0 1.3 VALUES OF BETA */
-/* cblas_sgemm T PUT F FOR NO TEST. SAME COLUMNS. */
-/* cblas_ssymm T PUT F FOR NO TEST. SAME COLUMNS. */
-/* cblas_strmm T PUT F FOR NO TEST. SAME COLUMNS. */
-/* cblas_strsm T PUT F FOR NO TEST. SAME COLUMNS. */
-/* cblas_ssyrk T PUT F FOR NO TEST. SAME COLUMNS. */
-/* cblas_ssyr2k T PUT F FOR NO TEST. SAME COLUMNS. */
-
-/* See: */
-
-/* Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. */
-/* A Set of Level 3 Basic Linear Algebra Subprograms. */
-
-/* Technical Memorandum No.88 (Revision 1), Mathematics and */
-/* Computer Science Division, Argonne National Laboratory, 9700 */
-/* South Cass Avenue, Argonne, Illinois 60439, US. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. Local Arrays .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Scalars in Common .. */
-/* .. Common blocks .. */
-/* .. Data statements .. */
-/* .. Executable Statements .. */
-
- infoc_1.noutc = 6;
-/* Read name and unit number for summary output file and open file. */
-
- char line[80];
-
- fgets(line,80,stdin);
- sscanf(line,"'%s'",snaps);
- fgets(line,80,stdin);
-#ifdef USE64BITINT
- sscanf(line,"%ld",&ntra);
-#else
- sscanf(line,"%d",&ntra);
-#endif
- trace = ntra >= 0;
- if (trace) {
-/* OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' ) */
-/* o__1.ounit = ntra;
- o__1.ofnmlen = 32;
- o__1.ofnm = snaps;
- o__1.orl = 0;
- o__1.osta = 0;
- o__1.oacc = 0;
- o__1.ofm = 0;
- o__1.oblnk = 0;
- f_open(&o__1);*/
- }
-/* Read the flag that directs rewinding of the snapshot file. */
- fgets(line,80,stdin);
- sscanf(line,"%d",&rewi);
- rewi = rewi && trace;
-/* Read the flag that directs stopping on any failure. */
- fgets(line,80,stdin);
- sscanf(line,"%c",&tmpchar);
-/* Read the flag that indicates whether error exits are to be tested. */
- sfatal=FALSE_;
- if (tmpchar=='T')sfatal=TRUE_;
- fgets(line,80,stdin);
- sscanf(line,"%c",&tmpchar);
-/* Read the flag that indicates whether error exits are to be tested. */
- tsterr=FALSE_;
- if (tmpchar=='T')tsterr=TRUE_;
-/* Read the flag that indicates whether row-major data layout to be tested. */
- fgets(line,80,stdin);
- sscanf(line,"%d",&layout);
-/* Read the threshold value of the test ratio */
- fgets(line,80,stdin);
- sscanf(line,"%f",&thresh);
-
-/* Read and check the parameter values for the tests. */
-
-/* Values of N */
- fgets(line,80,stdin);
-#ifdef USE64BITINT
- sscanf(line,"%ld",&nidim);
-#else
- sscanf(line,"%d",&nidim);
-#endif
-
- if (nidim < 1 || nidim > 9) {
- fprintf(stderr,"NUMBER OF VALUES OF N IS LESS THAN 1 OR GREATER THAN 9");
- goto L220;
- }
- fgets(line,80,stdin);
-#ifdef USE64BITINT
- sscanf(line,"%ld %ld %ld %ld %ld %ld %ld %ld %ld",&idim[0],&idim[1],&idim[2],
- &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]);
-#else
- sscanf(line,"%d %d %d %d %d %d %d %d %d",&idim[0],&idim[1],&idim[2],
- &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]);
-#endif
- i__1 = nidim;
- for (i__ = 1; i__ <= i__1; ++i__) {
- if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) {
- fprintf(stderr,"VALUE OF N IS LESS THAN 0 OR GREATER THAN 65\n");
- goto L220;
- }
-/* L10: */
- }
-/* Values of ALPHA */
- fgets(line,80,stdin);
-#ifdef USE64BITINT
- sscanf(line,"%ld",&nalf);
-#else
- sscanf(line,"%d",&nalf);
-#endif
- if (nalf < 1 || nalf > 7) {
- fprintf(stderr,"VALUE OF ALPHA IS LESS THAN 0 OR GREATER THAN 7\n");
- goto L220;
- }
- fgets(line,80,stdin);
- sscanf(line,"%f %f %f %f %f %f %f",&alf[0],&alf[1],&alf[2],&alf[3],&alf[4],&alf[5],&alf[6]);
-
-/* Values of BETA */
- fgets(line,80,stdin);
-#ifdef USE64BITINT
- sscanf(line,"%ld",&nbet);
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
#else
- sscanf(line,"%d",&nbet);
+typedef logical (*L_fp)();
#endif
- if (nalf < 1 || nbet > 7) {
- fprintf(stderr,"VALUE OF BETA IS LESS THAN 0 OR GREATER THAN 7\n");
- goto L220;
- }
- fgets(line,80,stdin);
- sscanf(line,"%f %f %f %f %f %f %f",&bet[0],&bet[1],&bet[2],&bet[3],&bet[4],&bet[5],&bet[6]);
-
-/* Report values of parameters. */
- printf("TESTS OF THE REAL LEVEL 3 BLAS\nTHE FOLLOWING PARAMETER VALUES WILL BE USED:\n");
- printf(" FOR N");
- for (i__ =1; i__ <=nidim;++i__) printf(" %d",idim[i__-1]);
- printf("\n");
- printf(" FOR ALPHA");
- for (i__ =1; i__ <=nalf;++i__) printf(" %f",alf[i__-1]);
- printf("\n");
- printf(" FOR BETA");
- for (i__ =1; i__ <=nbet;++i__) printf(" %f",bet[i__-1]);
- printf("\n");
-
- if (! tsterr) {
- printf(" ERROR-EXITS WILL NOT BE TESTED\n");
- }
- printf("ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LESS THAN %f\n",thresh);
- rorder = FALSE_;
- corder = FALSE_;
- if (layout == 2) {
- rorder = TRUE_;
- corder = TRUE_;
- printf("COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED\n");
- } else if (layout == 1) {
- rorder = TRUE_;
- printf("ROW-MAJOR DATA LAYOUT IS TESTED\n");
- } else if (layout == 0) {
- corder = TRUE_;
- printf("COLUMN-MAJOR DATA LAYOUT IS TESTED\n");
- }
-
-
-/* Read names of subroutines and flags which indicate */
-/* whether they are to be tested. */
-
- for (i__ = 1; i__ <= 6; ++i__) {
- ltest[i__ - 1] = FALSE_;
-/* L20: */
- }
-L30:
- if (! fgets(line,80,stdin)) {
- goto L60;
- }
- i__1 = sscanf(line,"%12c %c",snamet,&tmpchar);
- ltestt=FALSE_;
- if (tmpchar=='T')ltestt=TRUE_;
- if (i__1 < 2) {
- goto L60;
- }
- for (i__ = 1; i__ <= 9; ++i__) {
- if (s_cmp(snamet, snames[i__ - 1] , (ftnlen)12, (ftnlen)12) ==
- 0) {
- goto L50;
- }
-/* L40: */
- }
- printf("SUBPROGRAM NAME %s NOT RECOGNIZED\n****** TESTS ABANDONED ******\n",snamet);
- exit(1);
-
-L50:
- ltest[i__ - 1] = ltestt;
- goto L30;
-
-L60:
-// f_clos(&cl__1);
-/* Compute EPS (the machine precision). */
-
- eps = (float)1.;
-L70:
- r__1 = eps + (float)1.;
- if (sdiff_(&r__1, &c_b89) == (float)0.) {
- goto L80;
- }
- eps *= (float).5;
- goto L70;
-L80:
- eps += eps;
- printf("RELATIVE MACHINE PRECISION IS TAKEN TO BE %9.1g\n",eps);
-
-/* Check the reliability of SMMCH using exact data. */
-
- n = 32;
- i__1 = n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = n;
- for (i__ = 1; i__ <= i__2; ++i__) {
-/* Computing MAX */
- i__3 = i__ - j + 1;
- ab[i__ + j * 65 - 66] = (real) f2cmax(i__3,0);
-/* L90: */
+static float spow_ui(float x, integer n) {
+ float pow=1.0; unsigned long int u;
+ if(n != 0) {
+ if(n < 0) n = -n, x = 1/x;
+ for(u = n; ; ) {
+ if(u & 01) pow *= x;
+ if(u >>= 1) x *= x;
+ else break;
+ }
}
- ab[j + 4224] = (real) j;
- ab[(j + 65) * 65 - 65] = (real) j;
- c__[j - 1] = (float)0.;
-/* L100: */
- }
- i__1 = n;
- for (j = 1; j <= i__1; ++j) {
- cc[j - 1] = (real) (j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3)
- ;
-/* L110: */
- }
-/* CC holds the exact result. On exit from SMMCH CT holds */
-/* the result computed by SMMCH. */
- *(unsigned char *)transa = 'N';
- *(unsigned char *)transb = 'N';
- smmch_(transa, transb, &n, &c__1, &n, &c_b89, ab, &c__65, &ab[4225], &
- c__65, &c_b103, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &
- fatal, &c__6, &c_true, (ftnlen)1, (ftnlen)1);
- same = lse_(cc, ct, &n);
- if (! same || err != (float)0.) {
- printf("ERROR IN SMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n");
- printf("SMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb);
- printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err);
- printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n");
- printf("****** TESTS ABANDONED ******\n");
- exit(1);
- }
- *(unsigned char *)transb = 'T';
- smmch_(transa, transb, &n, &c__1, &n, &c_b89, ab, &c__65, &ab[4225], &
- c__65, &c_b103, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &
- fatal, &c__6, &c_true, (ftnlen)1, (ftnlen)1);
- same = lse_(cc, ct, &n);
- if (! same || err != (float)0.) {
- printf("ERROR IN SMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n");
- printf("SMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb);
- printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err);
- printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n");
- printf("****** TESTS ABANDONED ******\n");
- exit(1);
- }
- i__1 = n;
- for (j = 1; j <= i__1; ++j) {
- ab[j + 4224] = (real) (n - j + 1);
- ab[(j + 65) * 65 - 65] = (real) (n - j + 1);
-/* L120: */
- }
- i__1 = n;
- for (j = 1; j <= i__1; ++j) {
- cc[n - j] = (real) (j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3)
- ;
-/* L130: */
- }
- *(unsigned char *)transa = 'T';
- *(unsigned char *)transb = 'N';
- smmch_(transa, transb, &n, &c__1, &n, &c_b89, ab, &c__65, &ab[4225], &
- c__65, &c_b103, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &
- fatal, &c__6, &c_true, (ftnlen)1, (ftnlen)1);
- same = lse_(cc, ct, &n);
- if (! same || err != (float)0.) {
- printf("ERROR IN SMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n");
- printf("SMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb);
- printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err);
- printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n");
- printf("****** TESTS ABANDONED ******\n");
- exit(1);
- }
- *(unsigned char *)transb = 'T';
- smmch_(transa, transb, &n, &c__1, &n, &c_b89, ab, &c__65, &ab[4225], &
- c__65, &c_b103, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &
- fatal, &c__6, &c_true, (ftnlen)1, (ftnlen)1);
- same = lse_(cc, ct, &n);
- if (! same || err != (float)0.) {
- printf("ERROR IN SMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n");
- printf("SMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb);
- printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err);
- printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n");
- printf("****** TESTS ABANDONED ******\n");
- exit(1);
- }
-
-/* Test each subroutine in turn. */
-
- for (isnum = 1; isnum <= 6; ++isnum) {
- if (! ltest[isnum - 1]) {
-/* Subprogram is not to be tested. */
- printf("%12s WAS NOT TESTED\n",snames[isnum-1]);
- } else {
- s_copy(srnamc_1.srnamt, snames[isnum - 1], (ftnlen)12, (
- ftnlen)12);
-/* Test error exits. */
- if (tsterr) {
- cs3chke_(snames[isnum - 1], (ftnlen)12);
- }
-/* Test computations. */
- infoc_1.infot = 0;
- infoc_1.ok = TRUE_;
- fatal = FALSE_;
- switch ((int)isnum) {
- case 1: goto L140;
- case 2: goto L150;
- case 3: goto L160;
- case 4: goto L160;
- case 5: goto L170;
- case 6: goto L180;
- }
-/* Test SGEMM, 01. */
-L140:
- if (corder) {
- schk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,
- cc, cs, ct, g, &c__0, (ftnlen)12);
- }
- if (rorder) {
- schk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,
- cc, cs, ct, g, &c__1, (ftnlen)12);
- }
- goto L190;
-/* Test SSYMM, 02. */
-L150:
- if (corder) {
- schk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,
- cc, cs, ct, g, &c__0, (ftnlen)12);
- }
- if (rorder) {
- schk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,
- cc, cs, ct, g, &c__1, (ftnlen)12);
- }
- goto L190;
-/* Test STRMM, 03, STRSM, 04. */
-L160:
- if (corder) {
- schk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, &
- c__0, (ftnlen)12);
- }
- if (rorder) {
- schk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, &
- c__1, (ftnlen)12);
- }
- goto L190;
-/* Test SSYRK, 05. */
-L170:
- if (corder) {
- schk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,
- cc, cs, ct, g, &c__0, (ftnlen)12);
- }
- if (rorder) {
- schk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,
- cc, cs, ct, g, &c__1, (ftnlen)12);
- }
- goto L190;
-/* Test SSYR2K, 06. */
-L180:
- if (corder) {
- schk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs,
- ct, g, w, &c__0, (ftnlen)12);
- }
- if (rorder) {
- schk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs,
- ct, g, w, &c__1, (ftnlen)12);
- }
- goto L190;
-
-L190:
- if (fatal && sfatal) {
- goto L210;
- }
+ return pow;
+}
+static double dpow_ui(double x, integer n) {
+ double pow=1.0; unsigned long int u;
+ if(n != 0) {
+ if(n < 0) n = -n, x = 1/x;
+ for(u = n; ; ) {
+ if(u & 01) pow *= x;
+ if(u >>= 1) x *= x;
+ else break;
+ }
}
-/* L200: */
- }
- printf("\nEND OF TESTS\n");
- goto L230;
-
-L210:
- printf("\n****** FATAL ERROR - TESTS ABANDONED ******\n");
- goto L230;
-
-L220:
- printf("AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM\n");
- printf("****** TESTS ABANDONED ******\n");
-
-L230:
- if (trace) {
-// f_clos(&cl__1);
- }
-// f_clos(&cl__1);
- exit(0);
-
-/* End of SBLAT3. */
-
-} /* MAIN__ */
-
-/* Subroutine */ int schk1_(char* sname, real* eps, real* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, real* alf, integer* nbet, real* bet, integer* nmax, real* a, real* aa, real* as, real* b, real* bb, real* bs, real* c__, real* cc, real* cs, real* ct, real* g, integer* iorder, ftnlen sname_len)
-{
- /* Initialized data */
-
- static char ich[3+1] = "NTC";
-
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
- i__3, i__4, i__5, i__6;
-
-
- /* Local variables */
- static real beta;
- static integer ldas, ldbs, ldcs;
- static logical same, null;
- static integer i__, k, m, n;
- static real alpha;
- static logical isame[13];
- static logical trana, tranb;
- static integer nargs;
- static logical reset;
- extern /* Subroutine */ void sprcn1_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, integer*, real*, integer*, integer*, real*, integer*, ftnlen, ftnlen, ftnlen);
- extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, logical*, real*, ftnlen, ftnlen, ftnlen);
- extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*, ftnlen, ftnlen);
- static integer ia, ib, ma, mb, na, nb, nc, ik, im, in, ks, ms, ns;
- extern /* Subroutine */ void csgemm_(integer*, char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, ftnlen, ftnlen);
- static char tranas[1], tranbs[1], transa[1], transb[1];
- static real errmax;
- extern logical lseres_(char*, char*, integer*, integer*, real*, real*, integer*, ftnlen, ftnlen);
- extern logical lse_(real*, real*, integer*);
- static integer ica, icb, laa, lbb, lda, lcc, ldb, ldc;
- static real als, bls;
- static real err;
-
-/* Tests SGEMM. */
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Parameters .. */
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. Local Scalars .. */
-/* .. Local Arrays .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Scalars in Common .. */
-/* .. Common blocks .. */
-/* .. Data statements .. */
- /* Parameter adjustments */
- --idim;
- --alf;
- --bet;
- --g;
- --ct;
- --cs;
- --cc;
- c_dim1 = *nmax;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
- --bs;
- --bb;
- b_dim1 = *nmax;
- b_offset = 1 + b_dim1 * 1;
- b -= b_offset;
- --as;
- --aa;
- a_dim1 = *nmax;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
-
- /* Function Body */
-/* .. Executable Statements .. */
-
- nargs = 13;
- nc = 0;
- reset = TRUE_;
- errmax = (float)0.;
-
- i__1 = *nidim;
- for (im = 1; im <= i__1; ++im) {
- m = idim[im];
-
- i__2 = *nidim;
- for (in = 1; in <= i__2; ++in) {
- n = idim[in];
-/* Set LDC to 1 more than minimum value if room. */
- ldc = m;
- if (ldc < *nmax) {
- ++ldc;
- }
-/* Skip tests if not enough room. */
- if (ldc > *nmax) {
- goto L100;
- }
- lcc = ldc * n;
- null = n <= 0 || m <= 0;
-
- i__3 = *nidim;
- for (ik = 1; ik <= i__3; ++ik) {
- k = idim[ik];
-
- for (ica = 1; ica <= 3; ++ica) {
- *(unsigned char *)transa = *(unsigned char *)&ich[ica - 1]
- ;
- trana = *(unsigned char *)transa == 'T' || *(unsigned
- char *)transa == 'C';
-
- if (trana) {
- ma = k;
- na = m;
- } else {
- ma = m;
- na = k;
- }
-/* Set LDA to 1 more than minimum value if room. */
- lda = ma;
- if (lda < *nmax) {
- ++lda;
- }
-/* Skip tests if not enough room. */
- if (lda > *nmax) {
- goto L80;
- }
- laa = lda * na;
-
-/* Generate the matrix A. */
-
- smake_("GE", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[
- 1], &lda, &reset, &c_b103, (ftnlen)2, (ftnlen)1, (
- ftnlen)1);
-
- for (icb = 1; icb <= 3; ++icb) {
- *(unsigned char *)transb = *(unsigned char *)&ich[icb
- - 1];
- tranb = *(unsigned char *)transb == 'T' || *(unsigned
- char *)transb == 'C';
-
- if (tranb) {
- mb = n;
- nb = k;
- } else {
- mb = k;
- nb = n;
- }
-/* Set LDB to 1 more than minimum value if room. */
- ldb = mb;
- if (ldb < *nmax) {
- ++ldb;
- }
-/* Skip tests if not enough room. */
- if (ldb > *nmax) {
- goto L70;
- }
- lbb = ldb * nb;
-
-/* Generate the matrix B. */
-
- smake_("GE", " ", " ", &mb, &nb, &b[b_offset], nmax, &
- bb[1], &ldb, &reset, &c_b103, (ftnlen)2, (
- ftnlen)1, (ftnlen)1);
-
- i__4 = *nalf;
- for (ia = 1; ia <= i__4; ++ia) {
- alpha = alf[ia];
-
- i__5 = *nbet;
- for (ib = 1; ib <= i__5; ++ib) {
- beta = bet[ib];
-
-/* Generate the matrix C. */
-
- smake_("GE", " ", " ", &m, &n, &c__[c_offset],
- nmax, &cc[1], &ldc, &reset, &c_b103,
- (ftnlen)2, (ftnlen)1, (ftnlen)1);
-
- ++nc;
-
-/* Save every datum before calling the */
-/* subroutine. */
-
- *(unsigned char *)tranas = *(unsigned char *)
- transa;
- *(unsigned char *)tranbs = *(unsigned char *)
- transb;
- ms = m;
- ns = n;
- ks = k;
- als = alpha;
- i__6 = laa;
- for (i__ = 1; i__ <= i__6; ++i__) {
- as[i__] = aa[i__];
-/* L10: */
- }
- ldas = lda;
- i__6 = lbb;
- for (i__ = 1; i__ <= i__6; ++i__) {
- bs[i__] = bb[i__];
-/* L20: */
- }
- ldbs = ldb;
- bls = beta;
- i__6 = lcc;
- for (i__ = 1; i__ <= i__6; ++i__) {
- cs[i__] = cc[i__];
-/* L30: */
- }
- ldcs = ldc;
-
-/* Call the subroutine. */
-
- if (*trace) {
- sprcn1_(ntra, &nc, sname, iorder, transa,
- transb, &m, &n, &k, &alpha, &lda,
- &ldb, &beta, &ldc, (ftnlen)12, (
- ftnlen)1, (ftnlen)1);
- }
- if (*rewi) {
-// f_rew(&al__1);
- }
- csgemm_(iorder, transa, transb, &m, &n, &k, &
- alpha, &aa[1], &lda, &bb[1], &ldb, &
- beta, &cc[1], &ldc, (ftnlen)1, (
- ftnlen)1);
-
-/* Check if error-exit was taken incorrectly. */
-
- if (! infoc_1.ok) {
- printf(" *** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");
- *fatal = TRUE_;
- goto L120;
- }
-
-/* See what data changed inside subroutines. */
-
- isame[0] = *(unsigned char *)transa == *(
- unsigned char *)tranas;
- isame[1] = *(unsigned char *)transb == *(
- unsigned char *)tranbs;
- isame[2] = ms == m;
- isame[3] = ns == n;
- isame[4] = ks == k;
- isame[5] = als == alpha;
- isame[6] = lse_(&as[1], &aa[1], &laa);
- isame[7] = ldas == lda;
- isame[8] = lse_(&bs[1], &bb[1], &lbb);
- isame[9] = ldbs == ldb;
- isame[10] = bls == beta;
- if (null) {
- isame[11] = lse_(&cs[1], &cc[1], &lcc);
- } else {
- isame[11] = lseres_("GE", " ", &m, &n, &
- cs[1], &cc[1], &ldc, (ftnlen)2, (
- ftnlen)1);
- }
- isame[12] = ldcs == ldc;
-
-/* If data was incorrectly changed, report */
-/* and return. */
-
- same = TRUE_;
- i__6 = nargs;
- for (i__ = 1; i__ <= i__6; ++i__) {
- same = same && isame[i__ - 1];
- if (! isame[i__ - 1]) {
- printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
- }
-/* L40: */
- }
- if (! same) {
- *fatal = TRUE_;
- goto L120;
- }
-
- if (! null) {
-
-/* Check the result. */
-
- smmch_(transa, transb, &m, &n, &k, &alpha,
- &a[a_offset], nmax, &b[b_offset],
- nmax, &beta, &c__[c_offset],
- nmax, &ct[1], &g[1], &cc[1], &ldc,
- eps, &err, fatal, nout, &c_true,
- (ftnlen)1, (ftnlen)1);
- errmax = dmax(errmax,err);
-/* If got really bad answer, report and */
-/* return. */
- if (*fatal) {
- goto L120;
- }
- }
-
-/* L50: */
- }
-
-/* L60: */
- }
-
-L70:
- ;
- }
-
-L80:
- ;
+ return pow;
+}
+#ifdef _MSC_VER
+static _Fcomplex cpow_ui(complex x, integer n) {
+ complex pow={1.0,0.0}; unsigned long int u;
+ if(n != 0) {
+ if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i;
+ for(u = n; ; ) {
+ if(u & 01) pow.r *= x.r, pow.i *= x.i;
+ if(u >>= 1) x.r *= x.r, x.i *= x.i;
+ else break;
}
-
-/* L90: */
- }
-
-L100:
- ;
}
-
-/* L110: */
- }
-
-/* Report result. */
-
- if (errmax < *thresh) {
- if (*iorder == 0) {
- printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
+ _Fcomplex p={pow.r, pow.i};
+ return p;
+}
+#else
+static _Complex float cpow_ui(_Complex float x, integer n) {
+ _Complex float pow=1.0; unsigned long int u;
+ if(n != 0) {
+ if(n < 0) n = -n, x = 1/x;
+ for(u = n; ; ) {
+ if(u & 01) pow *= x;
+ if(u >>= 1) x *= x;
+ else break;
+ }
}
- if (*iorder == 1) {
- printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
+ return pow;
+}
+#endif
+#ifdef _MSC_VER
+static _Dcomplex zpow_ui(_Dcomplex x, integer n) {
+ _Dcomplex pow={1.0,0.0}; unsigned long int u;
+ if(n != 0) {
+ if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1];
+ for(u = n; ; ) {
+ if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1];
+ if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1];
+ else break;
+ }
}
- } else {
- if (*iorder == 0) {
- printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);
- printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);
+ _Dcomplex p = {pow._Val[0], pow._Val[1]};
+ return p;
+}
+#else
+static _Complex double zpow_ui(_Complex double x, integer n) {
+ _Complex double pow=1.0; unsigned long int u;
+ if(n != 0) {
+ if(n < 0) n = -n, x = 1/x;
+ for(u = n; ; ) {
+ if(u & 01) pow *= x;
+ if(u >>= 1) x *= x;
+ else break;
+ }
}
- if (*iorder == 1) {
- printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);
- printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);
+ return pow;
+}
+#endif
+static integer pow_ii(integer x, integer n) {
+ integer pow; unsigned long int u;
+ if (n <= 0) {
+ if (n == 0 || x == 1) pow = 1;
+ else if (x != -1) pow = x == 0 ? 1/x : 0;
+ else n = -n;
+ }
+ if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+ u = n;
+ for(pow = 1; ; ) {
+ if(u & 01) pow *= x;
+ if(u >>= 1) x *= x;
+ else break;
+ }
}
- }
- goto L130;
-
-L120:
- printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
- sprcn1_(nout, &nc, sname, iorder, transa, transb, &m, &n, &k, &alpha, &
- lda, &ldb, &beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1);
-
-L130:
- return 0;
-
-/* 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',', */
-/* $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ', */
-/* $ 'C,', I3, ').' ) */
-
-/* End of SCHK1. */
-
-} /* schk1_ */
-
-
-
-
-/* Subroutine */ void sprcn1_(integer* nout, integer* nc, char* sname, integer* iorder, char* transa, char* transb, integer* m, integer* n, integer* k, real* alpha, integer* lda, integer* ldb, real* beta, integer* ldc, ftnlen sname_len, ftnlen transa_len, ftnlen transb_len)
+ return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
{
-
- /* Local variables */
- static char crc[14], cta[14], ctb[14];
-
- if (*(unsigned char *)transa == 'N') {
- s_copy(cta, " CblasNoTrans", (ftnlen)14, (ftnlen)14);
- } else if (*(unsigned char *)transa == 'T') {
- s_copy(cta, " CblasTrans", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(cta, "CblasConjTrans", (ftnlen)14, (ftnlen)14);
- }
- if (*(unsigned char *)transb == 'N') {
- s_copy(ctb, " CblasNoTrans", (ftnlen)14, (ftnlen)14);
- } else if (*(unsigned char *)transb == 'T') {
- s_copy(ctb, " CblasTrans", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(ctb, "CblasConjTrans", (ftnlen)14, (ftnlen)14);
- }
- if (*iorder == 1) {
- s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
- }
- printf("%6d: %s %s %s %s\n",*nc,sname,crc,cta,ctb);
- printf("%d %d %d %4.1f A, %d, B, %d, %4.1f, C, %d.\n",*m,*n,*k,*alpha,*lda,*ldb,*beta,*ldc);
-
-} /* sprcn1_ */
-
-
-/* Subroutine */ int schk2_(char* sname, real* eps, real* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, real* alf, integer* nbet, real* bet, integer* nmax, real* a, real* aa, real* as, real* b, real* bb, real* bs, real* c__, real* cc, real* cs, real* ct, real* g, integer* iorder, ftnlen sname_len)
+ double m; integer i, mi;
+ for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+ if (w[i-1]>m) mi=i ,m=w[i-1];
+ return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
{
- /* Initialized data */
-
- static char ichs[2+1] = "LR";
- static char ichu[2+1] = "UL";
-
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
- i__3, i__4, i__5;
-
-
- /* Local variables */
- static real beta;
- static integer ldas, ldbs, ldcs;
- static logical same;
- static char side[1];
- static logical left, null;
- static char uplo[1];
- static integer i__, m, n;
- static real alpha;
- static logical isame[13];
- static char sides[1];
- static integer nargs;
- static logical reset;
- static char uplos[1];
- static integer ia, ib, na, nc, im, in, ms, ns;
- static real errmax;
- extern logical lseres_(char*, char*, integer*, integer*, real*, real*, integer*, ftnlen, ftnlen);
- extern /* Subroutine */ void cssymm_(integer*, char*, char*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, ftnlen, ftnlen);
- extern void sprcn2_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, real*, integer*, integer*, real*, integer*, ftnlen, ftnlen, ftnlen);
- extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, logical*, real*, ftnlen, ftnlen, ftnlen);
- extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*, ftnlen, ftnlen);
- static integer laa, lbb, lda, lcc, ldb, ldc, ics;
- static real als, bls;
- static integer icu;
- extern logical lse_(real*, real*, integer*);
- static real err;
-
-/* Tests SSYMM. */
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Parameters .. */
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. Local Scalars .. */
-/* .. Local Arrays .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Scalars in Common .. */
-/* .. Common blocks .. */
-/* .. Data statements .. */
- /* Parameter adjustments */
- --idim;
- --alf;
- --bet;
- --g;
- --ct;
- --cs;
- --cc;
- c_dim1 = *nmax;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
- --bs;
- --bb;
- b_dim1 = *nmax;
- b_offset = 1 + b_dim1 * 1;
- b -= b_offset;
- --as;
- --aa;
- a_dim1 = *nmax;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
-
- /* Function Body */
-/* .. Executable Statements .. */
-
- nargs = 12;
- nc = 0;
- reset = TRUE_;
- errmax = (float)0.;
-
- i__1 = *nidim;
- for (im = 1; im <= i__1; ++im) {
- m = idim[im];
-
- i__2 = *nidim;
- for (in = 1; in <= i__2; ++in) {
- n = idim[in];
-/* Set LDC to 1 more than minimum value if room. */
- ldc = m;
- if (ldc < *nmax) {
- ++ldc;
- }
-/* Skip tests if not enough room. */
- if (ldc > *nmax) {
- goto L90;
- }
- lcc = ldc * n;
- null = n <= 0 || m <= 0;
-
-/* Set LDB to 1 more than minimum value if room. */
- ldb = m;
- if (ldb < *nmax) {
- ++ldb;
- }
-/* Skip tests if not enough room. */
- if (ldb > *nmax) {
- goto L90;
- }
- lbb = ldb * n;
-
-/* Generate the matrix B. */
-
- smake_("GE", " ", " ", &m, &n, &b[b_offset], nmax, &bb[1], &ldb, &
- reset, &c_b103, (ftnlen)2, (ftnlen)1, (ftnlen)1);
-
- for (ics = 1; ics <= 2; ++ics) {
- *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1];
- left = *(unsigned char *)side == 'L';
-
- if (left) {
- na = m;
- } else {
- na = n;
+ float m; integer i, mi;
+ for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+ if (w[i-1]>m) mi=i ,m=w[i-1];
+ return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+ integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+ _Fcomplex zdotc = {0.0, 0.0};
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<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];
}
-/* Set LDA to 1 more than minimum value if room. */
- lda = na;
- if (lda < *nmax) {
- ++lda;
+ } 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];
}
-/* Skip tests if not enough room. */
- if (lda > *nmax) {
- goto L80;
+ }
+ 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]);
}
- 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: */
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
}
-
-L80:
- ;
- }
-
-L90:
- ;
}
-
-/* L100: */
- }
-
-/* Report result. */
-
- if (errmax < *thresh) {
- if (*iorder == 0) {
- printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
+ 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];
+ }
}
- if (*iorder == 1) {
- printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
+ 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]);
+ }
}
- } 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);
+ 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];
+ }
}
- 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_(integer* nout, integer* nc, char* sname, integer* iorder, char* side, char* uplo, integer* m, integer* n, real* alpha, integer* lda, integer* ldb, real* beta, integer* ldc, ftnlen sname_len, ftnlen side_len, ftnlen uplo_len)
-{
-
- /* Local variables */
- static char cs[14], cu[14], crc[14];
-
- if (*(unsigned char *)side == 'L') {
- s_copy(cs, " CblasLeft", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(cs, " CblasRight", (ftnlen)14, (ftnlen)14);
- }
- if (*(unsigned char *)uplo == 'U') {
- s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14);
- }
- if (*iorder == 1) {
- s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
- }
- printf("%6d: %s %s %s %s\n",*nc,sname,crc,cs,cu);
- printf("%d %d %4.1f A, %d, B, %d, %4.1f C, %d.\n",*m,*n,*alpha,*lda,*ldb,*beta,*ldc);
-} /* sprcn2_ */
-
-
-/* Subroutine */ int schk3_(char* sname, real* eps, real* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, real* alf, integer* nmax, real* a, real* aa, real* as, real* b, real* bb, real* bs, real* ct, real* g, real* 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;
- 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_(integer*, integer*, char*, integer*, char*, char*, char*, char*, integer*, integer*, real*, integer*, integer*, ftnlen , ftnlen, ftnlen, ftnlen, ftnlen);
- static integer ia, na, nc, im, in, ms, ns;
- static char tranas[1], transa[1];
- static real errmax;
- extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, logical*, real*, ftnlen, ftnlen, ftnlen);
- extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*, ftnlen, ftnlen);
- extern logical lseres_(char*, char*, integer*, integer*, real*, real*, integer*, ftnlen, ftnlen);
- extern /* Subroutine */ void cstrmm_(integer*, char*, char*, char*, char*, integer*, integer*, real*, real*, integer*, real*, integer*, ftnlen, ftnlen, ftnlen, ftnlen);
- extern /* Subroutine */ void cstrsm_(integer*, char*, char*, char*, char*, integer*, integer*, real*, real*, integer*, real*, integer*, ftnlen, ftnlen, ftnlen, ftnlen);
- static integer laa, icd, lbb, lda, ldb, ics;
- static real als;
- static integer ict, icu;
- extern logical lse_(real*, real*, integer*);
- 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: */
+ 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]);
+ }
}
-/* 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;
+ 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];
}
-/* Set LDA to 1 more than minimum value if room. */
- lda = na;
- if (lda < *nmax) {
- ++lda;
+ } 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];
}
-/* Skip tests if not enough room. */
- if (lda > *nmax) {
- goto L130;
+ }
+ 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]);
}
- 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_(integer* nout, integer* nc, char* sname, integer* iorder, char* side, char* uplo, char* transa, char* diag, integer* m, integer* n, real* alpha, integer* lda, integer* ldb, ftnlen sname_len, ftnlen side_len, ftnlen uplo_len, ftnlen transa_len, ftnlen diag_len)
-{
-
- /* Local variables */
- static char ca[14], cd[14], cs[14], cu[14], crc[14];
-
- if (*(unsigned char *)side == 'L') {
- s_copy(cs, " CblasLeft", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(cs, " CblasRight", (ftnlen)14, (ftnlen)14);
- }
- if (*(unsigned char *)uplo == 'U') {
- s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14);
- }
- if (*(unsigned char *)transa == 'N') {
- s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14);
- } else if (*(unsigned char *)transa == 'T') {
- s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14);
- }
- if (*(unsigned char *)diag == 'N') {
- s_copy(cd, " CblasNonUnit", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(cd, " CblasUnit", (ftnlen)14, (ftnlen)14);
- }
- if (*iorder == 1) {
- s_copy(crc, "CblasRowMajor", (ftnlen)14, (ftnlen)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_(char* sname, real* eps, real* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, real* alf, integer* nbet, real* bet, integer* nmax, real* a, real* aa, real* as, real* b, real* bb, real* bs, real* c__, real* cc, real* cs, real* ct, real* g, integer* iorder, ftnlen sname_len)
-{
- /* Initialized data */
-
- static char icht[3+1] = "NTC";
- static char ichu[2+1] = "UL";
-
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
- i__3, i__4, i__5;
-
-
- /* Local variables */
- static 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_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, ftnlen, ftnlen, ftnlen);
- extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, logical*, real*, ftnlen, ftnlen, ftnlen);
- extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*, ftnlen, ftnlen);
- static integer ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns;
- static real errmax;
- extern logical lseres_(char*, char*, integer*, integer*, real*, real*, integer*, ftnlen, ftnlen);
- static char transs[1];
- extern /* Subroutine */ void cssyrk_(integer*, char*, char*, integer*, integer*, real*, real*, integer*, real*, real*, integer*, ftnlen, ftnlen);
- static integer laa, lda, lcc, ldc;
- static real als;
- static integer ict, icu;
- extern logical lse_(real*, real*, integer*);
- 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_(integer* nout, integer* nc, char* sname, integer* iorder, char* uplo, char* transa, integer* n, integer* k, real* alpha, integer* lda, real* beta, integer* ldc, ftnlen sname_len, ftnlen uplo_len, ftnlen transa_len)
-{
-
- /* Local variables */
- static char ca[14], cu[14], crc[14];
-
- if (*(unsigned char *)uplo == 'U') {
- s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14);
- }
- if (*(unsigned char *)transa == 'N') {
- s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14);
- } else if (*(unsigned char *)transa == 'T') {
- s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14);
- }
- if (*iorder == 1) {
- s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
- }
- printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca);
- printf("( %d %d %4.1f A %d %4.1f C %d\n",*n,*k,*alpha,*lda,*beta,*ldc);
-
-} /* sprcn4_ */
-
-
-/* Subroutine */ int schk5_(char* sname, real* eps, real* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, real* alf, integer* nbet, real* bet, integer* nmax, real* ab, real* aa, real* as, real* bb, real* bs, real* c__, real* cc, real* cs, real* ct, real* g, real* w, integer* iorder, ftnlen sname_len)
-{
- /* Initialized data */
-
- static char icht[3+1] = "NTC";
- static char ichu[2+1] = "UL";
-
- /* System generated locals */
- integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8;
-
-
- /* Local variables */
- static integer jjab;
- static real beta;
- static integer ldas, ldbs, ldcs;
- static logical same;
- static real bets;
- static logical tran, null;
- static char uplo[1];
- static integer i__, j, k, n;
- static real alpha;
- static logical isame[13];
- static integer nargs;
- static logical reset;
- static char trans[1];
- static logical upper;
- static char uplos[1];
- static integer ia, ib;
- extern /* Subroutine */ void sprcn5_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, real*, integer*, integer*, real*, integer*, ftnlen, ftnlen, ftnlen);
- static integer jc, ma, na, nc, ik, in, jj, lj, ks, ns;
- static real errmax;
- extern logical lseres_(char*, char*, integer*, integer*, real*, real*, integer*, ftnlen, ftnlen);
- extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, logical*, real*, ftnlen, ftnlen, ftnlen);
- static char transs[1];
- static integer laa, lbb, lda, lcc, ldb, ldc;
- static real als;
- static integer ict, icu;
- extern /* Subroutine */ void cssyr2k_(integer*, char*, char*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, ftnlen, ftnlen);
- extern logical lse_(real*, real*, integer*);
- extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*, ftnlen, ftnlen);
- static real err;
-
-/* Tests SSYR2K. */
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Parameters .. */
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. Local Scalars .. */
-/* .. Local Arrays .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Scalars in Common .. */
-/* .. Common blocks .. */
-/* .. Data statements .. */
- /* Parameter adjustments */
- --idim;
- --alf;
- --bet;
- --w;
- --g;
- --ct;
- --cs;
- --cc;
- c_dim1 = *nmax;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
- --bs;
- --bb;
- --as;
- --aa;
- --ab;
-
- /* Function Body */
-/* .. Executable Statements .. */
-
- nargs = 12;
- nc = 0;
- reset = TRUE_;
- errmax = (float)0.;
-
- i__1 = *nidim;
- for (in = 1; in <= i__1; ++in) {
- n = idim[in];
-/* Set LDC to 1 more than minimum value if room. */
- ldc = n;
- if (ldc < *nmax) {
- ++ldc;
- }
-/* Skip tests if not enough room. */
- if (ldc > *nmax) {
- goto L130;
- }
- lcc = ldc * n;
- null = n <= 0;
-
- i__2 = *nidim;
- for (ik = 1; ik <= i__2; ++ik) {
- k = idim[ik];
-
- for (ict = 1; ict <= 3; ++ict) {
- *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1];
- tran = *(unsigned char *)trans == 'T' || *(unsigned char *)
- trans == 'C';
- if (tran) {
- ma = k;
- na = n;
- } else {
- ma = n;
- na = k;
- }
-/* Set LDA to 1 more than minimum value if room. */
- lda = ma;
- if (lda < *nmax) {
- ++lda;
- }
-/* Skip tests if not enough room. */
- if (lda > *nmax) {
- goto L110;
- }
- laa = lda * na;
-
-/* Generate the matrix A. */
-
- if (tran) {
- i__3 = *nmax << 1;
- smake_("GE", " ", " ", &ma, &na, &ab[1], &i__3, &aa[1], &
- lda, &reset, &c_b103, (ftnlen)2, (ftnlen)1, (
- ftnlen)1);
- } else {
- smake_("GE", " ", " ", &ma, &na, &ab[1], nmax, &aa[1], &
- lda, &reset, &c_b103, (ftnlen)2, (ftnlen)1, (
- ftnlen)1);
- }
-
-/* Generate the matrix B. */
-
- ldb = lda;
- lbb = laa;
- if (tran) {
- i__3 = *nmax << 1;
- smake_("GE", " ", " ", &ma, &na, &ab[k + 1], &i__3, &bb[1]
- , &ldb, &reset, &c_b103, (ftnlen)2, (ftnlen)1, (
- ftnlen)1);
- } else {
- smake_("GE", " ", " ", &ma, &na, &ab[k * *nmax + 1], nmax,
- &bb[1], &ldb, &reset, &c_b103, (ftnlen)2, (
- ftnlen)1, (ftnlen)1);
- }
-
- for (icu = 1; icu <= 2; ++icu) {
- *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];
- upper = *(unsigned char *)uplo == 'U';
-
- i__3 = *nalf;
- for (ia = 1; ia <= i__3; ++ia) {
- alpha = alf[ia];
-
- i__4 = *nbet;
- for (ib = 1; ib <= i__4; ++ib) {
- beta = bet[ib];
-
-/* Generate the matrix C. */
-
- smake_("SY", uplo, " ", &n, &n, &c__[c_offset],
- nmax, &cc[1], &ldc, &reset, &c_b103, (
- ftnlen)2, (ftnlen)1, (ftnlen)1);
-
- ++nc;
-
-/* Save every datum before calling the subroutine. */
-
- *(unsigned char *)uplos = *(unsigned char *)uplo;
- *(unsigned char *)transs = *(unsigned char *)
- trans;
- ns = n;
- ks = k;
- als = alpha;
- i__5 = laa;
- for (i__ = 1; i__ <= i__5; ++i__) {
- as[i__] = aa[i__];
-/* L10: */
- }
- ldas = lda;
- i__5 = lbb;
- for (i__ = 1; i__ <= i__5; ++i__) {
- bs[i__] = bb[i__];
-/* L20: */
- }
- ldbs = ldb;
- bets = beta;
- i__5 = lcc;
- for (i__ = 1; i__ <= i__5; ++i__) {
- cs[i__] = cc[i__];
-/* L30: */
- }
- ldcs = ldc;
-
-/* Call the subroutine. */
-
- if (*trace) {
- sprcn5_(ntra, &nc, sname, iorder, uplo, trans,
- &n, &k, &alpha, &lda, &ldb, &beta, &
- ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1)
- ;
- }
- if (*rewi) {
-// f_rew(&al__1);
- }
- cssyr2k_(iorder, uplo, trans, &n, &k, &alpha, &aa[
- 1], &lda, &bb[1], &ldb, &beta, &cc[1], &
- ldc, (ftnlen)1, (ftnlen)1);
-
-/* Check if error-exit was taken incorrectly. */
-
- if (! infoc_1.ok) {
- printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");
- *fatal = TRUE_;
- goto L150;
- }
-
-/* See what data changed inside subroutines. */
-
- isame[0] = *(unsigned char *)uplos == *(unsigned
- char *)uplo;
- isame[1] = *(unsigned char *)transs == *(unsigned
- char *)trans;
- isame[2] = ns == n;
- isame[3] = ks == k;
- isame[4] = als == alpha;
- isame[5] = lse_(&as[1], &aa[1], &laa);
- isame[6] = ldas == lda;
- isame[7] = lse_(&bs[1], &bb[1], &lbb);
- isame[8] = ldbs == ldb;
- isame[9] = bets == beta;
- if (null) {
- isame[10] = lse_(&cs[1], &cc[1], &lcc);
- } else {
- isame[10] = lseres_("SY", uplo, &n, &n, &cs[1]
- , &cc[1], &ldc, (ftnlen)2, (ftnlen)1);
- }
- isame[11] = ldcs == ldc;
-
-/* If data was incorrectly changed, report and */
-/* return. */
-
- same = TRUE_;
- i__5 = nargs;
- for (i__ = 1; i__ <= i__5; ++i__) {
- same = same && isame[i__ - 1];
- if (! isame[i__ - 1]) {
- printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
- }
-/* L40: */
- }
- if (! same) {
- *fatal = TRUE_;
- goto L150;
- }
-
- if (! null) {
-
-/* Check the result column by column. */
-
- jjab = 1;
- jc = 1;
- i__5 = n;
- for (j = 1; j <= i__5; ++j) {
- if (upper) {
- jj = 1;
- lj = j;
- } else {
- jj = j;
- lj = n - j + 1;
- }
- if (tran) {
- i__6 = k;
- for (i__ = 1; i__ <= i__6; ++i__) {
- w[i__] = ab[((j - 1) << 1) * *nmax
- + k + i__];
- w[k + i__] = ab[((j - 1) << 1) * *
- nmax + i__];
-/* L50: */
- }
- i__6 = k << 1;
- i__7 = *nmax << 1;
- i__8 = *nmax << 1;
- smmch_("T", "N", &lj, &c__1, &i__6, &
- alpha, &ab[jjab], &i__7, &w[1]
- , &i__8, &beta, &c__[jj + j *
- c_dim1], nmax, &ct[1], &g[1],
- &cc[jc], &ldc, eps, &err,
- fatal, nout, &c_true, (ftnlen)
- 1, (ftnlen)1);
- } else {
- i__6 = k;
- for (i__ = 1; i__ <= i__6; ++i__) {
- w[i__] = ab[(k + i__ - 1) * *nmax
- + j];
- w[k + i__] = ab[(i__ - 1) * *nmax
- + j];
-/* L60: */
- }
- i__6 = k << 1;
- i__7 = *nmax << 1;
- smmch_("N", "N", &lj, &c__1, &i__6, &
- alpha, &ab[jj], nmax, &w[1], &
- i__7, &beta, &c__[jj + j *
- c_dim1], nmax, &ct[1], &g[1],
- &cc[jc], &ldc, eps, &err,
- fatal, nout, &c_true, (ftnlen)
- 1, (ftnlen)1);
- }
- if (upper) {
- jc += ldc;
- } else {
- jc = jc + ldc + 1;
- if (tran) {
- jjab += *nmax << 1;
- }
- }
- errmax = dmax(errmax,err);
-/* If got really bad answer, report and */
-/* return. */
- if (*fatal) {
- goto L140;
- }
-/* L70: */
- }
- }
-
-/* L80: */
- }
-
-/* L90: */
- }
-
-/* L100: */
- }
-
-L110:
- ;
- }
-
-/* L120: */
- }
-
-L130:
- ;
- }
-
-/* Report result. */
-
- if (errmax < *thresh) {
- if (*iorder == 0) {
- printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
- }
- if (*iorder == 1) {
- printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
- }
- } else {
- if (*iorder == 0) {
- printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);
- printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);
- }
- if (*iorder == 1) {
- printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);
- printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);
- }
- }
- goto L160;
-
-L140:
- if (n > 1) {
- printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j);
- }
-
-L150:
- printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
- sprcn5_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &ldb,
- &beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1);
-
-L160:
- return 0;
-
-/* 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */
-/* $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', */
-/* $ ' .' ) */
-
-/* End of SCHK5. */
-
-} /* schk5_ */
-
-
-/* Subroutine */ void sprcn5_(integer* nout, integer* nc, char* sname, integer* iorder, char* uplo, char* transa, integer* n, integer* k, real* alpha, integer* lda, integer* ldb, real* beta, integer* ldc, ftnlen sname_len, ftnlen uplo_len, ftnlen transa_len)
-{
-
- /* Local variables */
- static char ca[14], cu[14], crc[14];
-
- if (*(unsigned char *)uplo == 'U') {
- s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14);
- }
- if (*(unsigned char *)transa == 'N') {
- s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14);
- } else if (*(unsigned char *)transa == 'T') {
- s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14);
- }
- if (*iorder == 1) {
- s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
- }
- printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca);
- printf("%d %d %4.1f , A, %d, B, %d, %4.1f , C, %d.\n",*n,*k,*alpha,*lda,*ldb,*beta,*ldc);
-
-} /* sprcn5_ */
-
-
-/* Subroutine */ int smake_(char* type__, char* uplo, char* diag, integer* m, integer* n, real* a, integer* nmax, real* aa, integer* lda, logical* reset, real* transl, ftnlen type_len, ftnlen uplo_len, ftnlen diag_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2;
-
- /* Builtin functions */
-
- /* Local variables */
- static integer ibeg, iend;
- extern doublereal sbeg_(logical*);
- static logical unit;
- static integer i__, j;
- static logical lower, upper, gen, tri, sym;
-
-
-/* Generates values for an M by N matrix A. */
-/* Stores the values in the array AA in the data structure required */
-/* by the routine, with unwanted elements set to rogue value. */
-
-/* TYPE is 'GE', 'SY' or 'TR'. */
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Parameters .. */
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. Executable Statements .. */
- /* Parameter adjustments */
- a_dim1 = *nmax;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- --aa;
-
- /* Function Body */
- gen = s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0;
- sym = s_cmp(type__, "SY", (ftnlen)2, (ftnlen)2) == 0;
- tri = s_cmp(type__, "TR", (ftnlen)2, (ftnlen)2) == 0;
- upper = (sym || tri) && *(unsigned char *)uplo == 'U';
- lower = (sym || tri) && *(unsigned char *)uplo == 'L';
- unit = tri && *(unsigned char *)diag == 'U';
-
-/* Generate data in array A. */
-
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- if (gen || (upper && i__ <= j) || (lower && i__ >= j)) {
- a[i__ + j * a_dim1] = sbeg_(reset) + *transl;
- if (i__ != j) {
-/* Set some elements to zero */
- if (*n > 3 && j == *n / 2) {
- a[i__ + j * a_dim1] = (float)0.;
- }
- if (sym) {
- a[j + i__ * a_dim1] = a[i__ + j * a_dim1];
- } else if (tri) {
- a[j + i__ * a_dim1] = (float)0.;
- }
- }
- }
-/* L10: */
- }
- if (tri) {
- a[j + j * a_dim1] += (float)1.;
- }
- if (unit) {
- a[j + j * a_dim1] = (float)1.;
- }
-/* L20: */
- }
-
-/* Store elements in array AS in data structure required by routine. */
-
- if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- aa[i__ + (j - 1) * *lda] = a[i__ + j * a_dim1];
-/* L30: */
- }
- i__2 = *lda;
- for (i__ = *m + 1; i__ <= i__2; ++i__) {
- aa[i__ + (j - 1) * *lda] = (float)-1e10;
-/* L40: */
- }
-/* L50: */
- }
- } else if (s_cmp(type__, "SY", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
- "TR", (ftnlen)2, (ftnlen)2) == 0) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (upper) {
- ibeg = 1;
- if (unit) {
- iend = j - 1;
- } else {
- iend = j;
- }
- } else {
- if (unit) {
- ibeg = j + 1;
- } else {
- ibeg = j;
- }
- iend = *n;
- }
- i__2 = ibeg - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- aa[i__ + (j - 1) * *lda] = (float)-1e10;
-/* L60: */
- }
- i__2 = iend;
- for (i__ = ibeg; i__ <= i__2; ++i__) {
- aa[i__ + (j - 1) * *lda] = a[i__ + j * a_dim1];
-/* L70: */
- }
- i__2 = *lda;
- for (i__ = iend + 1; i__ <= i__2; ++i__) {
- aa[i__ + (j - 1) * *lda] = (float)-1e10;
-/* L80: */
- }
-/* L90: */
- }
- }
- return 0;
-
-/* End of SMAKE. */
-
-} /* smake_ */
-
-/* Subroutine */ int smmch_(char* transa, char* transb, integer* m, integer* n, integer* kk, real* alpha, real* a, integer* lda, real* b, integer* ldb, real* beta, real* c__, integer* ldc, real* ct, real* g, real* cc, integer* ldcc, real* eps, real* err, logical* fatal, integer* nout, logical* mv, ftnlen transa_len, ftnlen transb_len)
-{
-
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, cc_dim1,
- cc_offset, i__1, i__2, i__3;
- real r__1, r__2;
-
- /* Builtin functions */
- double sqrt(double);
-
- /* Local variables */
- static real erri;
- static integer i__, j, k;
- static logical trana, tranb;
-
-/* Checks the results of the computational tests. */
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Parameters .. */
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. Local Scalars .. */
-/* .. Intrinsic Functions .. */
-/* .. Executable Statements .. */
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- b_dim1 = *ldb;
- b_offset = 1 + b_dim1 * 1;
- b -= b_offset;
- c_dim1 = *ldc;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
- --ct;
- --g;
- cc_dim1 = *ldcc;
- cc_offset = 1 + cc_dim1 * 1;
- cc -= cc_offset;
-
- /* Function Body */
- trana = *(unsigned char *)transa == 'T' || *(unsigned char *)transa ==
- 'C';
- tranb = *(unsigned char *)transb == 'T' || *(unsigned char *)transb ==
- 'C';
-
-/* Compute expected result, one column at a time, in CT using data */
-/* in A, B and C. */
-/* Compute gauges in G. */
-
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
-
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- ct[i__] = (float)0.;
- g[i__] = (float)0.;
-/* L10: */
- }
- if (! trana && ! tranb) {
- i__2 = *kk;
- for (k = 1; k <= i__2; ++k) {
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- ct[i__] += a[i__ + k * a_dim1] * b[k + j * b_dim1];
- g[i__] += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) * (
- r__2 = b[k + j * b_dim1], dabs(r__2));
-/* L20: */
- }
-/* L30: */
- }
- } else if (trana && ! tranb) {
- i__2 = *kk;
- for (k = 1; k <= i__2; ++k) {
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- ct[i__] += a[k + i__ * a_dim1] * b[k + j * b_dim1];
- g[i__] += (r__1 = a[k + i__ * a_dim1], dabs(r__1)) * (
- r__2 = b[k + j * b_dim1], dabs(r__2));
-/* L40: */
- }
-/* L50: */
- }
- } else if (! trana && tranb) {
- i__2 = *kk;
- for (k = 1; k <= i__2; ++k) {
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- ct[i__] += a[i__ + k * a_dim1] * b[j + k * b_dim1];
- g[i__] += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) * (
- r__2 = b[j + k * b_dim1], dabs(r__2));
-/* L60: */
- }
-/* L70: */
- }
- } else if (trana && tranb) {
- i__2 = *kk;
- for (k = 1; k <= i__2; ++k) {
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- ct[i__] += a[k + i__ * a_dim1] * b[j + k * b_dim1];
- g[i__] += (r__1 = a[k + i__ * a_dim1], dabs(r__1)) * (
- r__2 = b[j + k * b_dim1], dabs(r__2));
-/* L80: */
- }
-/* L90: */
- }
- }
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- ct[i__] = *alpha * ct[i__] + *beta * c__[i__ + j * c_dim1];
- g[i__] = dabs(*alpha) * g[i__] + dabs(*beta) * (r__1 = c__[i__ +
- j * c_dim1], dabs(r__1));
-/* L100: */
- }
-
-/* Compute the error ratio for this result. */
-
- *err = (float)0.;
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- erri = (r__1 = ct[i__] - cc[i__ + j * cc_dim1], dabs(r__1)) / *
- eps;
- if (g[i__] != (float)0.) {
- erri /= g[i__];
- }
- *err = dmax(*err,erri);
- if (*err * sqrt(*eps) >= (float)1.) {
- goto L130;
- }
-/* L110: */
- }
-
-/* L120: */
- }
-
-/* If the loop completes, all results are at least half accurate. */
- goto L150;
-
-/* Report fatal error. */
-
-L130:
- *fatal = TRUE_;
- printf(" ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HALF ACCURATE *******\n");
- printf(" EXPECTED RESULT COMPUTED RESULT\n");
- i__1 = *m;
- for (i__ = 1; i__ <= i__1; ++i__) {
- if (*mv) {
- printf("%7d %15.6g %15.6g\n",i__,ct[i__],cc[i__+j*cc_dim1]);
} else {
- printf("%7d %15.6g %15.6g\n",i__,cc[i__+j*cc_dim1],ct[i__]);
- }
-/* L140: */
- }
- if (*n > 1) {
- printf(" THESE ARE THE RESULTS FOR COLUMN %d\n",j);
- }
-
-L150:
- return 0;
-
-
-/* End of SMMCH. */
-
-} /* smmch_ */
-
-logical lse_(real* ri, real* rj, integer* lr)
-{
- /* System generated locals */
- integer i__1;
- logical ret_val;
-
- /* Local variables */
- static integer i__;
-
-
-/* Tests if two arrays are identical. */
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. Local Scalars .. */
-/* .. Executable Statements .. */
- /* Parameter adjustments */
- --rj;
- --ri;
-
- /* Function Body */
- i__1 = *lr;
- for (i__ = 1; i__ <= i__1; ++i__) {
- if (ri[i__] != rj[i__]) {
- goto L20;
- }
-/* L10: */
- }
- ret_val = TRUE_;
- goto L30;
-L20:
- ret_val = FALSE_;
-L30:
- return ret_val;
-
-/* End of LSE. */
-
-} /* lse_ */
-
-logical lseres_(char* type__, char* uplo, integer* m, integer* n, real* aa, real* as, integer* lda, ftnlen type_len, ftnlen uplo_len)
-{
- /* System generated locals */
- integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2;
- logical ret_val;
-
- /* Builtin functions */
-
- /* Local variables */
- static integer ibeg, iend, i__, j;
- static logical upper;
-
-
-/* Tests if selected elements in two arrays are equal. */
-
-/* TYPE is 'GE' or 'SY'. */
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. Local Scalars .. */
-/* .. Executable Statements .. */
- /* Parameter adjustments */
- as_dim1 = *lda;
- as_offset = 1 + as_dim1 * 1;
- as -= as_offset;
- aa_dim1 = *lda;
- aa_offset = 1 + aa_dim1 * 1;
- aa -= aa_offset;
-
- /* Function Body */
- upper = *(unsigned char *)uplo == 'U';
- if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *lda;
- for (i__ = *m + 1; i__ <= i__2; ++i__) {
- if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) {
- goto L70;
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
}
-/* 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_(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_(real* x, real* y)
-{
- /* System generated locals */
- real ret_val;
-
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Scalar Arguments .. */
-/* .. Executable Statements .. */
- ret_val = *x - *y;
- return ret_val;
+ pCd(z) = zdotc;
+}
+#endif
+/* -- translated by f2c (version 20000121).
+ You must link the resulting object file with the libraries:
+ -lf2c -lm (in that order)
+*/
-/* End of SDIFF. */
-} /* sdiff_ */
-/* Main program alias */ /*int sblat3_ () { MAIN__ (); }*/
diff --git a/ctest/c_zblat3c.c b/ctest/c_zblat3c.c
index 6025c0052a..447b23014f 100644
--- a/ctest/c_zblat3c.c
+++ b/ctest/c_zblat3c.c
@@ -10,7 +10,25 @@
#undef I
#endif
-#include "common.h"
+#if defined(_WIN64)
+typedef long long BLASLONG;
+typedef unsigned long long BLASULONG;
+#else
+typedef long BLASLONG;
+typedef unsigned long BLASULONG;
+#endif
+
+#ifdef LAPACK_ILP64
+typedef BLASLONG blasint;
+#if defined(_WIN64)
+#define blasabs(x) llabs(x)
+#else
+#define blasabs(x) labs(x)
+#endif
+#else
+typedef int blasint;
+#define blasabs(x) abs(x)
+#endif
typedef blasint integer;
@@ -22,11 +40,14 @@ typedef double doublereal;
typedef struct { real r, i; } complex;
typedef struct { doublereal r, i; } doublecomplex;
#ifdef _MSC_VER
+static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;}
static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;}
+static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;}
static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;}
#else
static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
#endif
#define pCf(z) (*_pCf(z))
@@ -226,6 +247,7 @@ typedef struct Namelist Namelist;
#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
#define sig_die(s, kill) { exit(1); }
#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
#define z_abs(z) (cabs(Cd(z)))
#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
@@ -239,3713 +261,251 @@ typedef struct Namelist Namelist;
/* procedure parameter types for -A and -C++ */
#define F2C_proc_par_types 1
-
-
-/* Common Block Declarations */
-
-struct {
- integer infot, noutc;
- logical ok, lerr;
-} infoc_;
-
-#define infoc_1 infoc_
-
-struct {
- char srnamt[12];
-} srnamc_;
-
-#define srnamc_1 srnamc_
-
-/* Table of constant values */
-
-static doublecomplex c_b1 = {0.,0.};
-static doublecomplex c_b2 = {1.,0.};
-static integer c__1 = 1;
-static integer c__65 = 65;
-static doublereal c_b92 = 1.;
-static integer c__6 = 6;
-static logical c_true = TRUE_;
-static integer c__0 = 0;
-static logical c_false = FALSE_;
-
-/* Main program MAIN__() */ int main(void)
-{
- /* Initialized data */
-
- static char snames[9][13] = { "cblas_zgemm ", "cblas_zhemm ", "cblas_zsymm ", "cblas_ztrmm ",
- "cblas_ztrsm ", "cblas_zherk ", "cblas_zsyrk ", "cblas_zher2k", "cblas_zsyr2k"};
-
- /* System generated locals */
- integer i__1, i__2, i__3, i__4, i__5;
- doublereal d__1;
-
- /* Builtin functions */
- integer s_rsle(void), do_lio(void), e_rsle(void), f_open(void), s_wsfe(void), do_fio(void),
- e_wsfe(void), s_wsle(void), e_wsle(void), s_rsfe(void), e_rsfe(void);
-
- /* Local variables */
- static integer nalf, idim[9];
- static logical same;
- static integer nbet, ntra;
- static logical rewi;
- extern /* Subroutine */ int zchk1_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublereal*, integer*, ftnlen);
- extern /* Subroutine */ int zchk2_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublereal*, integer*, ftnlen);
- extern /* Subroutine */ int zchk3_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublereal*, doublecomplex*, integer*, ftnlen);
- extern /* Subroutine */ int zchk4_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublereal*, integer*, ftnlen);
- extern /* Subroutine */ int zchk5_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublecomplex*, doublereal*, doublecomplex*, integer*, ftnlen);
- static doublecomplex c__[4225] /* was [65][65] */;
- static doublereal g[65];
- static integer i__, j;
- extern doublereal ddiff_(doublereal*, doublereal*);
- static integer n;
- static logical fatal;
- static doublecomplex w[130];
- static logical trace;
- static integer nidim;
- extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen);
- static char snaps[32];
- static integer isnum;
- static logical ltest[9];
- static doublecomplex aa[4225], ab[8450] /* was [65][130] */, bb[4225],
- cc[4225], as[4225], bs[4225], cs[4225], ct[65];
- static logical sfatal, corder;
- static char snamet[12], transa[1], transb[1];
- static doublereal thresh;
- static logical rorder;
- static integer layout;
- static logical ltestt, tsterr;
- extern /* Subroutine */ int cz3chke_(char*, ftnlen);
- static doublecomplex alf[7], bet[7];
- static doublereal eps, err;
- extern logical lze_(doublecomplex*, doublecomplex*, integer*);
- char tmpchar;
-
-/* Test program for the COMPLEX*16 Level 3 Blas. */
-
-/* The program must be driven by a short data file. The first 13 records */
-/* of the file are read using list-directed input, the last 9 records */
-/* are read using the format ( A12,L2 ). An annotated example of a data */
-/* file can be obtained by deleting the first 3 characters from the */
-/* following 22 lines: */
-/* 'CBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE */
-/* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) */
-/* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. */
-/* F LOGICAL FLAG, T TO STOP ON FAILURES. */
-/* T LOGICAL FLAG, T TO TEST ERROR EXITS. */
-/* 2 0 TO TEST COLUMN-MAJOR, 1 TO TEST ROW-MAJOR, 2 TO TEST BOTH */
-/* 16.0 THRESHOLD VALUE OF TEST RATIO */
-/* 6 NUMBER OF VALUES OF N */
-/* 0 1 2 3 5 9 VALUES OF N */
-/* 3 NUMBER OF VALUES OF ALPHA */
-/* (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA */
-/* 3 NUMBER OF VALUES OF BETA */
-/* (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA */
-/* ZGEMM T PUT F FOR NO TEST. SAME COLUMNS. */
-/* ZHEMM T PUT F FOR NO TEST. SAME COLUMNS. */
-/* ZSYMM T PUT F FOR NO TEST. SAME COLUMNS. */
-/* ZTRMM T PUT F FOR NO TEST. SAME COLUMNS. */
-/* ZTRSM T PUT F FOR NO TEST. SAME COLUMNS. */
-/* ZHERK T PUT F FOR NO TEST. SAME COLUMNS. */
-/* ZSYRK T PUT F FOR NO TEST. SAME COLUMNS. */
-/* ZHER2K T PUT F FOR NO TEST. SAME COLUMNS. */
-/* ZSYR2K T PUT F FOR NO TEST. SAME COLUMNS. */
-
-/* See: */
-
-/* Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. */
-/* A Set of Level 3 Basic Linear Algebra Subprograms. */
-
-/* Technical Memorandum No.88 (Revision 1), Mathematics and */
-/* Computer Science Division, Argonne National Laboratory, 9700 */
-/* South Cass Avenue, Argonne, Illinois 60439, US. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. Local Arrays .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Scalars in Common .. */
-/* .. Common blocks .. */
-/* .. Data statements .. */
-/* .. Executable Statements .. */
-
- infoc_1.noutc = 6;
-
-/* Read name and unit number for snapshot output file and open file. */
-
- char line[80];
-
- fgets(line,80,stdin);
- sscanf(line,"'%s'",snaps);
- fgets(line,80,stdin);
-#ifdef USE64BITINT
- sscanf(line,"%ld",&ntra);
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
#else
- sscanf(line,"%d",&ntra);
+typedef logical (*L_fp)();
#endif
- trace = ntra >= 0;
- if (trace) {
-/* o__1.oerr = 0;
- o__1.ounit = ntra;
- o__1.ofnmlen = 32;
- o__1.ofnm = snaps;
- o__1.orl = 0;
- o__1.osta = "NEW";
- o__1.oacc = 0;
- o__1.ofm = 0;
- o__1.oblnk = 0;
- f_open(&o__1);*/
- }
-/* Read the flag that directs rewinding of the snapshot file. */
- fgets(line,80,stdin);
- sscanf(line,"%d",&rewi);
- rewi = rewi && trace;
-/* Read the flag that directs stopping on any failure. */
- fgets(line,80,stdin);
- sscanf(line,"%c",&tmpchar);
- sfatal=FALSE_;
- if (tmpchar=='T')sfatal=TRUE_;
-/* Read the flag that indicates whether error exits are to be tested. */
- fgets(line,80,stdin);
- sscanf(line,"%c",&tmpchar);
- tsterr=FALSE_;
- if (tmpchar=='T')tsterr=TRUE_;
-/* Read the flag that indicates whether row-major data layout to be tested. */
- fgets(line,80,stdin);
- sscanf(line,"%d",&layout);
-/* Read the threshold value of the test ratio */
- fgets(line,80,stdin);
- sscanf(line,"%lf",&thresh);
-/* Read and check the parameter values for the tests. */
-
-/* Values of N */
- fgets(line,80,stdin);
-#ifdef USE64BITINT
- sscanf(line,"%d",&nidim);
-#else
- sscanf(line,"%d",&nidim);
-#endif
- if (nidim < 1 || nidim > 9) {
- fprintf(stderr,"NUMBER OF VALUES OF N IS LESS THAN 1 OR GREATER THAN 9");
- goto L220;
- }
- fgets(line,80,stdin);
-#ifdef USE64BITINT
- sscanf(line,"%ld %ld %ld %ld %ld %ld %ld %ld %ld",&idim[0],&idim[1],&idim[2],
- &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]);
-#else
- sscanf(line,"%d %d %d %d %d %d %d %d %d",&idim[0],&idim[1],&idim[2],
- &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]);
-#endif
- i__1 = nidim;
- for (i__ = 1; i__ <= i__1; ++i__) {
- if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) {
- fprintf(stderr,"VALUE OF N IS LESS THAN 0 OR GREATER THAN 65\n");
- goto L220;
- }
-/* L10: */
- }
-/* Values of ALPHA */
- fgets(line,80,stdin);
-#ifdef USE64BITINT
- sscanf(line,"%ld",&nalf);
+static float spow_ui(float x, integer n) {
+ float pow=1.0; unsigned long int u;
+ if(n != 0) {
+ if(n < 0) n = -n, x = 1/x;
+ for(u = n; ; ) {
+ if(u & 01) pow *= x;
+ if(u >>= 1) x *= x;
+ else break;
+ }
+ }
+ return pow;
+}
+static double dpow_ui(double x, integer n) {
+ double pow=1.0; unsigned long int u;
+ if(n != 0) {
+ if(n < 0) n = -n, x = 1/x;
+ for(u = n; ; ) {
+ if(u & 01) pow *= x;
+ if(u >>= 1) x *= x;
+ else break;
+ }
+ }
+ return pow;
+}
+#ifdef _MSC_VER
+static _Fcomplex cpow_ui(complex x, integer n) {
+ complex pow={1.0,0.0}; unsigned long int u;
+ if(n != 0) {
+ if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i;
+ for(u = n; ; ) {
+ if(u & 01) pow.r *= x.r, pow.i *= x.i;
+ if(u >>= 1) x.r *= x.r, x.i *= x.i;
+ else break;
+ }
+ }
+ _Fcomplex p={pow.r, pow.i};
+ return p;
+}
#else
- sscanf(line,"%d",&nalf);
+static _Complex float cpow_ui(_Complex float x, integer n) {
+ _Complex float pow=1.0; unsigned long int u;
+ if(n != 0) {
+ if(n < 0) n = -n, x = 1/x;
+ for(u = n; ; ) {
+ if(u & 01) pow *= x;
+ if(u >>= 1) x *= x;
+ else break;
+ }
+ }
+ return pow;
+}
#endif
- if (nalf < 1 || nalf > 7) {
- fprintf(stderr,"VALUE OF ALPHA IS LESS THAN 0 OR GREATER THAN 7\n");
- goto L220;
- }
- fgets(line,80,stdin);
- sscanf(line,"(%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf)",&alf[0].r,&alf[0].i,&alf[1].r,&alf[1].i,&alf[2].r,&alf[2].i,&alf[3].r,&alf[3].i,
- &alf[4].r,&alf[4].i,&alf[5].r,&alf[5].i,&alf[6].r,&alf[6].i);
-
-/* Values of BETA */
- fgets(line,80,stdin);
-#ifdef USE64BITINT
- sscanf(line,"%ld",&nbet);
+#ifdef _MSC_VER
+static _Dcomplex zpow_ui(_Dcomplex x, integer n) {
+ _Dcomplex pow={1.0,0.0}; unsigned long int u;
+ if(n != 0) {
+ if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1];
+ for(u = n; ; ) {
+ if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1];
+ if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1];
+ else break;
+ }
+ }
+ _Dcomplex p = {pow._Val[0], pow._Val[1]};
+ return p;
+}
#else
- sscanf(line,"%d",&nbet);
+static _Complex double zpow_ui(_Complex double x, integer n) {
+ _Complex double pow=1.0; unsigned long int u;
+ if(n != 0) {
+ if(n < 0) n = -n, x = 1/x;
+ for(u = n; ; ) {
+ if(u & 01) pow *= x;
+ if(u >>= 1) x *= x;
+ else break;
+ }
+ }
+ return pow;
+}
#endif
- if (nalf < 1 || nbet > 7) {
- fprintf(stderr,"VALUE OF BETA IS LESS THAN 0 OR GREATER THAN 7\n");
- goto L220;
- }
- fgets(line,80,stdin);
- sscanf(line,"(%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf)",&bet[0].r,&bet[0].i,&bet[1].r,&bet[1].i,&bet[2].r,&bet[2].i,&bet[3].r,&bet[3].i,
- &bet[4].r,&bet[4].i,&bet[5].r,&bet[5].i,&bet[6].r,&bet[6].i);
-
-/* Report values of parameters. */
-
- printf("TESTS OF THE DOUBLE PRECISION COMPLEX LEVEL 3 BLAS\nTHE FOLLOWING PARAMETER VALUES WILL BE USED:\n");
- printf(" FOR N");
- for (i__ =1; i__ <=nidim;++i__) printf(" %d",idim[i__-1]);
- printf("\n");
- printf(" FOR ALPHA");
- for (i__ =1; i__ <=nalf;++i__) printf(" (%lf,%lf)",alf[i__-1].r,alf[i__-1].i);
- printf("\n");
- printf(" FOR BETA");
- for (i__ =1; i__ <=nbet;++i__) printf(" (%lf,%lf)",bet[i__-1].r,bet[i__-1].i);
- printf("\n");
-
- if (! tsterr) {
- printf(" ERROR-EXITS WILL NOT BE TESTED\n");
- }
-
- printf("ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LESS THAN %lf\n",thresh);
- rorder = FALSE_;
- corder = FALSE_;
- if (layout == 2) {
- rorder = TRUE_;
- corder = TRUE_;
- printf("COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED\n");
- } else if (layout == 1) {
- rorder = TRUE_;
- printf("ROW-MAJOR DATA LAYOUT IS TESTED\n");
- } else if (layout == 0) {
- corder = TRUE_;
- printf("COLUMN-MAJOR DATA LAYOUT IS TESTED\n");
- }
-
-/* Read names of subroutines and flags which indicate */
-/* whether they are to be tested. */
-
- for (i__ = 1; i__ <= 9; ++i__) {
- ltest[i__ - 1] = FALSE_;
-/* L20: */
- }
-L30:
- if (! fgets(line,80,stdin)) {
- goto L60;
- }
- i__1 = sscanf(line,"%12c %c",snamet,&tmpchar);
- ltestt=FALSE_;
- if (tmpchar=='T')ltestt=TRUE_;
- if (i__1 < 2) {
- goto L60;
- }
- for (i__ = 1; i__ <= 9; ++i__) {
- if (s_cmp(snamet, snames[i__ - 1] , (ftnlen)12, (ftnlen)12) ==
- 0) {
- goto L50;
- }
-/* L40: */
- }
- printf("SUBPROGRAM NAME %s NOT RECOGNIZED\n****** TESTS ABANDONED ******\n",snamet);
- exit(1);
-L50:
- ltest[i__ - 1] = ltestt;
- goto L30;
-
-L60:
-/* cl__1.cerr = 0;
- cl__1.cunit = 5;
- cl__1.csta = 0;
- f_clos(&cl__1);*/
-
-/* Compute EPS (the machine precision). */
-
- eps = 1.;
-L70:
- d__1 = eps + 1.;
- if (ddiff_(&d__1, &c_b92) == 0.) {
- goto L80;
- }
- eps *= .5;
- goto L70;
-L80:
- eps += eps;
- printf("RELATIVE MACHINE PRECISION IS TAKEN TO BE %9.1g\n",eps);
-
-/* Check the reliability of ZMMCH using exact data. */
-
- n = 32;
- i__1 = n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = n;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * 65 - 66;
-/* Computing MAX */
- i__5 = i__ - j + 1;
- i__4 = f2cmax(i__5,0);
- ab[i__3].r = (doublereal) i__4, ab[i__3].i = 0.;
-/* L90: */
- }
- i__2 = j + 4224;
- ab[i__2].r = (doublereal) j, ab[i__2].i = 0.;
- i__2 = (j + 65) * 65 - 65;
- ab[i__2].r = (doublereal) j, ab[i__2].i = 0.;
- i__2 = j - 1;
- c__[i__2].r = 0., c__[i__2].i = 0.;
-/* L100: */
- }
- i__1 = n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j - 1;
- i__3 = j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3;
- cc[i__2].r = (doublereal) i__3, cc[i__2].i = 0.;
-/* L110: */
- }
-/* CC holds the exact result. On exit from ZMMCH CT holds */
-/* the result computed by ZMMCH. */
- *(unsigned char *)transa = 'N';
- *(unsigned char *)transb = 'N';
- zmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], &
- c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal,
- &c__6, &c_true, (ftnlen)1, (ftnlen)1);
- same = lze_(cc, ct, &n);
- if (! same || err != 0.) {
- printf("ERROR IN ZMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n");
- printf("ZMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb);
- printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err);
- printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n");
- printf("****** TESTS ABANDONED ******\n");
- exit(1);
- }
- *(unsigned char *)transb = 'C';
- zmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], &
- c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal,
- &c__6, &c_true, (ftnlen)1, (ftnlen)1);
- same = lze_(cc, ct, &n);
- if (! same || err != 0.) {
- printf("ERROR IN ZMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n");
- printf("ZMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb);
- printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err);
- printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n");
- printf("****** TESTS ABANDONED ******\n");
- exit(1);
- }
- i__1 = n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j + 4224;
- i__3 = n - j + 1;
- ab[i__2].r = (doublereal) i__3, ab[i__2].i = 0.;
- i__2 = (j + 65) * 65 - 65;
- i__3 = n - j + 1;
- ab[i__2].r = (doublereal) i__3, ab[i__2].i = 0.;
-/* L120: */
- }
- i__1 = n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = n - j;
- i__3 = j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3;
- cc[i__2].r = (doublereal) i__3, cc[i__2].i = 0.;
-/* L130: */
- }
- *(unsigned char *)transa = 'C';
- *(unsigned char *)transb = 'N';
- zmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], &
- c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal,
- &c__6, &c_true, (ftnlen)1, (ftnlen)1);
- same = lze_(cc, ct, &n);
- if (! same || err != 0.) {
- printf("ERROR IN ZMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n");
- printf("ZMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb);
- printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err);
- printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n");
- printf("****** TESTS ABANDONED ******\n");
- exit(1);
- }
- *(unsigned char *)transb = 'C';
- zmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], &
- c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal,
- &c__6, &c_true, (ftnlen)1, (ftnlen)1);
- same = lze_(cc, ct, &n);
- if (! same || err != 0.) {
- printf("ERROR IN ZMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n");
- printf("ZMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb);
- printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err);
- printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n");
- printf("****** TESTS ABANDONED ******\n");
- exit(1);
- }
-
-/* Test each subroutine in turn. */
-
- for (isnum = 1; isnum <= 9; ++isnum) {
- if (! ltest[isnum - 1]) {
-/* Subprogram is not to be tested. */
- printf("%12s WAS NOT TESTED\n",snames[isnum-1]);
- } else {
- s_copy(srnamc_1.srnamt, snames[isnum - 1], (ftnlen)12, (
- ftnlen)12);
-/* Test error exits. */
- if (tsterr) {
- cz3chke_(snames[isnum - 1], (ftnlen)12);
- }
-/* Test computations. */
- infoc_1.infot = 0;
- infoc_1.ok = TRUE_;
- fatal = FALSE_;
- switch ((int)isnum) {
- case 1: goto L140;
- case 2: goto L150;
- case 3: goto L150;
- case 4: goto L160;
- case 5: goto L160;
- case 6: goto L170;
- case 7: goto L170;
- case 8: goto L180;
- case 9: goto L180;
- }
-/* Test ZGEMM, 01. */
-L140:
- if (corder) {
- zchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,
- cc, cs, ct, g, &c__0, (ftnlen)12);
- }
- if (rorder) {
- zchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,
- cc, cs, ct, g, &c__1, (ftnlen)12);
- }
- goto L190;
-/* Test ZHEMM, 02, ZSYMM, 03. */
-L150:
- if (corder) {
- zchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,
- cc, cs, ct, g, &c__0, (ftnlen)12);
- }
- if (rorder) {
- zchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,
- cc, cs, ct, g, &c__1, (ftnlen)12);
- }
- goto L190;
-/* Test ZTRMM, 04, ZTRSM, 05. */
-L160:
- if (corder) {
- zchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, &
- c__0, (ftnlen)12);
- }
- if (rorder) {
- zchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, &
- c__1, (ftnlen)12);
- }
- goto L190;
-/* Test ZHERK, 06, ZSYRK, 07. */
-L170:
- if (corder) {
- zchk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,
- cc, cs, ct, g, &c__0, (ftnlen)12);
- }
- if (rorder) {
- zchk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,
- cc, cs, ct, g, &c__1, (ftnlen)12);
- }
- goto L190;
-/* Test ZHER2K, 08, ZSYR2K, 09. */
-L180:
- if (corder) {
- zchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs,
- ct, g, w, &c__0, (ftnlen)12);
- }
- if (rorder) {
- zchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,
- &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &
- nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs,
- ct, g, w, &c__1, (ftnlen)12);
- }
- goto L190;
-
-L190:
- if (fatal && sfatal) {
- goto L210;
- }
- }
-/* L200: */
- }
- printf("\nEND OF TESTS\n");
- goto L230;
-
-L210:
- printf("\n****** FATAL ERROR - TESTS ABANDONED ******\n");
- goto L230;
-
-L220:
- printf("AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM\n");
- printf("****** TESTS ABANDONED ******\n");
-
-L230:
- if (trace) {
-/* cl__1.cerr = 0;
- cl__1.cunit = ntra;
- cl__1.csta = 0;
- f_clos(&cl__1);*/
- }
-/* cl__1.cerr = 0;
- cl__1.cunit = 6;
- cl__1.csta = 0;
- f_clos(&cl__1);*/
- exit(0);
-
-/* End of ZBLAT3. */
-
-} /* MAIN__ */
-
-/* Subroutine */ int zchk1_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublecomplex* alf, integer* nbet, doublecomplex* bet, integer* nmax, doublecomplex* a, doublecomplex* aa, doublecomplex* as, doublecomplex* b, doublecomplex* bb, doublecomplex* bs, doublecomplex* c__, doublecomplex* cc, doublecomplex* cs, doublecomplex* ct, doublereal* g, integer* iorder, ftnlen sname_len)
-{
- /* Initialized data */
-
- static char ich[3+1] = "NTC";
-
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
- i__3, i__4, i__5, i__6, i__7, i__8;
-
- /* Local variables */
- static doublecomplex beta;
- static integer ldas, ldbs, ldcs;
- static logical same, null;
- static integer i__, k, m, n;
- static doublecomplex alpha;
- static logical isame[13], trana, tranb;
- extern /* Subroutine */ int zmake_(char*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, logical*, doublecomplex*, ftnlen, ftnlen, ftnlen);
- static integer nargs;
- extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen);
- static logical reset;
- static integer ia, ib;
- extern /* Subroutine */ int zprcn1_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, integer*, doublecomplex*, integer*, integer*, doublecomplex*, integer*, ftnlen, ftnlen, ftnlen);
- static integer ma, mb, na, nb, nc, ik, im, in, ks, ms, ns;
- extern /* Subroutine */ void czgemm_(integer*, char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen);
- static char tranas[1], tranbs[1], transa[1], transb[1];
- static doublereal errmax;
- extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen);
- static integer ica, icb, laa, lbb, lda, lcc, ldb, ldc;
- static doublecomplex als, bls;
- static doublereal err;
- extern logical lze_(doublecomplex*, doublecomplex*, integer*);
-
-/* Tests ZGEMM. */
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Parameters .. */
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. Local Scalars .. */
-/* .. Local Arrays .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Scalars in Common .. */
-/* .. Common blocks .. */
-/* .. Data statements .. */
- /* Parameter adjustments */
- --idim;
- --alf;
- --bet;
- --g;
- --ct;
- --cs;
- --cc;
- c_dim1 = *nmax;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
- --bs;
- --bb;
- b_dim1 = *nmax;
- b_offset = 1 + b_dim1 * 1;
- b -= b_offset;
- --as;
- --aa;
- a_dim1 = *nmax;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
-
- /* Function Body */
-/* .. Executable Statements .. */
-
- nargs = 13;
- nc = 0;
- reset = TRUE_;
- errmax = 0.;
-
- i__1 = *nidim;
- for (im = 1; im <= i__1; ++im) {
- m = idim[im];
-
- i__2 = *nidim;
- for (in = 1; in <= i__2; ++in) {
- n = idim[in];
-/* Set LDC to 1 more than minimum value if room. */
- ldc = m;
- if (ldc < *nmax) {
- ++ldc;
- }
-/* Skip tests if not enough room. */
- if (ldc > *nmax) {
- goto L100;
- }
- lcc = ldc * n;
- null = n <= 0 || m <= 0;
-
- i__3 = *nidim;
- for (ik = 1; ik <= i__3; ++ik) {
- k = idim[ik];
-
- for (ica = 1; ica <= 3; ++ica) {
- *(unsigned char *)transa = *(unsigned char *)&ich[ica - 1]
- ;
- trana = *(unsigned char *)transa == 'T' || *(unsigned
- char *)transa == 'C';
-
- if (trana) {
- ma = k;
- na = m;
- } else {
- ma = m;
- na = k;
- }
-/* Set LDA to 1 more than minimum value if room. */
- lda = ma;
- if (lda < *nmax) {
- ++lda;
- }
-/* Skip tests if not enough room. */
- if (lda > *nmax) {
- goto L80;
- }
- laa = lda * na;
-
-/* Generate the matrix A. */
-
- zmake_("ge", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[
- 1], &lda, &reset, &c_b1, (ftnlen)2, (ftnlen)1, (
- ftnlen)1);
-
- for (icb = 1; icb <= 3; ++icb) {
- *(unsigned char *)transb = *(unsigned char *)&ich[icb
- - 1];
- tranb = *(unsigned char *)transb == 'T' || *(unsigned
- char *)transb == 'C';
-
- if (tranb) {
- mb = n;
- nb = k;
- } else {
- mb = k;
- nb = n;
- }
-/* Set LDB to 1 more than minimum value if room. */
- ldb = mb;
- if (ldb < *nmax) {
- ++ldb;
- }
-/* Skip tests if not enough room. */
- if (ldb > *nmax) {
- goto L70;
- }
- lbb = ldb * nb;
-
-/* Generate the matrix B. */
-
- zmake_("ge", " ", " ", &mb, &nb, &b[b_offset], nmax, &
- bb[1], &ldb, &reset, &c_b1, (ftnlen)2, (
- ftnlen)1, (ftnlen)1);
-
- i__4 = *nalf;
- for (ia = 1; ia <= i__4; ++ia) {
- i__5 = ia;
- alpha.r = alf[i__5].r, alpha.i = alf[i__5].i;
-
- i__5 = *nbet;
- for (ib = 1; ib <= i__5; ++ib) {
- i__6 = ib;
- beta.r = bet[i__6].r, beta.i = bet[i__6].i;
-
-/* Generate the matrix C. */
-
- zmake_("ge", " ", " ", &m, &n, &c__[c_offset],
- nmax, &cc[1], &ldc, &reset, &c_b1, (
- ftnlen)2, (ftnlen)1, (ftnlen)1);
-
- ++nc;
-
-/* Save every datum before calling the */
-/* subroutine. */
-
- *(unsigned char *)tranas = *(unsigned char *)
- transa;
- *(unsigned char *)tranbs = *(unsigned char *)
- transb;
- ms = m;
- ns = n;
- ks = k;
- als.r = alpha.r, als.i = alpha.i;
- i__6 = laa;
- for (i__ = 1; i__ <= i__6; ++i__) {
- i__7 = i__;
- i__8 = i__;
- as[i__7].r = aa[i__8].r, as[i__7].i = aa[
- i__8].i;
-/* L10: */
- }
- ldas = lda;
- i__6 = lbb;
- for (i__ = 1; i__ <= i__6; ++i__) {
- i__7 = i__;
- i__8 = i__;
- bs[i__7].r = bb[i__8].r, bs[i__7].i = bb[
- i__8].i;
-/* L20: */
- }
- ldbs = ldb;
- bls.r = beta.r, bls.i = beta.i;
- i__6 = lcc;
- for (i__ = 1; i__ <= i__6; ++i__) {
- i__7 = i__;
- i__8 = i__;
- cs[i__7].r = cc[i__8].r, cs[i__7].i = cc[
- i__8].i;
-/* L30: */
- }
- ldcs = ldc;
-
-/* Call the subroutine. */
-
- if (*trace) {
- zprcn1_(ntra, &nc, sname, iorder, transa,
- transb, &m, &n, &k, &alpha, &lda,
- &ldb, &beta, &ldc, (ftnlen)12, (
- ftnlen)1, (ftnlen)1);
- }
- if (*rewi) {
-/* al__1.aerr = 0;
- al__1.aunit = *ntra;
- f_rew(&al__1);*/
- }
- czgemm_(iorder, transa, transb, &m, &n, &k, &
- alpha, &aa[1], &lda, &bb[1], &ldb, &
- beta, &cc[1], &ldc, (ftnlen)1, (
- ftnlen)1);
-
-/* Check if error-exit was taken incorrectly. */
-
- if (! infoc_1.ok) {
- printf(" *** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");
- *fatal = TRUE_;
- goto L120;
- }
-
-/* See what data changed inside subroutines. */
-
- isame[0] = *(unsigned char *)transa == *(
- unsigned char *)tranas;
- isame[1] = *(unsigned char *)transb == *(
- unsigned char *)tranbs;
- isame[2] = ms == m;
- isame[3] = ns == n;
- isame[4] = ks == k;
- isame[5] = als.r == alpha.r && als.i ==
- alpha.i;
- isame[6] = lze_(&as[1], &aa[1], &laa);
- isame[7] = ldas == lda;
- isame[8] = lze_(&bs[1], &bb[1], &lbb);
- isame[9] = ldbs == ldb;
- isame[10] = bls.r == beta.r && bls.i ==
- beta.i;
- if (null) {
- isame[11] = lze_(&cs[1], &cc[1], &lcc);
- } else {
- isame[11] = lzeres_("ge", " ", &m, &n, &
- cs[1], &cc[1], &ldc, (ftnlen)2, (
- ftnlen)1);
- }
- isame[12] = ldcs == ldc;
-
-/* If data was incorrectly changed, report */
-/* and return. */
-
- same = TRUE_;
- i__6 = nargs;
- for (i__ = 1; i__ <= i__6; ++i__) {
- same = same && isame[i__ - 1];
- if (! isame[i__ - 1]) {
- printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
- }
-/* L40: */
- }
- if (! same) {
- *fatal = TRUE_;
- goto L120;
- }
-
- if (! null) {
-
-/* Check the result. */
-
- zmmch_(transa, transb, &m, &n, &k, &alpha,
- &a[a_offset], nmax, &b[b_offset],
- nmax, &beta, &c__[c_offset],
- nmax, &ct[1], &g[1], &cc[1], &ldc,
- eps, &err, fatal, nout, &c_true,
- (ftnlen)1, (ftnlen)1);
- errmax = f2cmax(errmax,err);
-/* If got really bad answer, report and */
-/* return. */
- if (*fatal) {
- goto L120;
- }
- }
-
-/* L50: */
- }
-
-/* L60: */
- }
-
-L70:
- ;
- }
-
-L80:
- ;
- }
-
-/* L90: */
- }
-
-L100:
- ;
- }
-
-/* L110: */
- }
-
-/* Report result. */
-
- if (errmax < *thresh) {
- if (*iorder == 0) {
- printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
- }
- if (*iorder == 1) {
- printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
- }
- } else {
- if (*iorder == 0) {
- printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);
- printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);
- }
- if (*iorder == 1) {
- printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);
- printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);
- }
- }
- goto L130;
-
-L120:
- printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
- zprcn1_(nout, &nc, sname, iorder, transa, transb, &m, &n, &k, &alpha, &
- lda, &ldb, &beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1);
-
-L130:
- return 0;
-
-/* 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',', */
-/* $ 3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, */
-/* $ ',(', F4.1, ',', F4.1, '), C,', I3, ').' ) */
-
-/* End of ZCHK1. */
-
-} /* zchk1_ */
-
-
-/* Subroutine */ int zprcn1_(integer* nout, integer* nc, char* sname, integer* iorder, char* transa, char* transb, integer* m, integer* n, integer* k, doublecomplex* alpha, integer* lda, integer* ldb, doublecomplex* beta, integer* ldc, ftnlen sname_len, ftnlen transa_len, ftnlen transb_len)
+static integer pow_ii(integer x, integer n) {
+ integer pow; unsigned long int u;
+ if (n <= 0) {
+ if (n == 0 || x == 1) pow = 1;
+ else if (x != -1) pow = x == 0 ? 1/x : 0;
+ else n = -n;
+ }
+ if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
+ u = n;
+ for(pow = 1; ; ) {
+ if(u & 01) pow *= x;
+ if(u >>= 1) x *= x;
+ else break;
+ }
+ }
+ return pow;
+}
+static integer dmaxloc_(double *w, integer s, integer e, integer *n)
{
- /* Local variables */
- static char crc[14], cta[14], ctb[14];
-
- if (*(unsigned char *)transa == 'N') {
- s_copy(cta, " CblasNoTrans", (ftnlen)14, (ftnlen)14);
- } else if (*(unsigned char *)transa == 'T') {
- s_copy(cta, " CblasTrans", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(cta, "CblasConjTrans", (ftnlen)14, (ftnlen)14);
- }
- if (*(unsigned char *)transb == 'N') {
- s_copy(ctb, " CblasNoTrans", (ftnlen)14, (ftnlen)14);
- } else if (*(unsigned char *)transb == 'T') {
- s_copy(ctb, " CblasTrans", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(ctb, "CblasConjTrans", (ftnlen)14, (ftnlen)14);
- }
- if (*iorder == 1) {
- s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
- }
- printf("%6d: %s %s %s %s\n",*nc,sname,crc,cta,ctb);
- printf("%d %d %d (%4.1lf,%4.1lf) , A, %d, B, %d, (%4.1lf,%4.1lf) , C, %d.\n",*m,*n,*k,alpha->r,alpha->i,*lda,*ldb,beta->r,beta->i,*ldc);
-
-return 0;
-} /* zprcn1_ */
-
-
-/* Subroutine */ int zchk2_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublecomplex* alf, integer* nbet, doublecomplex* bet, integer* nmax, doublecomplex* a, doublecomplex* aa, doublecomplex* as, doublecomplex* b, doublecomplex* bb, doublecomplex* bs, doublecomplex* c__, doublecomplex* cc, doublecomplex* cs, doublecomplex* ct, doublereal* g, integer* iorder, ftnlen sname_len)
+ double m; integer i, mi;
+ for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+ if (w[i-1]>m) mi=i ,m=w[i-1];
+ return mi-s+1;
+}
+static integer smaxloc_(float *w, integer s, integer e, integer *n)
{
- /* Initialized data */
-
- static char ichs[2+1] = "LR";
- static char ichu[2+1] = "UL";
-
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
- i__3, i__4, i__5, i__6, i__7;
-
- /* Local variables */
- static doublecomplex beta;
- static integer ldas, ldbs, ldcs;
- static logical same;
- static char side[1];
- static logical isconj, left, null;
- static char uplo[1];
- static integer i__, m, n;
- static doublecomplex alpha;
- static logical isame[13];
- static char sides[1];
- extern /* Subroutine */ int zmake_(char*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, logical*, doublecomplex*, ftnlen, ftnlen, ftnlen);
- static integer nargs;
- extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen);
- static logical reset;
- static char uplos[1];
- static integer ia, ib;
- extern /* Subroutine */ int zprcn2_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublecomplex*, integer*, integer*, doublecomplex*, integer*, ftnlen, ftnlen, ftnlen);
- static integer na, nc, im, in, ms, ns;
- extern /* Subroutine */ void czhemm_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen);
- static doublereal errmax;
- extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen);
- extern /* Subroutine */ void czsymm_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen);
- static integer laa, lbb, lda, lcc, ldb, ldc, ics;
- static doublecomplex als, bls;
- static integer icu;
- static doublereal err;
- extern logical lze_(doublecomplex*, doublecomplex*, integer*);
-
-/* Tests ZHEMM and ZSYMM. */
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Parameters .. */
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. Local Scalars .. */
-/* .. Local Arrays .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Scalars in Common .. */
-/* .. Common blocks .. */
-/* .. Data statements .. */
- /* Parameter adjustments */
- --idim;
- --alf;
- --bet;
- --g;
- --ct;
- --cs;
- --cc;
- c_dim1 = *nmax;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
- --bs;
- --bb;
- b_dim1 = *nmax;
- b_offset = 1 + b_dim1 * 1;
- b -= b_offset;
- --as;
- --aa;
- a_dim1 = *nmax;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
-
- /* Function Body */
-/* .. Executable Statements .. */
- isconj = s_cmp(sname + 7, "he", (ftnlen)2, (ftnlen)2) == 0;
-
- nargs = 12;
- nc = 0;
- reset = TRUE_;
- errmax = 0.;
-
- i__1 = *nidim;
- for (im = 1; im <= i__1; ++im) {
- m = idim[im];
-
- i__2 = *nidim;
- for (in = 1; in <= i__2; ++in) {
- n = idim[in];
-/* Set LDC to 1 more than minimum value if room. */
- ldc = m;
- if (ldc < *nmax) {
- ++ldc;
- }
-/* Skip tests if not enough room. */
- if (ldc > *nmax) {
- goto L90;
- }
- lcc = ldc * n;
- null = n <= 0 || m <= 0;
-/* Set LDB to 1 more than minimum value if room. */
- ldb = m;
- if (ldb < *nmax) {
- ++ldb;
- }
-/* Skip tests if not enough room. */
- if (ldb > *nmax) {
- goto L90;
- }
- lbb = ldb * n;
-
-/* Generate the matrix B. */
-
- zmake_("ge", " ", " ", &m, &n, &b[b_offset], nmax, &bb[1], &ldb, &
- reset, &c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)1);
-
- for (ics = 1; ics <= 2; ++ics) {
- *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1];
- left = *(unsigned char *)side == 'L';
-
- if (left) {
- na = m;
- } else {
- na = n;
+ float m; integer i, mi;
+ for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
+ if (w[i-1]>m) mi=i ,m=w[i-1];
+ return mi-s+1;
+}
+static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
+ integer n = *n_, incx = *incx_, incy = *incy_, i;
+#ifdef _MSC_VER
+ _Fcomplex zdotc = {0.0, 0.0};
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<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];
}
-/* Set LDA to 1 more than minimum value if room. */
- lda = na;
- if (lda < *nmax) {
- ++lda;
+ } 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];
}
-/* Skip tests if not enough room. */
- if (lda > *nmax) {
- goto L80;
+ }
+ 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]);
}
- 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: */
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
}
-
-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);
+ 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];
+ }
}
- } 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);
+ 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]);
+ }
}
- 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);
+ 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];
+ }
}
- }
- 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_(integer* nout, integer* nc, char* sname, integer* iorder, char* side, char* uplo, integer* m, integer* n, doublecomplex* alpha, integer* lda, integer* 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_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublecomplex* alf, integer* nmax, doublecomplex* a, doublecomplex* aa, doublecomplex* as, doublecomplex* b, doublecomplex* bb, doublecomplex* bs, doublecomplex* ct, doublereal* g, doublecomplex* c__, integer* iorder, ftnlen sname_len)
-{
- /* Initialized data */
-
- static char ichu[2+1] = "UL";
- static char icht[3+1] = "NTC";
- static char ichd[2+1] = "UN";
- static char ichs[2+1] = "LR";
-
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
- i__3, i__4, i__5, i__6, i__7;
- doublecomplex z__1;
-
- /* Local variables */
- static char diag[1];
- static integer ldas, ldbs;
- static logical same;
- static char side[1];
- static logical left, null;
- static char uplo[1];
- static integer i__, j, m, n;
- static doublecomplex alpha;
- static char diags[1];
- static logical isame[13];
- static char sides[1];
- extern /* Subroutine */ int zmake_(char*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, logical*, doublecomplex*, ftnlen, ftnlen, ftnlen);
- static integer nargs;
- extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen);
- static logical reset;
- static char uplos[1];
- static integer ia, na;
- extern /* Subroutine */ int zprcn3_(integer*, integer*, char*, integer*, char*, char*, char*, char*, integer*, integer*, doublecomplex*, integer*, integer*, ftnlen, ftnlen, ftnlen, ftnlen, ftnlen);
- static integer nc, im, in, ms, ns;
- static char tranas[1], transa[1];
- static doublereal errmax;
- extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen);
- extern /* Subroutine */ void cztrmm_(integer*, char*, char*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, ftnlen, ftnlen, ftnlen, ftnlen);
- extern /* Subroutine */ void cztrsm_(integer*, char*, char*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, ftnlen, ftnlen, ftnlen, ftnlen);
- static integer laa, icd, lbb, lda, ldb, ics;
- static doublecomplex als;
- static integer ict, icu;
- static doublereal err;
- extern logical lze_(doublecomplex*, doublecomplex*, integer*);
-
-/* Tests ZTRMM and ZTRSM. */
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Parameters .. */
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. Local Scalars .. */
-/* .. Local Arrays .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Scalars in Common .. */
-/* .. Common blocks .. */
-/* .. Data statements .. */
- /* Parameter adjustments */
- --idim;
- --alf;
- c_dim1 = *nmax;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
- --g;
- --ct;
- --bs;
- --bb;
- b_dim1 = *nmax;
- b_offset = 1 + b_dim1 * 1;
- b -= b_offset;
- --as;
- --aa;
- a_dim1 = *nmax;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
-
- /* Function Body */
-/* .. Executable Statements .. */
-
- nargs = 11;
- nc = 0;
- reset = TRUE_;
- errmax = 0.;
-/* Set up zero matrix for ZMMCH. */
- i__1 = *nmax;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *nmax;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- c__[i__3].r = 0., c__[i__3].i = 0.;
-/* L10: */
+ pCf(z) = zdotc;
+}
+#else
+ _Complex float zdotc = 0.0;
+ if (incx == 1 && incy == 1) {
+ for (i=0;i<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]);
+ }
}
-/* 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;
+ 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];
}
-/* Set LDA to 1 more than minimum value if room. */
- lda = na;
- if (lda < *nmax) {
- ++lda;
+ } 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];
}
-/* Skip tests if not enough room. */
- if (lda > *nmax) {
- goto L130;
+ }
+ 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]);
}
- 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: */
+ } else {
+ for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
+ zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
}
-
-/* L120: */
- }
-
-L130:
- ;
}
+ pCd(z) = zdotc;
+}
+#endif
+/* -- translated by f2c (version 20000121).
+ You must link the resulting object file with the libraries:
+ -lf2c -lm (in that order)
+*/
-/* 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_(integer* nout, integer* nc, char* sname, integer* iorder, char* side, char* uplo, char* transa, char* diag, integer* m, integer* n, doublecomplex* alpha, integer* lda, integer* ldb, ftnlen sname_len, ftnlen side_len, ftnlen uplo_len, ftnlen transa_len, ftnlen diag_len)
-{
-
- /* Local variables */
- static char ca[14], cd[14], cs[14], cu[14], crc[14];
-
- if (*(unsigned char *)side == 'L') {
- s_copy(cs, " CblasLeft", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(cs, " CblasRight", (ftnlen)14, (ftnlen)14);
- }
- if (*(unsigned char *)uplo == 'U') {
- s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14);
- }
- if (*(unsigned char *)transa == 'N') {
- s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14);
- } else if (*(unsigned char *)transa == 'T') {
- s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14);
- }
- if (*(unsigned char *)diag == 'N') {
- s_copy(cd, " CblasNonUnit", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(cd, " CblasUnit", (ftnlen)14, (ftnlen)14);
- }
- if (*iorder == 1) {
- s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
- }
- printf("%6d: %s %s %s %s\n",*nc,sname,crc,cs,cu);
- printf(" %s %s %d %d (%4.1lf,%4.1lf) A %d B %d\n",ca,cd,*m,*n,alpha->r,alpha->i,*lda,*ldb);
-
-return 0;
-} /* zprcn3_ */
-
-
-/* Subroutine */ int zchk4_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublecomplex* alf, integer* nbet, doublecomplex* bet, integer* nmax, doublecomplex* a, doublecomplex* aa, doublecomplex* as, doublecomplex* b, doublecomplex* bb, doublecomplex* bs, doublecomplex* c__, doublecomplex* cc, doublecomplex* cs, doublecomplex* ct, doublereal* g, integer* iorder, ftnlen sname_len)
-{
- /* Initialized data */
-
- static char icht[2+1] = "NC";
- static char ichu[2+1] = "UL";
-
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
- i__3, i__4, i__5, i__6, i__7;
- doublecomplex z__1;
-
- /* Local variables */
- static doublecomplex beta;
- static integer ldas, ldcs;
- static logical same, isconj;
- static doublecomplex bets;
- static doublereal rals;
- static logical tran, null;
- static char uplo[1];
- static integer i__, j, k, n;
- static doublecomplex alpha;
- static doublereal rbeta;
- static logical isame[13];
- extern /* Subroutine */ int zmake_(char*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, logical*, doublecomplex*, ftnlen, ftnlen, ftnlen);
- static integer nargs;
- extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen);
- static doublereal rbets;
- static logical reset;
- static char trans[1];
- static logical upper;
- static char uplos[1];
- static integer ia, ib, jc, ma, na;
- extern /* Subroutine */ int zprcn4_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, ftnlen, ftnlen, ftnlen);
- static integer nc;
- extern /* Subroutine */ int zprcn6_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen);
- static integer ik, in, jj, lj, ks, ns;
- static doublereal ralpha;
- extern /* Subroutine */ int czherk_(integer*, char*, char*, integer*, integer*, doublereal*, doublecomplex*, integer*, doublereal*, doublecomplex*, integer*, ftnlen, ftnlen);
- static doublereal errmax;
- extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen);
- static char transs[1], transt[1];
- extern /* Subroutine */ int czsyrk_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen);
- static integer laa, lda, lcc, ldc;
- static doublecomplex als;
- static integer ict, icu;
- static doublereal err;
- extern logical lze_(doublecomplex*, doublecomplex*, integer*);
-
-/* Tests ZHERK and ZSYRK. */
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Parameters .. */
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. Local Scalars .. */
-/* .. Local Arrays .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Scalars in Common .. */
-/* .. Common blocks .. */
-/* .. Data statements .. */
- /* Parameter adjustments */
- --idim;
- --alf;
- --bet;
- --g;
- --ct;
- --cs;
- --cc;
- c_dim1 = *nmax;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
- --bs;
- --bb;
- b_dim1 = *nmax;
- b_offset = 1 + b_dim1 * 1;
- b -= b_offset;
- --as;
- --aa;
- a_dim1 = *nmax;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
-
- /* Function Body */
-/* .. Executable Statements .. */
- isconj = s_cmp(sname + 7, "he", (ftnlen)2, (ftnlen)2) == 0;
-
- nargs = 10;
- nc = 0;
- reset = TRUE_;
- errmax = 0.;
- rals = 1.;
- rbets = 1.;
-
- i__1 = *nidim;
- for (in = 1; in <= i__1; ++in) {
- n = idim[in];
-/* Set LDC to 1 more than minimum value if room. */
- ldc = n;
- if (ldc < *nmax) {
- ++ldc;
- }
-/* Skip tests if not enough room. */
- if (ldc > *nmax) {
- goto L100;
- }
- lcc = ldc * n;
-
- i__2 = *nidim;
- for (ik = 1; ik <= i__2; ++ik) {
- k = idim[ik];
-
- for (ict = 1; ict <= 2; ++ict) {
- *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1];
- tran = *(unsigned char *)trans == 'C';
- if (tran && ! isconj) {
- *(unsigned char *)trans = 'T';
- }
- if (tran) {
- ma = k;
- na = n;
- } else {
- ma = n;
- na = k;
- }
-/* Set LDA to 1 more than minimum value if room. */
- lda = ma;
- if (lda < *nmax) {
- ++lda;
- }
-/* Skip tests if not enough room. */
- if (lda > *nmax) {
- goto L80;
- }
- laa = lda * na;
-
-/* Generate the matrix A. */
-
- zmake_("ge", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[1], &
- lda, &reset, &c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)1);
-
- for (icu = 1; icu <= 2; ++icu) {
- *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];
- upper = *(unsigned char *)uplo == 'U';
-
- i__3 = *nalf;
- for (ia = 1; ia <= i__3; ++ia) {
- i__4 = ia;
- alpha.r = alf[i__4].r, alpha.i = alf[i__4].i;
- if (isconj) {
- ralpha = alpha.r;
- z__1.r = ralpha, z__1.i = 0.;
- alpha.r = z__1.r, alpha.i = z__1.i;
- }
-
- i__4 = *nbet;
- for (ib = 1; ib <= i__4; ++ib) {
- i__5 = ib;
- beta.r = bet[i__5].r, beta.i = bet[i__5].i;
- if (isconj) {
- rbeta = beta.r;
- z__1.r = rbeta, z__1.i = 0.;
- beta.r = z__1.r, beta.i = z__1.i;
- }
- null = n <= 0;
- if (isconj) {
- null = null ||( (k <= 0 || ralpha == 0.) &&
- rbeta == 1.);
- }
-
-/* Generate the matrix C. */
-
- zmake_(sname + 7, uplo, " ", &n, &n, &c__[
- c_offset], nmax, &cc[1], &ldc, &reset, &
- c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)1);
-
- ++nc;
-
-/* Save every datum before calling the subroutine. */
-
- *(unsigned char *)uplos = *(unsigned char *)uplo;
- *(unsigned char *)transs = *(unsigned char *)
- trans;
- ns = n;
- ks = k;
- if (isconj) {
- rals = ralpha;
- } else {
- als.r = alpha.r, als.i = alpha.i;
- }
- i__5 = laa;
- for (i__ = 1; i__ <= i__5; ++i__) {
- i__6 = i__;
- i__7 = i__;
- as[i__6].r = aa[i__7].r, as[i__6].i = aa[i__7]
- .i;
-/* L10: */
- }
- ldas = lda;
- if (isconj) {
- rbets = rbeta;
- } else {
- bets.r = beta.r, bets.i = beta.i;
- }
- i__5 = lcc;
- for (i__ = 1; i__ <= i__5; ++i__) {
- i__6 = i__;
- i__7 = i__;
- cs[i__6].r = cc[i__7].r, cs[i__6].i = cc[i__7]
- .i;
-/* L20: */
- }
- ldcs = ldc;
-
-/* Call the subroutine. */
-
- if (isconj) {
- if (*trace) {
- zprcn6_(ntra, &nc, sname, iorder, uplo,
- trans, &n, &k, &ralpha, &lda, &
- rbeta, &ldc, (ftnlen)12, (ftnlen)
- 1, (ftnlen)1);
- }
- if (*rewi) {
-/* al__1.aerr = 0;
- al__1.aunit = *ntra;
- f_rew(&al__1);*/
- }
- czherk_(iorder, uplo, trans, &n, &k, &ralpha,
- &aa[1], &lda, &rbeta, &cc[1], &ldc, (
- ftnlen)1, (ftnlen)1);
- } else {
- if (*trace) {
- zprcn4_(ntra, &nc, sname, iorder, uplo,
- trans, &n, &k, &alpha, &lda, &
- beta, &ldc, (ftnlen)12, (ftnlen)1,
- (ftnlen)1);
- }
- if (*rewi) {
-/* al__1.aerr = 0;
- al__1.aunit = *ntra;
- f_rew(&al__1);*/
- }
- czsyrk_(iorder, uplo, trans, &n, &k, &alpha, &
- aa[1], &lda, &beta, &cc[1], &ldc, (
- ftnlen)1, (ftnlen)1);
- }
-
-/* Check if error-exit was taken incorrectly. */
-
- if (! infoc_1.ok) {
- printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");
- *fatal = TRUE_;
- goto L120;
- }
-
-/* See what data changed inside subroutines. */
-
- isame[0] = *(unsigned char *)uplos == *(unsigned
- char *)uplo;
- isame[1] = *(unsigned char *)transs == *(unsigned
- char *)trans;
- isame[2] = ns == n;
- isame[3] = ks == k;
- if (isconj) {
- isame[4] = rals == ralpha;
- } else {
- isame[4] = als.r == alpha.r && als.i ==
- alpha.i;
- }
- isame[5] = lze_(&as[1], &aa[1], &laa);
- isame[6] = ldas == lda;
- if (isconj) {
- isame[7] = rbets == rbeta;
- } else {
- isame[7] = bets.r == beta.r && bets.i ==
- beta.i;
- }
- if (null) {
- isame[8] = lze_(&cs[1], &cc[1], &lcc);
- } else {
- isame[8] = lzeres_(sname + 7, uplo, &n, &n, &
- cs[1], &cc[1], &ldc, (ftnlen)2, (
- ftnlen)1);
- }
- isame[9] = ldcs == ldc;
-
-/* If data was incorrectly changed, report and */
-/* return. */
-
- same = TRUE_;
- i__5 = nargs;
- for (i__ = 1; i__ <= i__5; ++i__) {
- same = same && isame[i__ - 1];
- if (! isame[i__ - 1]) {
- printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
- }
-/* L30: */
- }
- if (! same) {
- *fatal = TRUE_;
- goto L120;
- }
-
- if (! null) {
-
-/* Check the result column by column. */
-
- if (isconj) {
- *(unsigned char *)transt = 'C';
- } else {
- *(unsigned char *)transt = 'T';
- }
- jc = 1;
- i__5 = n;
- for (j = 1; j <= i__5; ++j) {
- if (upper) {
- jj = 1;
- lj = j;
- } else {
- jj = j;
- lj = n - j + 1;
- }
- if (tran) {
- zmmch_(transt, "N", &lj, &c__1, &k, &
- alpha, &a[jj * a_dim1 + 1],
- nmax, &a[j * a_dim1 + 1],
- nmax, &beta, &c__[jj + j *
- c_dim1], nmax, &ct[1], &g[1],
- &cc[jc], &ldc, eps, &err,
- fatal, nout, &c_true, (ftnlen)
- 1, (ftnlen)1);
- } else {
- zmmch_("N", transt, &lj, &c__1, &k, &
- alpha, &a[jj + a_dim1], nmax,
- &a[j + a_dim1], nmax, &beta, &
- c__[jj + j * c_dim1], nmax, &
- ct[1], &g[1], &cc[jc], &ldc,
- eps, &err, fatal, nout, &
- c_true, (ftnlen)1, (ftnlen)1);
- }
- if (upper) {
- jc += ldc;
- } else {
- jc = jc + ldc + 1;
- }
- errmax = f2cmax(errmax,err);
-/* If got really bad answer, report and */
-/* return. */
- if (*fatal) {
- goto L110;
- }
-/* L40: */
- }
- }
-
-/* L50: */
- }
-
-/* L60: */
- }
-
-/* L70: */
- }
-
-L80:
- ;
- }
-
-/* L90: */
- }
-
-L100:
- ;
- }
-
-/* Report result. */
-
- if (errmax < *thresh) {
- if (*iorder == 0) {
- printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
- }
- if (*iorder == 1) {
- printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
- }
- } else {
- if (*iorder == 0) {
- printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);
- printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);
- }
- if (*iorder == 1) {
- printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);
- printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);
- }
- }
- goto L130;
-
-L110:
- if (n > 1) {
- printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j);
- }
-
-L120:
- printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
- if (isconj) {
- zprcn6_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &ralpha, &lda,
- &rbeta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1);
- } else {
- zprcn4_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &
- beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1);
- }
-
-L130:
- return 0;
-
-/* 9994 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */
-/* $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') ', */
-/* $ ' .' ) */
-/* 9993 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */
-/* $ '(', F4.1, ',', F4.1, ') , A,', I3, ',(', F4.1, ',', F4.1, */
-/* $ '), C,', I3, ') .' ) */
-
-/* End of CCHK4. */
-
-} /* zchk4_ */
-
-
-/* Subroutine */ int zprcn4_(integer* nout, integer* nc, char* sname, integer* iorder, char* uplo, char* transa, integer* n, integer* k, doublecomplex* alpha, integer* lda, doublecomplex* beta, integer* ldc, ftnlen sname_len, ftnlen uplo_len, ftnlen transa_len)
-{
- /* Local variables */
- static char ca[14], cu[14], crc[14];
-
- if (*(unsigned char *)uplo == 'U') {
- s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14);
- }
- if (*(unsigned char *)transa == 'N') {
- s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14);
- } else if (*(unsigned char *)transa == 'T') {
- s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14);
- }
- if (*iorder == 1) {
- s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
- }
- printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca);
- printf("( %d %d (%4.1lf,%4.1lf) A %d (%4.1lf,%4.1lf) C %d\n",*n,*k,alpha->r,alpha->i,*lda,beta->r,beta->i,*ldc);
-
-return 0;
-} /* zprcn4_ */
-
-
-
-/* Subroutine */ int zprcn6_(integer* nout, integer* nc, char* sname, integer* iorder, char* uplo, char* transa, integer* n, integer* k, doublereal* alpha, integer* lda, doublereal* beta, integer* ldc, ftnlen sname_len, ftnlen uplo_len, ftnlen transa_len)
-{
-
- /* Local variables */
- static char ca[14], cu[14], crc[14];
-
- if (*(unsigned char *)uplo == 'U') {
- s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14);
- }
- if (*(unsigned char *)transa == 'N') {
- s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14);
- } else if (*(unsigned char *)transa == 'T') {
- s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14);
- }
- if (*iorder == 1) {
- s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
- }
- printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca);
- printf("( %d %d %4.1lf A %d %4.1lf C %d\n",*n,*k,*alpha,*lda,*beta,*ldc);
-
-return 0;
-} /* zprcn6_ */
-
-
-/* Subroutine */ int zchk5_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublecomplex* alf, integer* nbet, doublecomplex* bet, integer* nmax, doublecomplex* ab, doublecomplex* aa, doublecomplex* as, doublecomplex* bb, doublecomplex* bs, doublecomplex* c__, doublecomplex* cc, doublecomplex* cs, doublecomplex* ct, doublereal* g, doublecomplex* w, integer* iorder, ftnlen sname_len)
-{
- /* Initialized data */
-
- static char icht[2+1] = "NC";
- static char ichu[2+1] = "UL";
-
- /* System generated locals */
- integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8;
- doublecomplex z__1, z__2;
-
- /* Local variables */
- static integer jjab;
- static doublecomplex beta;
- static integer ldas, ldbs, ldcs;
- static logical same, isconj;
- static doublecomplex bets;
- static logical tran, null;
- static char uplo[1];
- static integer i__, j, k, n;
- static doublecomplex alpha;
- static doublereal rbeta;
- static logical isame[13];
- extern /* Subroutine */ int zmake_(char*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, logical*, doublecomplex*, ftnlen, ftnlen, ftnlen);
- static integer nargs;
- extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen);
- static doublereal rbets;
- static logical reset;
- static char trans[1];
- static logical upper;
- static char uplos[1];
- static integer ia, ib, jc, ma, na, nc;
- extern /* Subroutine */ int zprcn5_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublecomplex*, integer*, integer*, doublecomplex*, integer*, ftnlen, ftnlen, ftnlen);
- extern /* Subroutine */ int zprcn7_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublecomplex*, integer*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen);
- static integer ik, in, jj, lj, ks, ns;
- static doublereal errmax;
- extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen);
- static char transs[1], transt[1];
- extern /* Subroutine */ int czher2k_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublereal*, doublecomplex*, integer*, ftnlen, ftnlen);
- static integer laa, lbb, lda, lcc, ldb, ldc;
- static doublecomplex als;
- static integer ict, icu;
- extern /* Subroutine */ int czsyr2k_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen);
- static doublereal err;
- extern logical lze_(doublecomplex*, doublecomplex*, integer*);
-
-/* Tests ZHER2K and ZSYR2K. */
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Parameters .. */
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. Local Scalars .. */
-/* .. Local Arrays .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Scalars in Common .. */
-/* .. Common blocks .. */
-/* .. Data statements .. */
- /* Parameter adjustments */
- --idim;
- --alf;
- --bet;
- --w;
- --g;
- --ct;
- --cs;
- --cc;
- c_dim1 = *nmax;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
- --bs;
- --bb;
- --as;
- --aa;
- --ab;
-
- /* Function Body */
-/* .. Executable Statements .. */
- isconj = s_cmp(sname + 7, "he", (ftnlen)2, (ftnlen)2) == 0;
-
- nargs = 12;
- nc = 0;
- reset = TRUE_;
- errmax = 0.;
-
- i__1 = *nidim;
- for (in = 1; in <= i__1; ++in) {
- n = idim[in];
-/* Set LDC to 1 more than minimum value if room. */
- ldc = n;
- if (ldc < *nmax) {
- ++ldc;
- }
-/* Skip tests if not enough room. */
- if (ldc > *nmax) {
- goto L130;
- }
- lcc = ldc * n;
-
- i__2 = *nidim;
- for (ik = 1; ik <= i__2; ++ik) {
- k = idim[ik];
-
- for (ict = 1; ict <= 2; ++ict) {
- *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1];
- tran = *(unsigned char *)trans == 'C';
- if (tran && ! isconj) {
- *(unsigned char *)trans = 'T';
- }
- if (tran) {
- ma = k;
- na = n;
- } else {
- ma = n;
- na = k;
- }
-/* Set LDA to 1 more than minimum value if room. */
- lda = ma;
- if (lda < *nmax) {
- ++lda;
- }
-/* Skip tests if not enough room. */
- if (lda > *nmax) {
- goto L110;
- }
- laa = lda * na;
-
-/* Generate the matrix A. */
-
- if (tran) {
- i__3 = *nmax << 1;
- zmake_("ge", " ", " ", &ma, &na, &ab[1], &i__3, &aa[1], &
- lda, &reset, &c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)
- 1);
- } else {
- zmake_("ge", " ", " ", &ma, &na, &ab[1], nmax, &aa[1], &
- lda, &reset, &c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)
- 1);
- }
-
-/* Generate the matrix B. */
-
- ldb = lda;
- lbb = laa;
- if (tran) {
- i__3 = *nmax << 1;
- zmake_("ge", " ", " ", &ma, &na, &ab[k + 1], &i__3, &bb[1]
- , &ldb, &reset, &c_b1, (ftnlen)2, (ftnlen)1, (
- ftnlen)1);
- } else {
- zmake_("ge", " ", " ", &ma, &na, &ab[k * *nmax + 1], nmax,
- &bb[1], &ldb, &reset, &c_b1, (ftnlen)2, (ftnlen)
- 1, (ftnlen)1);
- }
-
- for (icu = 1; icu <= 2; ++icu) {
- *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];
- upper = *(unsigned char *)uplo == 'U';
-
- i__3 = *nalf;
- for (ia = 1; ia <= i__3; ++ia) {
- i__4 = ia;
- alpha.r = alf[i__4].r, alpha.i = alf[i__4].i;
-
- i__4 = *nbet;
- for (ib = 1; ib <= i__4; ++ib) {
- i__5 = ib;
- beta.r = bet[i__5].r, beta.i = bet[i__5].i;
- if (isconj) {
- rbeta = beta.r;
- z__1.r = rbeta, z__1.i = 0.;
- beta.r = z__1.r, beta.i = z__1.i;
- }
- null = n <= 0;
- if (isconj) {
- null = null ||( (k <= 0 || (alpha.r == 0. &&
- alpha.i == 0.)) && rbeta == 1.);
- }
-
-/* Generate the matrix C. */
-
- zmake_(sname + 7, uplo, " ", &n, &n, &c__[
- c_offset], nmax, &cc[1], &ldc, &reset, &
- c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)1);
-
- ++nc;
-
-/* Save every datum before calling the subroutine. */
-
- *(unsigned char *)uplos = *(unsigned char *)uplo;
- *(unsigned char *)transs = *(unsigned char *)
- trans;
- ns = n;
- ks = k;
- als.r = alpha.r, als.i = alpha.i;
- i__5 = laa;
- for (i__ = 1; i__ <= i__5; ++i__) {
- i__6 = i__;
- i__7 = i__;
- as[i__6].r = aa[i__7].r, as[i__6].i = aa[i__7]
- .i;
-/* L10: */
- }
- ldas = lda;
- i__5 = lbb;
- for (i__ = 1; i__ <= i__5; ++i__) {
- i__6 = i__;
- i__7 = i__;
- bs[i__6].r = bb[i__7].r, bs[i__6].i = bb[i__7]
- .i;
-/* L20: */
- }
- ldbs = ldb;
- if (isconj) {
- rbets = rbeta;
- } else {
- bets.r = beta.r, bets.i = beta.i;
- }
- i__5 = lcc;
- for (i__ = 1; i__ <= i__5; ++i__) {
- i__6 = i__;
- i__7 = i__;
- cs[i__6].r = cc[i__7].r, cs[i__6].i = cc[i__7]
- .i;
-/* L30: */
- }
- ldcs = ldc;
-
-/* Call the subroutine. */
-
- if (isconj) {
- if (*trace) {
- zprcn7_(ntra, &nc, sname, iorder, uplo,
- trans, &n, &k, &alpha, &lda, &ldb,
- &rbeta, &ldc, (ftnlen)12, (
- ftnlen)1, (ftnlen)1);
- }
- if (*rewi) {
-/* al__1.aerr = 0;
- al__1.aunit = *ntra;
- f_rew(&al__1);*/
- }
- czher2k_(iorder, uplo, trans, &n, &k, &alpha,
- &aa[1], &lda, &bb[1], &ldb, &rbeta, &
- cc[1], &ldc, (ftnlen)1, (ftnlen)1);
- } else {
- if (*trace) {
- zprcn5_(ntra, &nc, sname, iorder, uplo,
- trans, &n, &k, &alpha, &lda, &ldb,
- &beta, &ldc, (ftnlen)12, (ftnlen)
- 1, (ftnlen)1);
- }
- if (*rewi) {
-/* al__1.aerr = 0;
- al__1.aunit = *ntra;
- f_rew(&al__1);*/
- }
- czsyr2k_(iorder, uplo, trans, &n, &k, &alpha,
- &aa[1], &lda, &bb[1], &ldb, &beta, &
- cc[1], &ldc, (ftnlen)1, (ftnlen)1);
- }
-
-/* Check if error-exit was taken incorrectly. */
-
- if (! infoc_1.ok) {
- printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");
- *fatal = TRUE_;
- goto L150;
- }
-
-/* See what data changed inside subroutines. */
-
- isame[0] = *(unsigned char *)uplos == *(unsigned
- char *)uplo;
- isame[1] = *(unsigned char *)transs == *(unsigned
- char *)trans;
- isame[2] = ns == n;
- isame[3] = ks == k;
- isame[4] = als.r == alpha.r && als.i == alpha.i;
- isame[5] = lze_(&as[1], &aa[1], &laa);
- isame[6] = ldas == lda;
- isame[7] = lze_(&bs[1], &bb[1], &lbb);
- isame[8] = ldbs == ldb;
- if (isconj) {
- isame[9] = rbets == rbeta;
- } else {
- isame[9] = bets.r == beta.r && bets.i ==
- beta.i;
- }
- if (null) {
- isame[10] = lze_(&cs[1], &cc[1], &lcc);
- } else {
- isame[10] = lzeres_("he", uplo, &n, &n, &cs[1]
- , &cc[1], &ldc, (ftnlen)2, (ftnlen)1);
- }
- isame[11] = ldcs == ldc;
-
-/* If data was incorrectly changed, report and */
-/* return. */
-
- same = TRUE_;
- i__5 = nargs;
- for (i__ = 1; i__ <= i__5; ++i__) {
- same = same && isame[i__ - 1];
- if (! isame[i__ - 1]) {
- printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
- }
-/* L40: */
- }
- if (! same) {
- *fatal = TRUE_;
- goto L150;
- }
-
- if (! null) {
-
-/* Check the result column by column. */
-
- if (isconj) {
- *(unsigned char *)transt = 'C';
- } else {
- *(unsigned char *)transt = 'T';
- }
- jjab = 1;
- jc = 1;
- i__5 = n;
- for (j = 1; j <= i__5; ++j) {
- if (upper) {
- jj = 1;
- lj = j;
- } else {
- jj = j;
- lj = n - j + 1;
- }
- if (tran) {
- i__6 = k;
- for (i__ = 1; i__ <= i__6; ++i__) {
- i__7 = i__;
- i__8 = ((j - 1) << 1) * *nmax + k +
- i__;
- z__1.r = alpha.r * ab[i__8].r -
- alpha.i * ab[i__8].i,
- z__1.i = alpha.r * ab[
- i__8].i + alpha.i * ab[
- i__8].r;
- w[i__7].r = z__1.r, w[i__7].i =
- z__1.i;
- if (isconj) {
- i__7 = k + i__;
- d_cnjg(&z__2, &alpha);
- i__8 = ((j - 1) << 1) * *nmax + i__;
- z__1.r = z__2.r * ab[i__8].r - z__2.i * ab[i__8].i,
- z__1.i = z__2.r * ab[i__8].i + z__2.i * ab[
- i__8].r;
- w[i__7].r = z__1.r, w[i__7].i = z__1.i;
- } else {
- i__7 = k + i__;
- i__8 = ((j - 1) << 1) * *nmax + i__;
- z__1.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8]
- .i, z__1.i = alpha.r * ab[i__8].i + alpha.i
- * ab[i__8].r;
- w[i__7].r = z__1.r, w[i__7].i = z__1.i;
- }
-/* L50: */
- }
- i__6 = k << 1;
- i__7 = *nmax << 1;
- i__8 = *nmax << 1;
- zmmch_(transt, "N", &lj, &c__1, &i__6,
- &c_b2, &ab[jjab], &i__7, &w[
- 1], &i__8, &beta, &c__[jj + j
- * c_dim1], nmax, &ct[1], &g[1]
- , &cc[jc], &ldc, eps, &err,
- fatal, nout, &c_true, (ftnlen)
- 1, (ftnlen)1);
- } else {
- i__6 = k;
- for (i__ = 1; i__ <= i__6; ++i__) {
- if (isconj) {
- i__7 = i__;
- d_cnjg(&z__2, &ab[(k + i__ - 1) * *nmax + j]);
- z__1.r = alpha.r * z__2.r - alpha.i * z__2.i,
- z__1.i = alpha.r * z__2.i + alpha.i *
- z__2.r;
- w[i__7].r = z__1.r, w[i__7].i = z__1.i;
- i__7 = k + i__;
- i__8 = (i__ - 1) * *nmax + j;
- z__2.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8]
- .i, z__2.i = alpha.r * ab[i__8].i + alpha.i
- * ab[i__8].r;
- d_cnjg(&z__1, &z__2);
- w[i__7].r = z__1.r, w[i__7].i = z__1.i;
- } else {
- i__7 = i__;
- i__8 = (k + i__ - 1) * *nmax + j;
- z__1.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8]
- .i, z__1.i = alpha.r * ab[i__8].i + alpha.i
- * ab[i__8].r;
- w[i__7].r = z__1.r, w[i__7].i = z__1.i;
- i__7 = k + i__;
- i__8 = (i__ - 1) * *nmax + j;
- z__1.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8]
- .i, z__1.i = alpha.r * ab[i__8].i + alpha.i
- * ab[i__8].r;
- w[i__7].r = z__1.r, w[i__7].i = z__1.i;
- }
-/* L60: */
- }
- i__6 = k << 1;
- i__7 = *nmax << 1;
- zmmch_("N", "N", &lj, &c__1, &i__6, &
- c_b2, &ab[jj], nmax, &w[1], &
- i__7, &beta, &c__[jj + j *
- c_dim1], nmax, &ct[1], &g[1],
- &cc[jc], &ldc, eps, &err,
- fatal, nout, &c_true, (ftnlen)
- 1, (ftnlen)1);
- }
- if (upper) {
- jc += ldc;
- } else {
- jc = jc + ldc + 1;
- if (tran) {
- jjab += *nmax << 1;
- }
- }
- errmax = f2cmax(errmax,err);
-/* If got really bad answer, report and */
-/* return. */
- if (*fatal) {
- goto L140;
- }
-/* L70: */
- }
- }
-
-/* L80: */
- }
-
-/* L90: */
- }
-
-/* L100: */
- }
-
-L110:
- ;
- }
-
-/* L120: */
- }
-
-L130:
- ;
- }
-
-/* Report result. */
-
- if (errmax < *thresh) {
- if (*iorder == 0) {
- printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
- }
- if (*iorder == 1) {
- printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
- }
- } else {
- if (*iorder == 0) {
- printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);
- printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);
- }
- if (*iorder == 1) {
- printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);
- printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);
- }
- }
- goto L160;
-
-L140:
- if (n > 1) {
- printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j);
- }
-
-L150:
- printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
- if (isconj) {
- zprcn7_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &
- ldb, &rbeta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1);
- } else {
- zprcn5_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &
- ldb, &beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1);
- }
-
-L160:
- return 0;
-
-/* 9994 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */
-/* $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',', F4.1, */
-/* $ ', C,', I3, ') .' ) */
-/* 9993 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */
-/* $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1, */
-/* $ ',', F4.1, '), C,', I3, ') .' ) */
-
-/* End of ZCHK5. */
-
-} /* zchk5_ */
-
-
-/* Subroutine */ int zprcn5_(integer* nout, integer* nc, char* sname, integer* iorder, char* uplo, char* transa, integer* n, integer* k, doublecomplex* alpha, integer* lda, integer* ldb, doublecomplex* beta, integer* ldc, ftnlen sname_len, ftnlen uplo_len, ftnlen transa_len)
-{
- /* Local variables */
- static char ca[14], cu[14], crc[14];
-
- if (*(unsigned char *)uplo == 'U') {
- s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14);
- }
- if (*(unsigned char *)transa == 'N') {
- s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14);
- } else if (*(unsigned char *)transa == 'T') {
- s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14);
- }
- if (*iorder == 1) {
- s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
- }
- printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca);
- printf("%d %d (%4.1lf,%4.1lf) , A, %d, B, %d, (%4.1lf,%4.1lf) , C, %d.\n",*n,*k,alpha->r,alpha->i,*lda,*ldb,beta->r,beta->i,*ldc);
-
-return 0;
-} /* zprcn5_ */
-
-
-
-/* Subroutine */ int zprcn7_(integer* nout, integer* nc, char* sname, integer* iorder, char* uplo, char* transa, integer* n, integer* k, doublecomplex* alpha, integer* lda, integer* ldb, doublereal* beta, integer* ldc, ftnlen sname_len, ftnlen uplo_len, ftnlen transa_len)
-{
-
- /* Local variables */
- static char ca[14], cu[14], crc[14];
-
- if (*(unsigned char *)uplo == 'U') {
- s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(cu, " CblasLower", (ftnlen)14, (ftnlen)14);
- }
- if (*(unsigned char *)transa == 'N') {
- s_copy(ca, " CblasNoTrans", (ftnlen)14, (ftnlen)14);
- } else if (*(unsigned char *)transa == 'T') {
- s_copy(ca, " CblasTrans", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14);
- }
- if (*iorder == 1) {
- s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14);
- } else {
- s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
- }
- printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca);
- printf("%d %d (%4.1lf,%4.1lf), A, %d, B, %d, %4.1lf, C, %d.\n",*n,*k,alpha->r,alpha->i,*lda,*ldb,*beta,*ldc);
-
-return 0;
-} /* zprcn7_ */
-
-
-/* Subroutine */ int zmake_(char* type__, char* uplo, char* diag, integer* m, integer* n, doublecomplex* a, integer* nmax, doublecomplex* aa, integer* lda, logical* reset, doublecomplex* transl, ftnlen type_len, ftnlen uplo_len, ftnlen diag_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
- doublereal d__1;
- doublecomplex z__1, z__2;
-
- /* Local variables */
- static integer ibeg, iend;
- extern /* Double Complex */ VOID zbeg_(doublecomplex*, logical*);
- static logical unit;
- static integer i__, j;
- static logical lower, upper;
- static integer jj;
- static logical gen, her, tri, sym;
-
-
-/* Generates values for an M by N matrix A. */
-/* Stores the values in the array AA in the data structure required */
-/* by the routine, with unwanted elements set to rogue value. */
-
-/* TYPE is 'ge', 'he', 'sy' or 'tr'. */
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Parameters .. */
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. Intrinsic Functions .. */
-/* .. Executable Statements .. */
- /* Parameter adjustments */
- a_dim1 = *nmax;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- --aa;
-
- /* Function Body */
- gen = s_cmp(type__, "ge", (ftnlen)2, (ftnlen)2) == 0;
- her = s_cmp(type__, "he", (ftnlen)2, (ftnlen)2) == 0;
- sym = s_cmp(type__, "sy", (ftnlen)2, (ftnlen)2) == 0;
- tri = s_cmp(type__, "tr", (ftnlen)2, (ftnlen)2) == 0;
- upper = (her || sym || tri) && *(unsigned char *)uplo == 'U';
- lower = (her || sym || tri) && *(unsigned char *)uplo == 'L';
- unit = tri && *(unsigned char *)diag == 'U';
-
-/* Generate data in array A. */
-
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- if (gen || (upper && i__ <= j) || (lower && i__ >= j)) {
- i__3 = i__ + j * a_dim1;
- zbeg_(&z__2, reset);
- z__1.r = z__2.r + transl->r, z__1.i = z__2.i + transl->i;
- a[i__3].r = z__1.r, a[i__3].i = z__1.i;
- if (i__ != j) {
-/* Set some elements to zero */
- if (*n > 3 && j == *n / 2) {
- i__3 = i__ + j * a_dim1;
- a[i__3].r = 0., a[i__3].i = 0.;
- }
- if (her) {
- i__3 = j + i__ * a_dim1;
- d_cnjg(&z__1, &a[i__ + j * a_dim1]);
- a[i__3].r = z__1.r, a[i__3].i = z__1.i;
- } else if (sym) {
- i__3 = j + i__ * a_dim1;
- i__4 = i__ + j * a_dim1;
- a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i;
- } else if (tri) {
- i__3 = j + i__ * a_dim1;
- a[i__3].r = 0., a[i__3].i = 0.;
- }
- }
- }
-/* L10: */
- }
- if (her) {
- i__2 = j + j * a_dim1;
- i__3 = j + j * a_dim1;
- d__1 = a[i__3].r;
- z__1.r = d__1, z__1.i = 0.;
- a[i__2].r = z__1.r, a[i__2].i = z__1.i;
- }
- if (tri) {
- i__2 = j + j * a_dim1;
- i__3 = j + j * a_dim1;
- z__1.r = a[i__3].r + 1., z__1.i = a[i__3].i + 0.;
- a[i__2].r = z__1.r, a[i__2].i = z__1.i;
- }
- if (unit) {
- i__2 = j + j * a_dim1;
- a[i__2].r = 1., a[i__2].i = 0.;
- }
-/* L20: */
- }
-
-/* Store elements in array AS in data structure required by routine. */
-
- if (s_cmp(type__, "ge", (ftnlen)2, (ftnlen)2) == 0) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + (j - 1) * *lda;
- i__4 = i__ + j * a_dim1;
- aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i;
-/* L30: */
- }
- i__2 = *lda;
- for (i__ = *m + 1; i__ <= i__2; ++i__) {
- i__3 = i__ + (j - 1) * *lda;
- aa[i__3].r = -1e10, aa[i__3].i = 1e10;
-/* L40: */
- }
-/* L50: */
- }
- } else if (s_cmp(type__, "he", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
- "sy", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__, "tr", (ftnlen)
- 2, (ftnlen)2) == 0) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (upper) {
- ibeg = 1;
- if (unit) {
- iend = j - 1;
- } else {
- iend = j;
- }
- } else {
- if (unit) {
- ibeg = j + 1;
- } else {
- ibeg = j;
- }
- iend = *n;
- }
- i__2 = ibeg - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + (j - 1) * *lda;
- aa[i__3].r = -1e10, aa[i__3].i = 1e10;
-/* L60: */
- }
- i__2 = iend;
- for (i__ = ibeg; i__ <= i__2; ++i__) {
- i__3 = i__ + (j - 1) * *lda;
- i__4 = i__ + j * a_dim1;
- aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i;
-/* L70: */
- }
- i__2 = *lda;
- for (i__ = iend + 1; i__ <= i__2; ++i__) {
- i__3 = i__ + (j - 1) * *lda;
- aa[i__3].r = -1e10, aa[i__3].i = 1e10;
-/* L80: */
- }
- if (her) {
- jj = j + (j - 1) * *lda;
- i__2 = jj;
- i__3 = jj;
- d__1 = aa[i__3].r;
- z__1.r = d__1, z__1.i = -1e10;
- aa[i__2].r = z__1.r, aa[i__2].i = z__1.i;
- }
-/* L90: */
- }
- }
- return 0;
-
-/* End of ZMAKE. */
-
-} /* zmake_ */
-
-/* Subroutine */ int zmmch_(char* transa, char* transb, integer* m, integer* n, integer* kk, doublecomplex* alpha, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* beta, doublecomplex* c__, integer* ldc, doublecomplex* ct, doublereal* g, doublecomplex* cc, integer* ldcc, doublereal* eps, doublereal* err, logical* fatal, integer* nout, logical* mv, ftnlen transa_len, ftnlen transb_len)
-{
-
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, cc_dim1,
- cc_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
- doublereal d__1, d__2, d__3, d__4, d__5, d__6;
- doublecomplex z__1, z__2, z__3, z__4;
-
- double sqrt(double);
- /* Local variables */
- static doublereal erri;
- static integer i__, j, k;
- static logical trana, tranb, ctrana, ctranb;
-
-/* Checks the results of the computational tests. */
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Parameters .. */
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. Local Scalars .. */
-/* .. Intrinsic Functions .. */
-/* .. Statement Functions .. */
-/* .. Statement Function definitions .. */
-/* .. Executable Statements .. */
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- b_dim1 = *ldb;
- b_offset = 1 + b_dim1 * 1;
- b -= b_offset;
- c_dim1 = *ldc;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
- --ct;
- --g;
- cc_dim1 = *ldcc;
- cc_offset = 1 + cc_dim1 * 1;
- cc -= cc_offset;
-
- /* Function Body */
- trana = *(unsigned char *)transa == 'T' || *(unsigned char *)transa ==
- 'C';
- tranb = *(unsigned char *)transb == 'T' || *(unsigned char *)transb ==
- 'C';
- ctrana = *(unsigned char *)transa == 'C';
- ctranb = *(unsigned char *)transb == 'C';
-
-/* Compute expected result, one column at a time, in CT using data */
-/* in A, B and C. */
-/* Compute gauges in G. */
-
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
-
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__;
- ct[i__3].r = 0., ct[i__3].i = 0.;
- g[i__] = 0.;
-/* L10: */
- }
- if (! trana && ! tranb) {
- i__2 = *kk;
- for (k = 1; k <= i__2; ++k) {
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- i__4 = i__;
- i__5 = i__;
- i__6 = i__ + k * a_dim1;
- i__7 = k + j * b_dim1;
- z__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[i__7].i,
- z__2.i = a[i__6].r * b[i__7].i + a[i__6].i * b[
- i__7].r;
- z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i +
- z__2.i;
- ct[i__4].r = z__1.r, ct[i__4].i = z__1.i;
- i__4 = i__ + k * a_dim1;
- i__5 = k + j * b_dim1;
- g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(
- &a[i__ + k * a_dim1]), abs(d__2))) * ((d__3 = b[
- i__5].r, abs(d__3)) + (d__4 = d_imag(&b[k + j *
- b_dim1]), abs(d__4)));
-/* L20: */
- }
-/* L30: */
- }
- } else if (trana && ! tranb) {
- if (ctrana) {
- i__2 = *kk;
- for (k = 1; k <= i__2; ++k) {
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- i__4 = i__;
- i__5 = i__;
- d_cnjg(&z__3, &a[k + i__ * a_dim1]);
- i__6 = k + j * b_dim1;
- z__2.r = z__3.r * b[i__6].r - z__3.i * b[i__6].i,
- z__2.i = z__3.r * b[i__6].i + z__3.i * b[i__6]
- .r;
- z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i +
- z__2.i;
- ct[i__4].r = z__1.r, ct[i__4].i = z__1.i;
- i__4 = k + i__ * a_dim1;
- i__5 = k + j * b_dim1;
- g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
- d_imag(&a[k + i__ * a_dim1]), abs(d__2))) * ((
- d__3 = b[i__5].r, abs(d__3)) + (d__4 = d_imag(
- &b[k + j * b_dim1]), abs(d__4)));
-/* L40: */
- }
-/* L50: */
- }
- } else {
- i__2 = *kk;
- for (k = 1; k <= i__2; ++k) {
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- i__4 = i__;
- i__5 = i__;
- i__6 = k + i__ * a_dim1;
- i__7 = k + j * b_dim1;
- z__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[i__7]
- .i, z__2.i = a[i__6].r * b[i__7].i + a[i__6]
- .i * b[i__7].r;
- z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i +
- z__2.i;
- ct[i__4].r = z__1.r, ct[i__4].i = z__1.i;
- i__4 = k + i__ * a_dim1;
- i__5 = k + j * b_dim1;
- g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
- d_imag(&a[k + i__ * a_dim1]), abs(d__2))) * ((
- d__3 = b[i__5].r, abs(d__3)) + (d__4 = d_imag(
- &b[k + j * b_dim1]), abs(d__4)));
-/* L60: */
- }
-/* L70: */
- }
- }
- } else if (! trana && tranb) {
- if (ctranb) {
- i__2 = *kk;
- for (k = 1; k <= i__2; ++k) {
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- i__4 = i__;
- i__5 = i__;
- i__6 = i__ + k * a_dim1;
- d_cnjg(&z__3, &b[j + k * b_dim1]);
- z__2.r = a[i__6].r * z__3.r - a[i__6].i * z__3.i,
- z__2.i = a[i__6].r * z__3.i + a[i__6].i *
- z__3.r;
- z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i +
- z__2.i;
- ct[i__4].r = z__1.r, ct[i__4].i = z__1.i;
- i__4 = i__ + k * a_dim1;
- i__5 = j + k * b_dim1;
- g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
- d_imag(&a[i__ + k * a_dim1]), abs(d__2))) * ((
- d__3 = b[i__5].r, abs(d__3)) + (d__4 = d_imag(
- &b[j + k * b_dim1]), abs(d__4)));
-/* L80: */
- }
-/* L90: */
- }
- } else {
- i__2 = *kk;
- for (k = 1; k <= i__2; ++k) {
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- i__4 = i__;
- i__5 = i__;
- i__6 = i__ + k * a_dim1;
- i__7 = j + k * b_dim1;
- z__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[i__7]
- .i, z__2.i = a[i__6].r * b[i__7].i + a[i__6]
- .i * b[i__7].r;
- z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i +
- z__2.i;
- ct[i__4].r = z__1.r, ct[i__4].i = z__1.i;
- i__4 = i__ + k * a_dim1;
- i__5 = j + k * b_dim1;
- g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
- d_imag(&a[i__ + k * a_dim1]), abs(d__2))) * ((
- d__3 = b[i__5].r, abs(d__3)) + (d__4 = d_imag(
- &b[j + k * b_dim1]), abs(d__4)));
-/* L100: */
- }
-/* L110: */
- }
- }
- } else if (trana && tranb) {
- if (ctrana) {
- if (ctranb) {
- i__2 = *kk;
- for (k = 1; k <= i__2; ++k) {
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- i__4 = i__;
- i__5 = i__;
- d_cnjg(&z__3, &a[k + i__ * a_dim1]);
- d_cnjg(&z__4, &b[j + k * b_dim1]);
- z__2.r = z__3.r * z__4.r - z__3.i * z__4.i,
- z__2.i = z__3.r * z__4.i + z__3.i *
- z__4.r;
- z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i
- + z__2.i;
- ct[i__4].r = z__1.r, ct[i__4].i = z__1.i;
- i__4 = k + i__ * a_dim1;
- i__5 = j + k * b_dim1;
- g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
- d_imag(&a[k + i__ * a_dim1]), abs(d__2)))
- * ((d__3 = b[i__5].r, abs(d__3)) + (d__4
- = d_imag(&b[j + k * b_dim1]), abs(d__4)));
-/* L120: */
- }
-/* L130: */
- }
- } else {
- i__2 = *kk;
- for (k = 1; k <= i__2; ++k) {
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- i__4 = i__;
- i__5 = i__;
- d_cnjg(&z__3, &a[k + i__ * a_dim1]);
- i__6 = j + k * b_dim1;
- z__2.r = z__3.r * b[i__6].r - z__3.i * b[i__6].i,
- z__2.i = z__3.r * b[i__6].i + z__3.i * b[
- i__6].r;
- z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i
- + z__2.i;
- ct[i__4].r = z__1.r, ct[i__4].i = z__1.i;
- i__4 = k + i__ * a_dim1;
- i__5 = j + k * b_dim1;
- g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
- d_imag(&a[k + i__ * a_dim1]), abs(d__2)))
- * ((d__3 = b[i__5].r, abs(d__3)) + (d__4
- = d_imag(&b[j + k * b_dim1]), abs(d__4)));
-/* L140: */
- }
-/* L150: */
- }
- }
- } else {
- if (ctranb) {
- i__2 = *kk;
- for (k = 1; k <= i__2; ++k) {
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- i__4 = i__;
- i__5 = i__;
- i__6 = k + i__ * a_dim1;
- d_cnjg(&z__3, &b[j + k * b_dim1]);
- z__2.r = a[i__6].r * z__3.r - a[i__6].i * z__3.i,
- z__2.i = a[i__6].r * z__3.i + a[i__6].i *
- z__3.r;
- z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i
- + z__2.i;
- ct[i__4].r = z__1.r, ct[i__4].i = z__1.i;
- i__4 = k + i__ * a_dim1;
- i__5 = j + k * b_dim1;
- g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
- d_imag(&a[k + i__ * a_dim1]), abs(d__2)))
- * ((d__3 = b[i__5].r, abs(d__3)) + (d__4
- = d_imag(&b[j + k * b_dim1]), abs(d__4)));
-/* L160: */
- }
-/* L170: */
- }
- } else {
- i__2 = *kk;
- for (k = 1; k <= i__2; ++k) {
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- i__4 = i__;
- i__5 = i__;
- i__6 = k + i__ * a_dim1;
- i__7 = j + k * b_dim1;
- z__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[
- i__7].i, z__2.i = a[i__6].r * b[i__7].i +
- a[i__6].i * b[i__7].r;
- z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i
- + z__2.i;
- ct[i__4].r = z__1.r, ct[i__4].i = z__1.i;
- i__4 = k + i__ * a_dim1;
- i__5 = j + k * b_dim1;
- g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
- d_imag(&a[k + i__ * a_dim1]), abs(d__2)))
- * ((d__3 = b[i__5].r, abs(d__3)) + (d__4
- = d_imag(&b[j + k * b_dim1]), abs(d__4)));
-/* L180: */
- }
-/* L190: */
- }
- }
- }
- }
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__;
- i__4 = i__;
- z__2.r = alpha->r * ct[i__4].r - alpha->i * ct[i__4].i, z__2.i =
- alpha->r * ct[i__4].i + alpha->i * ct[i__4].r;
- i__5 = i__ + j * c_dim1;
- z__3.r = beta->r * c__[i__5].r - beta->i * c__[i__5].i, z__3.i =
- beta->r * c__[i__5].i + beta->i * c__[i__5].r;
- z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
- ct[i__3].r = z__1.r, ct[i__3].i = z__1.i;
- i__3 = i__ + j * c_dim1;
- g[i__] = ((d__1 = alpha->r, abs(d__1)) + (d__2 = d_imag(alpha),
- abs(d__2))) * g[i__] + ((d__3 = beta->r, abs(d__3)) + (
- d__4 = d_imag(beta), abs(d__4))) * ((d__5 = c__[i__3].r,
- abs(d__5)) + (d__6 = d_imag(&c__[i__ + j * c_dim1]), abs(
- d__6)));
-/* L200: */
- }
-
-/* Compute the error ratio for this result. */
-
- *err = 0.;
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__;
- i__4 = i__ + j * cc_dim1;
- z__2.r = ct[i__3].r - cc[i__4].r, z__2.i = ct[i__3].i - cc[i__4]
- .i;
- z__1.r = z__2.r, z__1.i = z__2.i;
- erri = ((d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), abs(
- d__2))) / *eps;
- if (g[i__] != 0.) {
- erri /= g[i__];
- }
- *err = f2cmax(*err,erri);
- if (*err * sqrt(*eps) >= 1.) {
- goto L230;
- }
-/* L210: */
- }
-
-/* L220: */
- }
-
-/* If the loop completes, all results are at least half accurate. */
- goto L250;
-
-/* Report fatal error. */
-
-L230:
- *fatal = TRUE_;
- printf(" ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HALF ACCURATE *******\n");
- printf(" EXPECTED RESULT COMPUTED RESULT\n");
- i__1 = *m;
- for (i__ = 1; i__ <= i__1; ++i__) {
- if (*mv) {
- printf("%7d (%15.6g,%15.6g) (%15.6g,%15.6g)\n",i__,ct[i__].r,ct[i__].i,cc[i__+j*cc_dim1].r,cc[i__+j*cc_dim1].i);
- } else {
- printf("%7d (%15.6g,%15.6g) (%15.6g,%15.6g)\n",i__,cc[i__+j*cc_dim1].r,cc[i__+j*cc_dim1].i,ct[i__].r,ct[i__].i);
- }
-/* L240: */
- }
- if (*n > 1) {
- printf(" THESE ARE THE RESULTS FOR COLUMN %d\n",j);
- }
-
-L250:
- return 0;
-
-
-/* End of ZMMCH. */
-
-} /* zmmch_ */
-
-logical lze_(doublecomplex* ri, doublecomplex* rj, integer* lr)
-{
- /* System generated locals */
- integer i__1, i__2, i__3;
- logical ret_val;
-
- /* Local variables */
- static integer i__;
-
-
-/* Tests if two arrays are identical. */
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. Local Scalars .. */
-/* .. Executable Statements .. */
- /* Parameter adjustments */
- --rj;
- --ri;
-
- /* Function Body */
- i__1 = *lr;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = i__;
- i__3 = i__;
- if (ri[i__2].r != rj[i__3].r || ri[i__2].i != rj[i__3].i) {
- goto L20;
- }
-/* L10: */
- }
- ret_val = TRUE_;
- goto L30;
-L20:
- ret_val = FALSE_;
-L30:
- return ret_val;
-
-/* End of LZE. */
-
-} /* lze_ */
-
-logical lzeres_(char* type__, char* uplo, integer* m, integer* n, doublecomplex *aa, doublecomplex* as, integer* lda, ftnlen type_len, ftnlen uplo_len)
-{
- /* System generated locals */
- integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2, i__3, i__4;
- logical ret_val;
-
- /* Local variables */
- static integer ibeg, iend, i__, j;
- static logical upper;
-
-
-/* Tests if selected elements in two arrays are equal. */
-
-/* TYPE is 'ge' or 'he' or 'sy'. */
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. Local Scalars .. */
-/* .. Executable Statements .. */
- /* Parameter adjustments */
- as_dim1 = *lda;
- as_offset = 1 + as_dim1 * 1;
- as -= as_offset;
- aa_dim1 = *lda;
- aa_offset = 1 + aa_dim1 * 1;
- aa -= aa_offset;
-
- /* Function Body */
- upper = *(unsigned char *)uplo == 'U';
- if (s_cmp(type__, "ge", (ftnlen)2, (ftnlen)2) == 0) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *lda;
- for (i__ = *m + 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * aa_dim1;
- i__4 = i__ + j * as_dim1;
- if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) {
- goto L70;
- }
-/* L10: */
- }
-/* L20: */
- }
- } else if (s_cmp(type__, "he", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
- "sy", (ftnlen)2, (ftnlen)2) == 0) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (upper) {
- ibeg = 1;
- iend = j;
- } else {
- ibeg = j;
- iend = *n;
- }
- i__2 = ibeg - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * aa_dim1;
- i__4 = i__ + j * as_dim1;
- if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) {
- goto L70;
- }
-/* L30: */
- }
- i__2 = *lda;
- for (i__ = iend + 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * aa_dim1;
- i__4 = i__ + j * as_dim1;
- if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) {
- goto L70;
- }
-/* L40: */
- }
-/* L50: */
- }
- }
-
-/* 60 CONTINUE */
- ret_val = TRUE_;
- goto L80;
-L70:
- ret_val = FALSE_;
-L80:
- return ret_val;
-
-/* End of LZERES. */
-
-} /* lzeres_ */
-
-/* Double Complex */ VOID zbeg_(doublecomplex* ret_val, logical* reset)
-{
- /* System generated locals */
- doublereal d__1, d__2;
- doublecomplex z__1;
-
- /* Local variables */
- static integer i__, j, ic, mi, mj;
-
-
-/* Generates complex numbers as pairs of random numbers uniformly */
-/* distributed between -0.5 and 0.5. */
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Scalar Arguments .. */
-/* .. Local Scalars .. */
-/* .. Save statement .. */
-/* .. Intrinsic Functions .. */
-/* .. Executable Statements .. */
- if (*reset) {
-/* Initialize local variables. */
- mi = 891;
- mj = 457;
- i__ = 7;
- j = 7;
- ic = 0;
- *reset = FALSE_;
- }
-
-/* The sequence of values of I or J is bounded between 1 and 999. */
-/* If initial I or J = 1,2,3,6,7 or 9, the period will be 50. */
-/* If initial I or J = 4 or 8, the period will be 25. */
-/* If initial I or J = 5, the period will be 10. */
-/* IC is used to break up the period by skipping 1 value of I or J */
-/* in 6. */
-
- ++ic;
-L10:
- i__ *= mi;
- j *= mj;
- i__ -= i__ / 1000 * 1000;
- j -= j / 1000 * 1000;
- if (ic >= 5) {
- ic = 0;
- goto L10;
- }
- d__1 = (i__ - 500) / 1001.;
- d__2 = (j - 500) / 1001.;
- z__1.r = d__1, z__1.i = d__2;
- ret_val->r = z__1.r, ret_val->i = z__1.i;
- return ;
-
-/* End of ZBEG. */
-
-} /* zbeg_ */
-
-doublereal ddiff_(doublereal* x, doublereal* y)
-{
- /* System generated locals */
- doublereal ret_val;
-
-
-/* Auxiliary routine for test program for Level 3 Blas. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* .. Scalar Arguments .. */
-/* .. Executable Statements .. */
- ret_val = *x - *y;
- return ret_val;
-
-/* End of DDIFF. */
-} /* ddiff_ */
-/* Main program alias */ /*int zblat3_ () { MAIN__ (); }*/
From 140da0c8f388d3851f6eedc1092532d83dd71dcb Mon Sep 17 00:00:00 2001
From: Martin Kroeker <martin@ruby.chemie.uni-freiburg.de>
Date: Thu, 20 Mar 2025 22:27:05 +0100
Subject: [PATCH 07/17] Fix f2c conversion errors
---
ctest/c_cblat3c.c | 5287 +++++++++++++++++++++++++++++++++++++++++++-
ctest/c_dblat3c.c | 4427 ++++++++++++++++++++++++++++++++++++-
ctest/c_sblat3c.c | 4407 ++++++++++++++++++++++++++++++++++++-
ctest/c_zblat3c.c | 5329 ++++++++++++++++++++++++++++++++++++++++++++-
4 files changed, 19374 insertions(+), 76 deletions(-)
diff --git a/ctest/c_cblat3c.c b/ctest/c_cblat3c.c
index 447b23014f..48dbaf82f6 100644
--- a/ctest/c_cblat3c.c
+++ b/ctest/c_cblat3c.c
@@ -10,25 +10,7 @@
#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
+#include "common.h"
typedef blasint integer;
@@ -509,3 +491,5270 @@ static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integ
+/* -- translated by f2c (version 20200916).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, noutc;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[13];
+} 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__9 = 9;
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__8 = 8;
+static integer c__4 = 4;
+static integer c__65 = 65;
+static integer c__7 = 7;
+static integer c__6 = 6;
+static integer c__2 = 2;
+static real c_b91 = 1.f;
+static logical c_true = TRUE_;
+static integer c__0 = 0;
+static logical c_false = FALSE_;
+
+/* Main program */ int main(void)
+{
+ /* Initialized data */
+
+ static char snames[13*10] = "cblas_cgemm " "cblas_chemm " "cblas_csymm"
+ " " "cblas_ctrmm " "cblas_ctrsm " "cblas_cherk " "cblas_csyrk"
+ " " "cblas_cher2k " "cblas_csyr2k " "cblas_cgemmtr";
+
+ /* Format strings */
+ static char fmt_9997[] = "(\002 NUMBER OF VALUES OF \002,a,\002 IS LESS "
+ "THAN 1 OR GREATER \002,\002THAN \002,i2)";
+ static char fmt_9996[] = "(\002 VALUE OF N IS LESS THAN 0 OR GREATER THA"
+ "N \002,i2)";
+ static char fmt_9995[] = "(\002 TESTS OF THE COMPLEX LEVEL 3 BL"
+ "AS\002,//\002 THE F\002,\002OLLOWING PARAMETER VALUES WILL BE US"
+ "ED:\002)";
+ static char fmt_9994[] = "(\002 FOR N \002,9i6)";
+ static char fmt_9993[] = "(\002 FOR ALPHA \002,7(\002(\002,f4"
+ ".1,\002,\002,f4.1,\002) \002,:))";
+ static char fmt_9992[] = "(\002 FOR BETA \002,7(\002(\002,f4"
+ ".1,\002,\002,f4.1,\002) \002,:))";
+ static char fmt_9984[] = "(\002 ERROR-CALL MYEXITS WILL NOT BE TESTED"
+ "\002)";
+ static char fmt_9999[] = "(\002 ROUTINES PASS COMPUTATIONAL TESTS IF TES"
+ "T RATIO IS LES\002,\002S THAN\002,f8.2)";
+ static char fmt_10002[] = "(\002 COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS"
+ " ARE TESTED\002)";
+ static char fmt_10001[] = "(\002 ROW-MAJOR DATA LAYOUT IS TESTED\002)";
+ static char fmt_10000[] = "(\002 COLUMN-MAJOR DATA LAYOUT IS TESTED\002)";
+ static char fmt_9988[] = "(a13,l2)";
+ static char fmt_9990[] = "(\002 SUBPROGRAM NAME \002,a13,\002 NOT RECOGN"
+ "IZED\002,/\002 ******* T\002,\002ESTS ABANDONED *******\002)";
+ static char fmt_9998[] = "(\002 RELATIVE MACHINE PRECISION IS TAKEN TO"
+ " BE\002,1p,e9.1)";
+ static char fmt_9989[] = "(\002 ERROR IN CMMCH - IN-LINE DOT PRODUCTS A"
+ "RE BEING EVALU\002,\002ATED WRONGLY.\002,/\002 CMMCH WAS CALLED "
+ "WITH TRANSA = \002,a1,\002AND TRANSB = \002,a1,/\002 AND RETURNE"
+ "D SAME = \002,l1,\002 AND \002,\002 ERR = \002,f12.3,\002.\002,"
+ "/\002 THIS MAY BE DUE TO FAULTS IN THE \002,\002ARITHMETIC OR TH"
+ "E COMPILER.\002,/\002 ******* TESTS ABANDONED \002,\002******"
+ "*\002)";
+ static char fmt_9987[] = "(1x,a13,\002 WAS NOT TESTED\002)";
+ static char fmt_9986[] = "(/\002 END OF TESTS\002)";
+ static char fmt_9985[] = "(/\002 ******* FATAL ERROR - TESTS ABANDONED *"
+ "******\002)";
+ static char fmt_9991[] = "(\002 AMEND DATA FILE OR INCREASE ARRAY SIZES "
+ "IN PROGRAM\002,/\002 ******* TESTS ABANDONED *******\002)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ real r__1;
+ olist o__1;
+ cllist cl__1;
+
+ /* Local variables */
+ complex c__[4225] /* was [65][65] */;
+ real g[65];
+ integer i__, j, n;
+ complex w[130], aa[4225], ab[8450] /* was [65][130] */, bb[4225], cc[
+ 4225], as[4225], bs[4225], cs[4225], ct[65], alf[7];
+ extern logical lce_(complex *, complex *, integer *);
+ complex bet[7];
+ real eps, err;
+ 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 *),
+ cchk6_(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 *);
+ logical fatal;
+ 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[10], sfatal, corder;
+ char snamet[13], transa[1], transb[1];
+ real thresh;
+ logical rorder;
+ extern /* Subroutine */ int cc3chke_(char *);
+ integer layout;
+ logical ltestt, tsterr;
+
+ /* Fortran I/O blocks */
+ static cilist io___2 = { 0, 5, 0, 0, 0 };
+ static cilist io___4 = { 0, 5, 0, 0, 0 };
+ static cilist io___7 = { 0, 5, 0, 0, 0 };
+ static cilist io___9 = { 0, 5, 0, 0, 0 };
+ static cilist io___11 = { 0, 5, 0, 0, 0 };
+ static cilist io___13 = { 0, 5, 0, 0, 0 };
+ static cilist io___15 = { 0, 5, 0, 0, 0 };
+ static cilist io___17 = { 0, 5, 0, 0, 0 };
+ static cilist io___19 = { 0, 6, 0, fmt_9997, 0 };
+ static cilist io___20 = { 0, 5, 0, 0, 0 };
+ static cilist io___23 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___24 = { 0, 5, 0, 0, 0 };
+ static cilist io___26 = { 0, 6, 0, fmt_9997, 0 };
+ static cilist io___27 = { 0, 5, 0, 0, 0 };
+ static cilist io___29 = { 0, 5, 0, 0, 0 };
+ static cilist io___31 = { 0, 6, 0, fmt_9997, 0 };
+ static cilist io___32 = { 0, 5, 0, 0, 0 };
+ static cilist io___34 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___35 = { 0, 6, 0, fmt_9994, 0 };
+ static cilist io___36 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___37 = { 0, 6, 0, fmt_9992, 0 };
+ static cilist io___38 = { 0, 6, 0, 0, 0 };
+ static cilist io___39 = { 0, 6, 0, fmt_9984, 0 };
+ static cilist io___40 = { 0, 6, 0, 0, 0 };
+ static cilist io___41 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 6, 0, 0, 0 };
+ static cilist io___45 = { 0, 6, 0, fmt_10002, 0 };
+ static cilist io___46 = { 0, 6, 0, fmt_10001, 0 };
+ static cilist io___47 = { 0, 6, 0, fmt_10000, 0 };
+ static cilist io___48 = { 0, 6, 0, 0, 0 };
+ static cilist io___50 = { 0, 5, 1, fmt_9988, 0 };
+ static cilist io___53 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___55 = { 0, 6, 0, fmt_9998, 0 };
+ static cilist io___68 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___69 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___70 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___71 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___73 = { 0, 6, 0, 0, 0 };
+ static cilist io___74 = { 0, 6, 0, fmt_9987, 0 };
+ static cilist io___75 = { 0, 6, 0, 0, 0 };
+ static cilist io___82 = { 0, 6, 0, fmt_9986, 0 };
+ static cilist io___83 = { 0, 6, 0, fmt_9985, 0 };
+ static cilist io___84 = { 0, 6, 0, fmt_9991, 0 };
+
+
+
+/* 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 10 records */
+/* are read using the format ( A13, L2 ). An annotated example of a data */
+/* file can be obtained by deleting the first 3 characters from the */
+/* following 23 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. */
+/* cblas_cgemmtr 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. */
+
+ s_rsle(&io___2);
+ do_lio(&c__9, &c__1, snaps, (ftnlen)32);
+ e_rsle();
+ s_rsle(&io___4);
+ do_lio(&c__3, &c__1, (char *)&ntra, (ftnlen)sizeof(integer));
+ e_rsle();
+ 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. */
+ s_rsle(&io___7);
+ do_lio(&c__8, &c__1, (char *)&rewi, (ftnlen)sizeof(logical));
+ e_rsle();
+ rewi = rewi && trace;
+/* Read the flag that directs stopping on any failure. */
+ s_rsle(&io___9);
+ do_lio(&c__8, &c__1, (char *)&sfatal, (ftnlen)sizeof(logical));
+ e_rsle();
+/* Read the flag that indicates whether error exits are to be tested. */
+ s_rsle(&io___11);
+ do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
+ e_rsle();
+/* Read the flag that indicates whether row-major data layout to be tested. */
+ s_rsle(&io___13);
+ do_lio(&c__3, &c__1, (char *)&layout, (ftnlen)sizeof(integer));
+ e_rsle();
+/* Read the threshold value of the test ratio */
+ s_rsle(&io___15);
+ do_lio(&c__4, &c__1, (char *)&thresh, (ftnlen)sizeof(real));
+ e_rsle();
+
+/* Read and check the parameter values for the tests. */
+
+/* Values of N */
+ s_rsle(&io___17);
+ do_lio(&c__3, &c__1, (char *)&nidim, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nidim < 1 || nidim > 9) {
+ s_wsfe(&io___19);
+ do_fio(&c__1, "N", (ftnlen)1);
+ do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+ s_rsle(&io___20);
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) {
+ s_wsfe(&io___23);
+ do_fio(&c__1, (char *)&c__65, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+/* L10: */
+ }
+/* Values of ALPHA */
+ s_rsle(&io___24);
+ do_lio(&c__3, &c__1, (char *)&nalf, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nalf < 1 || nalf > 7) {
+ s_wsfe(&io___26);
+ do_fio(&c__1, "ALPHA", (ftnlen)5);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+ s_rsle(&io___27);
+ i__1 = nalf;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__6, &c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(complex));
+ }
+ e_rsle();
+/* Values of BETA */
+ s_rsle(&io___29);
+ do_lio(&c__3, &c__1, (char *)&nbet, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nbet < 1 || nbet > 7) {
+ s_wsfe(&io___31);
+ do_fio(&c__1, "BETA", (ftnlen)4);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+ s_rsle(&io___32);
+ i__1 = nbet;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__6, &c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(complex));
+ }
+ e_rsle();
+
+/* Report values of parameters. */
+
+ s_wsfe(&io___34);
+ e_wsfe();
+ s_wsfe(&io___35);
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ s_wsfe(&io___36);
+ i__1 = nalf;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__2, (char *)&alf[i__ - 1], (ftnlen)sizeof(real));
+ }
+ e_wsfe();
+ s_wsfe(&io___37);
+ i__1 = nbet;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__2, (char *)&bet[i__ - 1], (ftnlen)sizeof(real));
+ }
+ e_wsfe();
+ if (! tsterr) {
+ s_wsle(&io___38);
+ e_wsle();
+ s_wsfe(&io___39);
+ e_wsfe();
+ }
+ s_wsle(&io___40);
+ e_wsle();
+ s_wsfe(&io___41);
+ do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(real));
+ e_wsfe();
+ s_wsle(&io___42);
+ e_wsle();
+ rorder = FALSE_;
+ corder = FALSE_;
+ if (layout == 2) {
+ rorder = TRUE_;
+ corder = TRUE_;
+ s_wsfe(&io___45);
+ e_wsfe();
+ } else if (layout == 1) {
+ rorder = TRUE_;
+ s_wsfe(&io___46);
+ e_wsfe();
+ } else if (layout == 0) {
+ corder = TRUE_;
+ s_wsfe(&io___47);
+ e_wsfe();
+ }
+ s_wsle(&io___48);
+ e_wsle();
+
+/* Read names of subroutines and flags which indicate */
+/* whether they are to be tested. */
+
+ for (i__ = 1; i__ <= 10; ++i__) {
+ ltest[i__ - 1] = FALSE_;
+/* L20: */
+ }
+L30:
+ i__1 = s_rsfe(&io___50);
+ if (i__1 != 0) {
+ goto L60;
+ }
+ i__1 = do_fio(&c__1, snamet, (ftnlen)13);
+ if (i__1 != 0) {
+ goto L60;
+ }
+ i__1 = do_fio(&c__1, (char *)<estt, (ftnlen)sizeof(logical));
+ if (i__1 != 0) {
+ goto L60;
+ }
+ i__1 = e_rsfe();
+ if (i__1 != 0) {
+ goto L60;
+ }
+ for (i__ = 1; i__ <= 10; ++i__) {
+ if (s_cmp(snamet, snames + (i__ - 1) * 13, (ftnlen)13, (ftnlen)13) ==
+ 0) {
+ goto L50;
+ }
+/* L40: */
+ }
+ s_wsfe(&io___53);
+ do_fio(&c__1, snamet, (ftnlen)13);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+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;
+ s_wsfe(&io___55);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real));
+ e_wsfe();
+
+/* 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) {
+ s_wsfe(&io___68);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+ *(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) {
+ s_wsfe(&io___69);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+ 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) {
+ s_wsfe(&io___70);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+ *(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) {
+ s_wsfe(&io___71);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+/* Test each subroutine in turn. */
+
+ for (isnum = 1; isnum <= 10; ++isnum) {
+ s_wsle(&io___73);
+ e_wsle();
+ if (! ltest[isnum - 1]) {
+/* Subprogram is not to be tested. */
+ s_wsfe(&io___74);
+ do_fio(&c__1, snames + (isnum - 1) * 13, (ftnlen)13);
+ e_wsfe();
+ } else {
+ s_copy(srnamc_1.srnamt, snames + (isnum - 1) * 13, (ftnlen)13, (
+ ftnlen)13);
+/* Test error exits. */
+ if (tsterr) {
+ cc3chke_(snames + (isnum - 1) * 13);
+ s_wsle(&io___75);
+ e_wsle();
+ }
+/* 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;
+ case 10: goto L185;
+ }
+/* Test CGEMM, 01. */
+L140:
+ if (corder) {
+ cchk1_(snames + (isnum - 1) * 13, &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) * 13, &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) * 13, &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) * 13, &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) * 13, &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) * 13, &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) * 13, &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) * 13, &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) * 13, &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) * 13, &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;
+/* Test CGEMMTR, 10. */
+L185:
+ if (corder) {
+ cchk6_(snames + (isnum - 1) * 13, &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) {
+ cchk6_(snames + (isnum - 1) * 13, &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;
+
+L190:
+ if (fatal && sfatal) {
+ goto L210;
+ }
+ }
+/* L200: */
+ }
+ s_wsfe(&io___82);
+ e_wsfe();
+ goto L230;
+
+L210:
+ s_wsfe(&io___83);
+ e_wsfe();
+ goto L230;
+
+L220:
+ s_wsfe(&io___84);
+ e_wsfe();
+
+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);
+
+
+/* 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";
+
+ /* Format strings */
+ static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
+ "TAKEN ON VALID CALL *******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
+ "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
+ " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
+ "BER:\002)";
+
+ /* 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;
+ alist al__1;
+
+ /* Local variables */
+ integer i__, k, m, n, ia, ib, ma, mb, na, nb, nc, ik, im, in, ks, ms, ns,
+ ica, icb, laa, lbb, lda, lcc, ldb, ldc;
+ extern logical lce_(complex *, complex *, integer *);
+ complex als, bls;
+ real err;
+ complex beta;
+ integer ldas, ldbs, ldcs;
+ logical same, null;
+ 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 *), ccgemm_(integer *, char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ extern logical lceres_(char *, char *, integer *, integer *, complex *,
+ complex *, integer *);
+ char tranas[1], tranbs[1], transa[1], transb[1];
+ real errmax;
+
+ /* Fortran I/O blocks */
+ static cilist io___128 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___131 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___133 = { 0, 0, 0, fmt_10000, 0 };
+ static cilist io___134 = { 0, 0, 0, fmt_10001, 0 };
+ static cilist io___135 = { 0, 0, 0, fmt_10002, 0 };
+ static cilist io___136 = { 0, 0, 0, fmt_10003, 0 };
+ static cilist io___137 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* 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;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ 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();
+ *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]) {
+ io___131.ciunit = *nout;
+ s_wsfe(&io___131);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* 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) {
+ io___133.ciunit = *nout;
+ s_wsfe(&io___133);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___134.ciunit = *nout;
+ s_wsfe(&io___134);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ } else {
+ if (*iorder == 0) {
+ io___135.ciunit = *nout;
+ s_wsfe(&io___135);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___136.ciunit = *nout;
+ s_wsfe(&io___136);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ }
+ goto L130;
+
+L120:
+ io___137.ciunit = *nout;
+ s_wsfe(&io___137);
+ do_fio(&c__1, sname, (ftnlen)13);
+ e_wsfe();
+ cprcn1_(nout, &nc, sname, iorder, transa, transb, &m, &n, &k, &alpha, &
+ lda, &ldb, &beta, &ldc);
+
+L130:
+ return 0;
+
+/* 9995 FORMAT( 1X, I6, ': ', A13,'(''', 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)
+{
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
+ "a14,\002,\002,a14,\002,\002)";
+ static char fmt_9994[] = "(10x,3(i3,\002,\002),\002 (\002,f4.1,\002,\002"
+ ",f4.1,\002) , A,\002,i3,\002, B,\002,i3,\002, (\002,f4.1,\002"
+ ",\002,f4.1,\002) , C,\002,i3,\002).\002)";
+
+ /* Local variables */
+ char crc[14], cta[14], ctb[14];
+
+ /* Fortran I/O blocks */
+ static cilist io___141 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___142 = { 0, 0, 0, fmt_9994, 0 };
+
+
+ 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);
+ }
+ io___141.ciunit = *nout;
+ s_wsfe(&io___141);
+ do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, crc, (ftnlen)14);
+ do_fio(&c__1, cta, (ftnlen)14);
+ do_fio(&c__1, ctb, (ftnlen)14);
+ e_wsfe();
+ io___142.ciunit = *nout;
+ s_wsfe(&io___142);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
+ e_wsfe();
+ 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";
+
+ /* Format strings */
+ static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
+ "TAKEN ON VALID CALL *******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
+ "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
+ " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
+ "BER:\002)";
+
+ /* 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;
+ alist al__1;
+
+ /* Local variables */
+ integer i__, m, n, ia, ib, na, nc, im, in, ms, ns, laa, lbb, lda, lcc,
+ ldb, ldc;
+ extern logical lce_(complex *, complex *, integer *);
+ integer ics;
+ complex als, bls;
+ integer icu;
+ real err;
+ complex beta;
+ integer ldas, ldbs, ldcs;
+ logical same;
+ char side[1];
+ logical conj, left, null;
+ char uplo[1];
+ 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 *), cchemm_(
+ integer *, char *, char *, integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, complex *,
+ integer *);
+ 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;
+
+ /* Fortran I/O blocks */
+ static cilist io___181 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___184 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___186 = { 0, 0, 0, fmt_10000, 0 };
+ static cilist io___187 = { 0, 0, 0, fmt_10001, 0 };
+ static cilist io___188 = { 0, 0, 0, fmt_10002, 0 };
+ static cilist io___189 = { 0, 0, 0, fmt_10003, 0 };
+ static cilist io___190 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* 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;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ 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) {
+ io___181.ciunit = *nout;
+ s_wsfe(&io___181);
+ e_wsfe();
+ *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]) {
+ io___184.ciunit = *nout;
+ s_wsfe(&io___184);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* 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) {
+ io___186.ciunit = *nout;
+ s_wsfe(&io___186);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___187.ciunit = *nout;
+ s_wsfe(&io___187);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ } else {
+ if (*iorder == 0) {
+ io___188.ciunit = *nout;
+ s_wsfe(&io___188);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___189.ciunit = *nout;
+ s_wsfe(&io___189);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ }
+ goto L120;
+
+L110:
+ io___190.ciunit = *nout;
+ s_wsfe(&io___190);
+ do_fio(&c__1, sname, (ftnlen)13);
+ e_wsfe();
+ cprcn2_(nout, &nc, sname, iorder, side, uplo, &m, &n, &alpha, &lda, &ldb,
+ &beta, &ldc);
+
+L120:
+ return 0;
+
+/* L9995: */
+
+/* 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)
+{
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
+ "a14,\002,\002,a14,\002,\002)";
+ static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002"
+ ",f4.1,\002), A,\002,i3,\002, B,\002,i3,\002, (\002,f4.1,\002,"
+ "\002,f4.1,\002), \002,\002C,\002,i3,\002).\002)";
+
+ /* Local variables */
+ char cs[14], cu[14], crc[14];
+
+ /* Fortran I/O blocks */
+ static cilist io___194 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___195 = { 0, 0, 0, fmt_9994, 0 };
+
+
+ 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);
+ }
+ io___194.ciunit = *nout;
+ s_wsfe(&io___194);
+ do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, crc, (ftnlen)14);
+ do_fio(&c__1, cs, (ftnlen)14);
+ do_fio(&c__1, cu, (ftnlen)14);
+ e_wsfe();
+ io___195.ciunit = *nout;
+ s_wsfe(&io___195);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
+ e_wsfe();
+ 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";
+
+ /* Format strings */
+ static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
+ "TAKEN ON VALID CALL *******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
+ "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
+ " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
+ "BER:\002)";
+
+ /* 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;
+ alist al__1;
+
+ /* Local variables */
+ integer i__, j, m, n, ia, na, nc, im, in, ms, ns, laa, icd, lbb, lda, ldb;
+ extern logical lce_(complex *, complex *, integer *);
+ integer ics;
+ complex als;
+ integer ict, icu;
+ real err;
+ char diag[1];
+ integer ldas, ldbs;
+ logical same;
+ char side[1];
+ logical left, null;
+ char uplo[1];
+ 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 *);
+ 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;
+
+ /* Fortran I/O blocks */
+ static cilist io___236 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___239 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___241 = { 0, 0, 0, fmt_10000, 0 };
+ static cilist io___242 = { 0, 0, 0, fmt_10001, 0 };
+ static cilist io___243 = { 0, 0, 0, fmt_10002, 0 };
+ static cilist io___244 = { 0, 0, 0, fmt_10003, 0 };
+ static cilist io___245 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* 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;
+ c__ -= c_offset;
+ --g;
+ --ct;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ 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)13, (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)13, (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) {
+ io___236.ciunit = *nout;
+ s_wsfe(&io___236);
+ e_wsfe();
+ *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]) {
+ io___239.ciunit = *nout;
+ s_wsfe(&io___239);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* 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) {
+ io___241.ciunit = *nout;
+ s_wsfe(&io___241);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___242.ciunit = *nout;
+ s_wsfe(&io___242);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ } else {
+ if (*iorder == 0) {
+ io___243.ciunit = *nout;
+ s_wsfe(&io___243);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___244.ciunit = *nout;
+ s_wsfe(&io___244);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ }
+ goto L160;
+
+L150:
+ io___245.ciunit = *nout;
+ s_wsfe(&io___245);
+ do_fio(&c__1, sname, (ftnlen)13);
+ e_wsfe();
+ if (*trace) {
+ cprcn3_(ntra, &nc, sname, iorder, side, uplo, transa, diag, &m, &n, &
+ alpha, &lda, &ldb);
+ }
+
+L160:
+ return 0;
+
+/* L9995: */
+
+/* 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)
+{
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
+ "a14,\002,\002,a14,\002,\002)";
+ static char fmt_9994[] = "(10x,2(a14,\002,\002),2(i3,\002,\002),\002 "
+ "(\002,f4.1,\002,\002,f4.1,\002), A,\002,i3,\002, B,\002,i3,\002)."
+ "\002)";
+
+ /* Local variables */
+ char ca[14], cd[14], cs[14], cu[14], crc[14];
+
+ /* Fortran I/O blocks */
+ static cilist io___251 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___252 = { 0, 0, 0, fmt_9994, 0 };
+
+
+ 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);
+ }
+ io___251.ciunit = *nout;
+ s_wsfe(&io___251);
+ do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, crc, (ftnlen)14);
+ do_fio(&c__1, cs, (ftnlen)14);
+ do_fio(&c__1, cu, (ftnlen)14);
+ e_wsfe();
+ io___252.ciunit = *nout;
+ s_wsfe(&io___252);
+ do_fio(&c__1, ca, (ftnlen)14);
+ do_fio(&c__1, cd, (ftnlen)14);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
+ e_wsfe();
+ 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";
+
+ /* Format strings */
+ static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
+ "TAKEN ON VALID CALL *******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
+ "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
+ " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+ static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
+ "BER:\002)";
+
+ /* 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;
+ alist al__1;
+
+ /* Local variables */
+ integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa,
+ lda, lcc, ldc;
+ extern logical lce_(complex *, complex *, integer *);
+ complex als;
+ integer ict, icu;
+ real err;
+ complex beta;
+ integer ldas, ldcs;
+ logical same, conj;
+ complex bets;
+ real rals;
+ logical tran, null;
+ char uplo[1];
+ 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 *),
+ ccherk_(integer *, char *, char *, integer *, integer *, real *,
+ complex *, integer *, real *, complex *, integer *);
+ 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];
+
+ /* Fortran I/O blocks */
+ static cilist io___294 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___297 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___304 = { 0, 0, 0, fmt_10000, 0 };
+ static cilist io___305 = { 0, 0, 0, fmt_10001, 0 };
+ static cilist io___306 = { 0, 0, 0, fmt_10002, 0 };
+ static cilist io___307 = { 0, 0, 0, fmt_10003, 0 };
+ static cilist io___308 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___309 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* 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;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ 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;
+
+ 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) {
+ io___294.ciunit = *nout;
+ s_wsfe(&io___294);
+ e_wsfe();
+ *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]) {
+ io___297.ciunit = *nout;
+ s_wsfe(&io___297);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* 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) {
+ io___304.ciunit = *nout;
+ s_wsfe(&io___304);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___305.ciunit = *nout;
+ s_wsfe(&io___305);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ } else {
+ if (*iorder == 0) {
+ io___306.ciunit = *nout;
+ s_wsfe(&io___306);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___307.ciunit = *nout;
+ s_wsfe(&io___307);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ }
+ goto L130;
+
+L110:
+ if (n > 1) {
+ io___308.ciunit = *nout;
+ s_wsfe(&io___308);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L120:
+ io___309.ciunit = *nout;
+ s_wsfe(&io___309);
+ do_fio(&c__1, sname, (ftnlen)13);
+ e_wsfe();
+ 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;
+
+/* L9994: */
+/* L9993: */
+
+/* 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)
+{
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002,"
+ "\002))";
+ static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002"
+ ",f4.1,\002), A,\002,i3,\002, (\002,f4.1,\002,\002,f4.1,\002), C"
+ ",\002,i3,\002).\002)";
+
+ /* Local variables */
+ char ca[14], cu[14], crc[14];
+
+ /* Fortran I/O blocks */
+ static cilist io___313 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___314 = { 0, 0, 0, fmt_9994, 0 };
+
+
+ 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);
+ }
+ io___313.ciunit = *nout;
+ s_wsfe(&io___313);
+ do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, crc, (ftnlen)14);
+ do_fio(&c__1, cu, (ftnlen)14);
+ do_fio(&c__1, ca, (ftnlen)14);
+ e_wsfe();
+ io___314.ciunit = *nout;
+ s_wsfe(&io___314);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
+ e_wsfe();
+ 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)
+{
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002,"
+ "\002))";
+ static char fmt_9994[] = "(10x,2(i3,\002,\002),f4.1,\002, A,\002,i3"
+ ",\002,\002,f4.1,\002, C,\002,i3,\002).\002)";
+
+ /* Local variables */
+ char ca[14], cu[14], crc[14];
+
+ /* Fortran I/O blocks */
+ static cilist io___318 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___319 = { 0, 0, 0, fmt_9994, 0 };
+
+
+ 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);
+ }
+ io___318.ciunit = *nout;
+ s_wsfe(&io___318);
+ do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, crc, (ftnlen)14);
+ do_fio(&c__1, cu, (ftnlen)14);
+ do_fio(&c__1, ca, (ftnlen)14);
+ e_wsfe();
+ io___319.ciunit = *nout;
+ s_wsfe(&io___319);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
+ e_wsfe();
+ 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";
+
+ /* Format strings */
+ static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
+ "TAKEN ON VALID CALL *******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
+ "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
+ " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+ static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
+ "BER:\002)";
+
+ /* 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;
+ alist al__1;
+
+ /* Local variables */
+ integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa,
+ lbb, lda, lcc, ldb, ldc;
+ extern logical lce_(complex *, complex *, integer *);
+ complex als;
+ integer ict, icu;
+ real err;
+ integer jjab;
+ complex beta;
+ integer ldas, ldbs, ldcs;
+ logical same, conj;
+ complex bets;
+ logical tran, null;
+ char uplo[1];
+ 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 *);
+ 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 *), ccsyr2k_(integer *
+ , char *, char *, integer *, integer *, complex *, complex *,
+ integer *, complex *, integer *, complex *, complex *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___362 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___365 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___373 = { 0, 0, 0, fmt_10000, 0 };
+ static cilist io___374 = { 0, 0, 0, fmt_10001, 0 };
+ static cilist io___375 = { 0, 0, 0, fmt_10002, 0 };
+ static cilist io___376 = { 0, 0, 0, fmt_10003, 0 };
+ static cilist io___377 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___378 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* 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;
+ 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) {
+ io___362.ciunit = *nout;
+ s_wsfe(&io___362);
+ e_wsfe();
+ *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]) {
+ io___365.ciunit = *nout;
+ s_wsfe(&io___365);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* 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) {
+ io___373.ciunit = *nout;
+ s_wsfe(&io___373);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___374.ciunit = *nout;
+ s_wsfe(&io___374);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ } else {
+ if (*iorder == 0) {
+ io___375.ciunit = *nout;
+ s_wsfe(&io___375);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___376.ciunit = *nout;
+ s_wsfe(&io___376);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ }
+ goto L160;
+
+L140:
+ if (n > 1) {
+ io___377.ciunit = *nout;
+ s_wsfe(&io___377);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L150:
+ io___378.ciunit = *nout;
+ s_wsfe(&io___378);
+ do_fio(&c__1, sname, (ftnlen)13);
+ e_wsfe();
+ 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;
+
+/* L9994: */
+/* L9993: */
+
+/* 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)
+{
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002,"
+ "\002))";
+ static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002"
+ ",f4.1,\002), A,\002,i3,\002, B\002,i3,\002, (\002,f4.1,\002,\002"
+ ",f4.1,\002), C,\002,i3,\002).\002)";
+
+ /* Local variables */
+ char ca[14], cu[14], crc[14];
+
+ /* Fortran I/O blocks */
+ static cilist io___382 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___383 = { 0, 0, 0, fmt_9994, 0 };
+
+
+ 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);
+ }
+ io___382.ciunit = *nout;
+ s_wsfe(&io___382);
+ do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, crc, (ftnlen)14);
+ do_fio(&c__1, cu, (ftnlen)14);
+ do_fio(&c__1, ca, (ftnlen)14);
+ e_wsfe();
+ io___383.ciunit = *nout;
+ s_wsfe(&io___383);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
+ e_wsfe();
+ 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)
+{
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002,"
+ "\002))";
+ static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002"
+ ",f4.1,\002), A,\002,i3,\002, B\002,i3,\002,\002,f4.1,\002, C,"
+ "\002,i3,\002).\002)";
+
+ /* Local variables */
+ char ca[14], cu[14], crc[14];
+
+ /* Fortran I/O blocks */
+ static cilist io___387 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___388 = { 0, 0, 0, fmt_9994, 0 };
+
+
+ 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);
+ }
+ io___387.ciunit = *nout;
+ s_wsfe(&io___387);
+ do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, crc, (ftnlen)14);
+ do_fio(&c__1, cu, (ftnlen)14);
+ do_fio(&c__1, ca, (ftnlen)14);
+ e_wsfe();
+ io___388.ciunit = *nout;
+ s_wsfe(&io___388);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
+ e_wsfe();
+ 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 */
+ integer i__, j, jj;
+ logical gen, her, tri, sym;
+ extern /* Complex */ VOID cbeg_(complex *, logical *);
+ integer ibeg, iend;
+ logical unit, lower, upper;
+
+
+/* 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;
+ 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)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS"
+ " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 "
+ " EXPECTED RE\002,\002SULT COMPUTED R"
+ "ESULT\002)";
+ static char fmt_9998[] = "(1x,i7,2(\002 (\002,g15.6,\002,\002,g15.6,"
+ "\002)\002))";
+ static char fmt_9997[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+
+ /* 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 */
+ integer i__, j, k;
+ real erri;
+ logical trana, tranb, ctrana, ctranb;
+
+ /* Fortran I/O blocks */
+ static cilist io___409 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___410 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___411 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___412 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* 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;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --ct;
+ --g;
+ cc_dim1 = *ldcc;
+ cc_offset = 1 + cc_dim1;
+ 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_;
+ io___409.ciunit = *nout;
+ s_wsfe(&io___409);
+ e_wsfe();
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*mv) {
+ io___410.ciunit = *nout;
+ s_wsfe(&io___410);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&ct[i__], (ftnlen)sizeof(real));
+ do_fio(&c__2, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ } else {
+ io___411.ciunit = *nout;
+ s_wsfe(&io___411);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(real)
+ );
+ do_fio(&c__2, (char *)&ct[i__], (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+/* L240: */
+ }
+ if (*n > 1) {
+ io___412.ciunit = *nout;
+ s_wsfe(&io___412);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+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 i__, j, ibeg, iend;
+ 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;
+ as -= as_offset;
+ aa_dim1 = *lda;
+ aa_offset = 1 + aa_dim1;
+ 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: */
+ }
+ }
+
+/* L60: */
+ 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_ */
+
+/* Subroutine */ int cchk6_(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";
+ static char ishape[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
+ "TAKEN ON VALID CALL *******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
+ "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
+ " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
+ "BER:\002)";
+
+ /* 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;
+ alist al__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int ccgemmtr_(integer *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *, complex *, complex *, integer *);
+ integer i__, k, n, ia, ib, ma, mb, na, nb, nc, ik, in, is, ks, ns, ica,
+ icb, laa, lbb, lda, lcc, ldb, ldc;
+ extern logical lce_(complex *, complex *, integer *);
+ complex als, bls;
+ real err;
+ complex beta;
+ integer ldas, ldbs, ldcs;
+ logical same, null;
+ char uplo[1];
+ extern /* Subroutine */ int cmake_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *, logical *,
+ complex *);
+ complex alpha;
+ logical isame[13], trana, tranb;
+ integer nargs;
+ logical reset;
+ char uplos[1];
+ extern /* Subroutine */ int cprcn8_(integer *, integer *, char *, integer
+ *, char *, char *, char *, integer *, integer *, complex *,
+ integer *, integer *, complex *, integer *), cmmtch_(char *, char *, char *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *, complex *, real *, complex *,
+ integer *, real *, real *, logical *, integer *, logical *);
+ extern logical lceres_(char *, char *, integer *, integer *, complex *,
+ complex *, integer *);
+ char tranas[1], tranbs[1], transa[1], transb[1];
+ real errmax;
+
+ /* Fortran I/O blocks */
+ static cilist io___468 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___471 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___473 = { 0, 0, 0, fmt_10000, 0 };
+ static cilist io___474 = { 0, 0, 0, fmt_10001, 0 };
+ static cilist io___475 = { 0, 0, 0, fmt_10002, 0 };
+ static cilist io___476 = { 0, 0, 0, fmt_10003, 0 };
+ static cilist io___477 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* Tests CGEMMTR. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 24-June-2024. */
+/* Martin Koehler, Max Planck Institute Magdeburg */
+
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+
+ nargs = 13;
+ 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 L100;
+ }
+ lcc = ldc * n;
+ null = (real) n <= 0.f;
+
+ i__2 = *nidim;
+ for (ik = 1; ik <= i__2; ++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 = 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 (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__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;
+ for (is = 1; is <= 2; ++is) {
+ *(unsigned char *)uplo = *(unsigned char *)&
+ ishape[is - 1];
+
+/* Generate the matrix C. */
+
+ cmake_("ge", 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 *)tranas = *(unsigned char *)
+ transa;
+ *(unsigned char *)tranbs = *(unsigned char *)
+ transb;
+ 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;
+ 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) {
+ cprcn8_(ntra, &nc, sname, iorder, uplo,
+ transa, transb, &n, &k, &alpha, &
+ lda, &ldb, &beta, &ldc);
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ ccgemmtr_(iorder, uplo, transa, transb, &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___468.ciunit = *nout;
+ s_wsfe(&io___468);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)uplo == *(
+ unsigned char *)uplos;
+ isame[1] = *(unsigned char *)transa == *(
+ unsigned char *)tranas;
+ isame[2] = *(unsigned char *)transb == *(
+ unsigned char *)tranbs;
+ 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", " ", &n, &n, &
+ cs[1], &cc[1], &ldc);
+ }
+ isame[12] = 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]) {
+ io___471.ciunit = *nout;
+ s_wsfe(&io___471);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+ if (! null) {
+
+/* Check the result. */
+
+ cmmtch_(uplo, transa, transb, &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;
+ }
+ }
+
+/* L45: */
+ }
+
+/* L50: */
+ }
+
+/* L60: */
+ }
+
+L70:
+ ;
+ }
+
+L80:
+ ;
+ }
+
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ if (*iorder == 0) {
+ io___473.ciunit = *nout;
+ s_wsfe(&io___473);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___474.ciunit = *nout;
+ s_wsfe(&io___474);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ } else {
+ if (*iorder == 0) {
+ io___475.ciunit = *nout;
+ s_wsfe(&io___475);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___476.ciunit = *nout;
+ s_wsfe(&io___476);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ }
+ goto L130;
+
+L120:
+ io___477.ciunit = *nout;
+ s_wsfe(&io___477);
+ do_fio(&c__1, sname, (ftnlen)13);
+ e_wsfe();
+ cprcn8_(nout, &nc, sname, iorder, uplo, transa, transb, &n, &k, &alpha, &
+ lda, &ldb, &beta, &ldc);
+
+L130:
+ return 0;
+
+/* L9995: */
+
+/* End of CCHK6. */
+
+} /* cchk6_ */
+
+/* Subroutine */ int cprcn8_(integer *nout, integer *nc, char *sname, integer
+ *iorder, char *uplo, char *transa, char *transb, integer *n, integer *
+ k, complex *alpha, integer *lda, integer *ldb, complex *beta, integer
+ *ldc)
+{
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
+ "a14,\002,\002,a14,\002,\002,a14,\002,\002)";
+ static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002"
+ ",f4.1,\002) , A,\002,i3,\002, B,\002,i3,\002, (\002,f4.1,\002"
+ ",\002,f4.1,\002) , C,\002,i3,\002).\002)";
+
+ /* Local variables */
+ char crc[14], cta[14], ctb[14], cuplo[14];
+
+ /* Fortran I/O blocks */
+ static cilist io___482 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___483 = { 0, 0, 0, fmt_9994, 0 };
+
+
+ if (*(unsigned char *)uplo == 'U') {
+ s_copy(cuplo, "CblasUpper", (ftnlen)14, (ftnlen)10);
+ } else {
+ s_copy(cuplo, "CblasLower", (ftnlen)14, (ftnlen)10);
+ }
+ 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);
+ }
+ io___482.ciunit = *nout;
+ s_wsfe(&io___482);
+ do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, crc, (ftnlen)14);
+ do_fio(&c__1, cuplo, (ftnlen)14);
+ do_fio(&c__1, cta, (ftnlen)14);
+ do_fio(&c__1, ctb, (ftnlen)14);
+ e_wsfe();
+ io___483.ciunit = *nout;
+ s_wsfe(&io___483);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
+ e_wsfe();
+ return 0;
+} /* cprcn8_ */
+
+/* Subroutine */ int cmmtch_(char *uplo, char *transa, char *transb, 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)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS"
+ " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 "
+ " EXPECTED RE\002,\002SULT COMPUTED R"
+ "ESULT\002)";
+ static char fmt_9998[] = "(1x,i7,2(\002 (\002,g15.6,\002,\002,g15.6,"
+ "\002)\002))";
+ static char fmt_9997[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+
+ /* 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 */
+ integer i__, j, k;
+ real erri;
+ logical trana, tranb, upper;
+ integer istop;
+ logical ctrana, ctranb;
+ integer istart;
+
+ /* Fortran I/O blocks */
+ static cilist io___495 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___496 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___497 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___498 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* Checks the results of the computational tests for GEMMTR. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 24-June-2024. */
+/* Martin Koehler, Max Planck Institute, Magdeburg */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --ct;
+ --g;
+ cc_dim1 = *ldcc;
+ cc_offset = 1 + cc_dim1;
+ cc -= cc_offset;
+
+ /* Function Body */
+ upper = *(unsigned char *)uplo == 'U';
+ 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';
+ istart = 1;
+ istop = *n;
+
+/* 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) {
+
+ if (upper) {
+ istart = 1;
+ istop = j;
+ } else {
+ istart = j;
+ istop = *n;
+ }
+ i__2 = istop;
+ for (i__ = istart; 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 = istop;
+ for (i__ = istart; 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 = istop;
+ for (i__ = istart; 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 = istop;
+ for (i__ = istart; 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 = istop;
+ for (i__ = istart; 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 = istop;
+ for (i__ = istart; 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 = istop;
+ for (i__ = istart; 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 = istop;
+ for (i__ = istart; 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 = istop;
+ for (i__ = istart; 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 = istop;
+ for (i__ = istart; 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 = istop;
+ for (i__ = istart; 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 = istop;
+ for (i__ = istart; 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_;
+ io___495.ciunit = *nout;
+ s_wsfe(&io___495);
+ e_wsfe();
+ i__1 = istop;
+ for (i__ = istart; i__ <= i__1; ++i__) {
+ if (*mv) {
+ io___496.ciunit = *nout;
+ s_wsfe(&io___496);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&ct[i__], (ftnlen)sizeof(real));
+ do_fio(&c__2, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ } else {
+ io___497.ciunit = *nout;
+ s_wsfe(&io___497);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(real)
+ );
+ do_fio(&c__2, (char *)&ct[i__], (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+/* L240: */
+ }
+ if (*n > 1) {
+ io___498.ciunit = *nout;
+ s_wsfe(&io___498);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L250:
+ return 0;
+
+
+/* End of CMMTCH. */
+
+} /* cmmtch_ */
+
+/* Main program alias */ int cblat3_ () { MAIN__ (); return 0; }
diff --git a/ctest/c_dblat3c.c b/ctest/c_dblat3c.c
index 447b23014f..2dea060673 100644
--- a/ctest/c_dblat3c.c
+++ b/ctest/c_dblat3c.c
@@ -10,25 +10,7 @@
#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
+#include "common.h"
typedef blasint integer;
@@ -509,3 +491,4410 @@ static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integ
+/* -- translated by f2c (version 20200916).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+
+
+/* Common Block Declarations */
+
+union {
+ struct {
+ integer infot, noutc;
+ logical ok;
+ } _1;
+ struct {
+ integer infot, noutc;
+ logical ok, lerr;
+ } _2;
+} infoc_;
+
+#define infoc_1 (infoc_._1)
+#define infoc_2 (infoc_._2)
+
+struct {
+ char srnamt[13];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__9 = 9;
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__8 = 8;
+static integer c__5 = 5;
+static integer c__65 = 65;
+static integer c__7 = 7;
+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 */ int main(void)
+{
+ /* Initialized data */
+
+ static char snames[13*7] = "cblas_dgemm " "cblas_dsymm " "cblas_dtrmm "
+ "cblas_dtrsm " "cblas_dsyrk " "cblas_dsyr2k " "cblas_dgemmtr";
+
+ /* Format strings */
+ static char fmt_9997[] = "(\002 NUMBER OF VALUES OF \002,a,\002 IS LESS "
+ "THAN 1 OR GREATER \002,\002THAN \002,i2)";
+ static char fmt_9996[] = "(\002 VALUE OF N IS LESS THAN 0 OR GREATER THA"
+ "N \002,i2)";
+ static char fmt_9995[] = "(\002 TESTS OF THE DOUBLE PRECISION LEVEL 3 BL"
+ "AS\002,//\002 THE F\002,\002OLLOWING PARAMETER VALUES WILL BE US"
+ "ED:\002)";
+ static char fmt_9994[] = "(\002 FOR N \002,9i6)";
+ static char fmt_9993[] = "(\002 FOR ALPHA \002,7f6.1)";
+ static char fmt_9992[] = "(\002 FOR BETA \002,7f6.1)";
+ static char fmt_9984[] = "(\002 ERROR-CALL MYEXITS WILL NOT BE TESTED"
+ "\002)";
+ static char fmt_9999[] = "(\002 ROUTINES PASS COMPUTATIONAL TESTS IF TES"
+ "T RATIO IS LES\002,\002S THAN\002,f8.2)";
+ static char fmt_10002[] = "(\002 COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS"
+ " ARE TESTED\002)";
+ static char fmt_10001[] = "(\002 ROW-MAJOR DATA LAYOUT IS TESTED\002)";
+ static char fmt_10000[] = "(\002 COLUMN-MAJOR DATA LAYOUT IS TESTED\002)";
+ static char fmt_9988[] = "(a13,l2)";
+ static char fmt_9990[] = "(\002 SUBPROGRAM NAME \002,a13,\002 NOT RECOGN"
+ "IZED\002,/\002 ******* T\002,\002ESTS ABANDONED *******\002)";
+ static char fmt_9998[] = "(\002 RELATIVE MACHINE PRECISION IS TAKEN TO"
+ " BE\002,1p,d9.1)";
+ static char fmt_9989[] = "(\002 ERROR IN DMMCH - IN-LINE DOT PRODUCTS A"
+ "RE BEING EVALU\002,\002ATED WRONGLY.\002,/\002 DMMCH WAS CALLED "
+ "WITH TRANSA = \002,a1,\002 AND TRANSB = \002,a1,/\002 AND RETURN"
+ "ED SAME = \002,l1,\002 AND \002,\002ERR = \002,f12.3,\002.\002,"
+ "/\002 THIS MAY BE DUE TO FAULTS IN THE \002,\002ARITHMETIC OR TH"
+ "E COMPILER.\002,/\002 ******* TESTS ABANDONED \002,\002******"
+ "*\002)";
+ static char fmt_9987[] = "(1x,a13,\002 WAS NOT TESTED\002)";
+ static char fmt_9986[] = "(/\002 END OF TESTS\002)";
+ static char fmt_9985[] = "(/\002 ******* FATAL ERROR - TESTS ABANDONED *"
+ "******\002)";
+ static char fmt_9991[] = "(\002 AMEND DATA FILE OR INCREASE ARRAY SIZES "
+ "IN PROGRAM\002,/\002 ******* TESTS ABANDONED *******\002)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublereal d__1;
+ olist o__1;
+ cllist cl__1;
+
+ /* Local variables */
+ doublereal c__[4225] /* was [65][65] */, g[65];
+ integer i__, j, n;
+ doublereal w[130], aa[4225], ab[8450] /* was [65][130] */, bb[4225],
+ cc[4225], as[4225], bs[4225], cs[4225], ct[65], alf[7];
+ extern logical lde_(doublereal *, doublereal *, integer *);
+ doublereal bet[7], eps, err;
+ integer nalf, idim[9];
+ logical same;
+ integer nbet, ntra;
+ logical rewi;
+ extern /* Subroutine */ int dchk1_(char *, doublereal *, doublereal *,
+ integer *, integer *, logical *, logical *, logical *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ dchk2_(char *, doublereal *, doublereal *, integer *, integer *,
+ logical *, logical *, logical *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *), dchk3_(char *,
+ doublereal *, doublereal *, integer *, integer *, logical *,
+ logical *, logical *, integer *, integer *, integer *, doublereal
+ *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *), dchk4_(char *,
+ doublereal *, doublereal *, integer *, integer *, logical *,
+ logical *, logical *, integer *, integer *, integer *, doublereal
+ *, integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *), dchk5_(char *, doublereal *,
+ doublereal *, integer *, integer *, logical *, logical *, logical
+ *, integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *), dchk6_(char *, doublereal *, doublereal *, integer *,
+ integer *, logical *, logical *, logical *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ extern doublereal ddiff_(doublereal *, doublereal *);
+ logical fatal;
+ extern /* Subroutine */ int dmmch_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ logical *, integer *, logical *);
+ logical trace;
+ integer nidim;
+ char snaps[32];
+ integer isnum;
+ logical ltest[7], sfatal, corder;
+ char snamet[13], transa[1], transb[1];
+ doublereal thresh;
+ logical rorder;
+ extern /* Subroutine */ int cd3chke_(char *);
+ integer layout;
+ logical ltestt, tsterr;
+
+ /* Fortran I/O blocks */
+ static cilist io___2 = { 0, 5, 0, 0, 0 };
+ static cilist io___4 = { 0, 5, 0, 0, 0 };
+ static cilist io___7 = { 0, 5, 0, 0, 0 };
+ static cilist io___9 = { 0, 5, 0, 0, 0 };
+ static cilist io___11 = { 0, 5, 0, 0, 0 };
+ static cilist io___13 = { 0, 5, 0, 0, 0 };
+ static cilist io___15 = { 0, 5, 0, 0, 0 };
+ static cilist io___17 = { 0, 5, 0, 0, 0 };
+ static cilist io___19 = { 0, 6, 0, fmt_9997, 0 };
+ static cilist io___20 = { 0, 5, 0, 0, 0 };
+ static cilist io___23 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___24 = { 0, 5, 0, 0, 0 };
+ static cilist io___26 = { 0, 6, 0, fmt_9997, 0 };
+ static cilist io___27 = { 0, 5, 0, 0, 0 };
+ static cilist io___29 = { 0, 5, 0, 0, 0 };
+ static cilist io___31 = { 0, 6, 0, fmt_9997, 0 };
+ static cilist io___32 = { 0, 5, 0, 0, 0 };
+ static cilist io___34 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___35 = { 0, 6, 0, fmt_9994, 0 };
+ static cilist io___36 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___37 = { 0, 6, 0, fmt_9992, 0 };
+ static cilist io___38 = { 0, 6, 0, 0, 0 };
+ static cilist io___39 = { 0, 6, 0, fmt_9984, 0 };
+ static cilist io___40 = { 0, 6, 0, 0, 0 };
+ static cilist io___41 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 6, 0, 0, 0 };
+ static cilist io___45 = { 0, 6, 0, fmt_10002, 0 };
+ static cilist io___46 = { 0, 6, 0, fmt_10001, 0 };
+ static cilist io___47 = { 0, 6, 0, fmt_10000, 0 };
+ static cilist io___48 = { 0, 6, 0, 0, 0 };
+ static cilist io___50 = { 0, 5, 1, fmt_9988, 0 };
+ static cilist io___53 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___55 = { 0, 6, 0, fmt_9998, 0 };
+ static cilist io___68 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___69 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___70 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___71 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___73 = { 0, 6, 0, 0, 0 };
+ static cilist io___74 = { 0, 6, 0, fmt_9987, 0 };
+ static cilist io___75 = { 0, 6, 0, 0, 0 };
+ static cilist io___82 = { 0, 6, 0, fmt_9986, 0 };
+ static cilist io___83 = { 0, 6, 0, fmt_9985, 0 };
+ static cilist io___84 = { 0, 6, 0, fmt_9991, 0 };
+
+
+
+/* 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 ( A13, 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 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 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. */
+/* cblas_dgemmtr 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. */
+
+
+/* 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. */
+
+ s_rsle(&io___2);
+ do_lio(&c__9, &c__1, snaps, (ftnlen)32);
+ e_rsle();
+ s_rsle(&io___4);
+ do_lio(&c__3, &c__1, (char *)&ntra, (ftnlen)sizeof(integer));
+ e_rsle();
+ 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. */
+ s_rsle(&io___7);
+ do_lio(&c__8, &c__1, (char *)&rewi, (ftnlen)sizeof(logical));
+ e_rsle();
+ rewi = rewi && trace;
+/* Read the flag that directs stopping on any failure. */
+ s_rsle(&io___9);
+ do_lio(&c__8, &c__1, (char *)&sfatal, (ftnlen)sizeof(logical));
+ e_rsle();
+/* Read the flag that indicates whether error exits are to be tested. */
+ s_rsle(&io___11);
+ do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
+ e_rsle();
+/* Read the flag that indicates whether row-major data layout to be tested. */
+ s_rsle(&io___13);
+ do_lio(&c__3, &c__1, (char *)&layout, (ftnlen)sizeof(integer));
+ e_rsle();
+/* Read the threshold value of the test ratio */
+ s_rsle(&io___15);
+ do_lio(&c__5, &c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_rsle();
+
+/* Read and check the parameter values for the tests. */
+
+/* Values of N */
+ s_rsle(&io___17);
+ do_lio(&c__3, &c__1, (char *)&nidim, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nidim < 1 || nidim > 9) {
+ s_wsfe(&io___19);
+ do_fio(&c__1, "N", (ftnlen)1);
+ do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+ s_rsle(&io___20);
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) {
+ s_wsfe(&io___23);
+ do_fio(&c__1, (char *)&c__65, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+/* L10: */
+ }
+/* Values of ALPHA */
+ s_rsle(&io___24);
+ do_lio(&c__3, &c__1, (char *)&nalf, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nalf < 1 || nalf > 7) {
+ s_wsfe(&io___26);
+ do_fio(&c__1, "ALPHA", (ftnlen)5);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+ s_rsle(&io___27);
+ i__1 = nalf;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__5, &c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(doublereal)
+ );
+ }
+ e_rsle();
+/* Values of BETA */
+ s_rsle(&io___29);
+ do_lio(&c__3, &c__1, (char *)&nbet, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nbet < 1 || nbet > 7) {
+ s_wsfe(&io___31);
+ do_fio(&c__1, "BETA", (ftnlen)4);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+ s_rsle(&io___32);
+ i__1 = nbet;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__5, &c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(doublereal)
+ );
+ }
+ e_rsle();
+
+/* Report values of parameters. */
+
+ s_wsfe(&io___34);
+ e_wsfe();
+ s_wsfe(&io___35);
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ s_wsfe(&io___36);
+ i__1 = nalf;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(doublereal));
+ }
+ e_wsfe();
+ s_wsfe(&io___37);
+ i__1 = nbet;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(doublereal));
+ }
+ e_wsfe();
+ if (! tsterr) {
+ s_wsle(&io___38);
+ e_wsle();
+ s_wsfe(&io___39);
+ e_wsfe();
+ }
+ s_wsle(&io___40);
+ e_wsle();
+ s_wsfe(&io___41);
+ do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ s_wsle(&io___42);
+ e_wsle();
+ rorder = FALSE_;
+ corder = FALSE_;
+ if (layout == 2) {
+ rorder = TRUE_;
+ corder = TRUE_;
+ s_wsfe(&io___45);
+ e_wsfe();
+ } else if (layout == 1) {
+ rorder = TRUE_;
+ s_wsfe(&io___46);
+ e_wsfe();
+ } else if (layout == 0) {
+ corder = TRUE_;
+ s_wsfe(&io___47);
+ e_wsfe();
+ }
+ s_wsle(&io___48);
+ e_wsle();
+
+/* Read names of subroutines and flags which indicate */
+/* whether they are to be tested. */
+
+ for (i__ = 1; i__ <= 7; ++i__) {
+ ltest[i__ - 1] = FALSE_;
+/* L20: */
+ }
+L30:
+ i__1 = s_rsfe(&io___50);
+ if (i__1 != 0) {
+ goto L60;
+ }
+ i__1 = do_fio(&c__1, snamet, (ftnlen)13);
+ if (i__1 != 0) {
+ goto L60;
+ }
+ i__1 = do_fio(&c__1, (char *)<estt, (ftnlen)sizeof(logical));
+ if (i__1 != 0) {
+ goto L60;
+ }
+ i__1 = e_rsfe();
+ if (i__1 != 0) {
+ goto L60;
+ }
+ for (i__ = 1; i__ <= 7; ++i__) {
+ if (s_cmp(snamet, snames + (i__ - 1) * 13, (ftnlen)13, (ftnlen)13) ==
+ 0) {
+ goto L50;
+ }
+/* L40: */
+ }
+ s_wsfe(&io___53);
+ do_fio(&c__1, snamet, (ftnlen)13);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+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;
+ s_wsfe(&io___55);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+
+/* 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);
+ same = lde_(cc, ct, &n);
+ if (! same || err != 0.) {
+ s_wsfe(&io___68);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+ *(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);
+ same = lde_(cc, ct, &n);
+ if (! same || err != 0.) {
+ s_wsfe(&io___69);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+ 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);
+ same = lde_(cc, ct, &n);
+ if (! same || err != 0.) {
+ s_wsfe(&io___70);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+ *(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);
+ same = lde_(cc, ct, &n);
+ if (! same || err != 0.) {
+ s_wsfe(&io___71);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+/* Test each subroutine in turn. */
+
+ for (isnum = 1; isnum <= 7; ++isnum) {
+ s_wsle(&io___73);
+ e_wsle();
+ if (! ltest[isnum - 1]) {
+/* Subprogram is not to be tested. */
+ s_wsfe(&io___74);
+ do_fio(&c__1, snames + (isnum - 1) * 13, (ftnlen)13);
+ e_wsfe();
+ } else {
+ s_copy(srnamc_1.srnamt, snames + (isnum - 1) * 13, (ftnlen)13, (
+ ftnlen)13);
+/* Test error exits. */
+ if (tsterr) {
+ cd3chke_(snames + (isnum - 1) * 13);
+ s_wsle(&io___75);
+ e_wsle();
+ }
+/* 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 L160;
+ case 4: goto L160;
+ case 5: goto L170;
+ case 6: goto L180;
+ case 7: goto L185;
+ }
+/* Test DGEMM, 01. */
+L140:
+ if (corder) {
+ dchk1_(snames + (isnum - 1) * 13, &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) {
+ dchk1_(snames + (isnum - 1) * 13, &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 DSYMM, 02. */
+L150:
+ if (corder) {
+ dchk2_(snames + (isnum - 1) * 13, &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) {
+ dchk2_(snames + (isnum - 1) * 13, &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 DTRMM, 03, DTRSM, 04. */
+L160:
+ if (corder) {
+ dchk3_(snames + (isnum - 1) * 13, &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) {
+ dchk3_(snames + (isnum - 1) * 13, &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 DSYRK, 05. */
+L170:
+ if (corder) {
+ dchk4_(snames + (isnum - 1) * 13, &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) {
+ dchk4_(snames + (isnum - 1) * 13, &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 DSYR2K, 06. */
+L180:
+ if (corder) {
+ dchk5_(snames + (isnum - 1) * 13, &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) {
+ dchk5_(snames + (isnum - 1) * 13, &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;
+/* Test DGEMMTR, 07. */
+L185:
+ if (corder) {
+ dchk6_(snames + (isnum - 1) * 13, &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) {
+ dchk6_(snames + (isnum - 1) * 13, &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: */
+ }
+ s_wsfe(&io___82);
+ e_wsfe();
+ goto L230;
+
+L210:
+ s_wsfe(&io___83);
+ e_wsfe();
+ goto L230;
+
+L220:
+ s_wsfe(&io___84);
+ e_wsfe();
+
+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);
+
+
+/* End of DBLAT3. */
+
+ return 0;
+} /* MAIN__ */
+
+/* Subroutine */ int dchk1_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nalf, doublereal *alf,
+ integer *nbet, doublereal *bet, integer *nmax, doublereal *a,
+ doublereal *aa, doublereal *as, doublereal *b, doublereal *bb,
+ doublereal *bs, doublereal *c__, doublereal *cc, doublereal *cs,
+ doublereal *ct, doublereal *g, integer *iorder)
+{
+ /* Initialized data */
+
+ static char ich[3] = "NTC";
+
+ /* Format strings */
+ static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
+ "TAKEN ON VALID CALL *******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
+ "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
+ " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
+ "BER:\002)";
+
+ /* 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;
+ alist al__1;
+
+ /* Local variables */
+ integer i__, k, m, n, ia, ib, ma, mb, na, nb, nc, ik, im, in, ks, ms, ns,
+ ica, icb, laa, lbb, lda, lcc, ldb, ldc;
+ extern logical lde_(doublereal *, doublereal *, integer *);
+ doublereal als, bls, err, beta;
+ integer ldas, ldbs, ldcs;
+ logical same, null;
+ extern /* Subroutine */ int dmake_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ logical *, doublereal *);
+ doublereal alpha;
+ extern /* Subroutine */ int dmmch_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ logical *, integer *, logical *);
+ logical isame[13], trana, tranb;
+ integer nargs;
+ logical reset;
+ extern /* Subroutine */ int dprcn1_(integer *, integer *, char *, integer
+ *, char *, char *, integer *, integer *, integer *, doublereal *,
+ integer *, integer *, doublereal *, integer *), cdgemm_(integer *, char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ extern logical lderes_(char *, char *, integer *, integer *, doublereal *,
+ doublereal *, integer *);
+ char tranas[1], tranbs[1], transa[1], transb[1];
+ doublereal errmax;
+
+ /* Fortran I/O blocks */
+ static cilist io___128 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___131 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___133 = { 0, 0, 0, fmt_10000, 0 };
+ static cilist io___134 = { 0, 0, 0, fmt_10001, 0 };
+ static cilist io___135 = { 0, 0, 0, fmt_10002, 0 };
+ static cilist io___136 = { 0, 0, 0, fmt_10003, 0 };
+ static cilist io___137 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* 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. */
+
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+
+ 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);
+
+ 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);
+
+ 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);
+
+ ++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);
+ }
+ 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);
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___128.ciunit = *nout;
+ s_wsfe(&io___128);
+ e_wsfe();
+ *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);
+ }
+ 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]) {
+ io___131.ciunit = *nout;
+ s_wsfe(&io___131);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* 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);
+ 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) {
+ io___133.ciunit = *nout;
+ s_wsfe(&io___133);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___134.ciunit = *nout;
+ s_wsfe(&io___134);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ } else {
+ if (*iorder == 0) {
+ io___135.ciunit = *nout;
+ s_wsfe(&io___135);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___136.ciunit = *nout;
+ s_wsfe(&io___136);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ }
+ goto L130;
+
+L120:
+ io___137.ciunit = *nout;
+ s_wsfe(&io___137);
+ do_fio(&c__1, sname, (ftnlen)13);
+ e_wsfe();
+ dprcn1_(nout, &nc, sname, iorder, transa, transb, &m, &n, &k, &alpha, &
+ lda, &ldb, &beta, &ldc);
+
+L130:
+ return 0;
+
+/* L9995: */
+
+/* End of DCHK1. */
+
+} /* dchk1_ */
+
+/* Subroutine */ int dprcn1_(integer *nout, integer *nc, char *sname, integer
+ *iorder, char *transa, char *transb, integer *m, integer *n, integer *
+ k, doublereal *alpha, integer *lda, integer *ldb, doublereal *beta,
+ integer *ldc)
+{
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
+ "a14,\002,\002,a14,\002,\002)";
+ static char fmt_9994[] = "(20x,3(i3,\002,\002),f4.1,\002, A,\002,i3,\002"
+ ", B,\002,i3,\002,\002,f4.1,\002, \002,\002C,\002,i3,\002).\002)";
+
+ /* Local variables */
+ char crc[14], cta[14], ctb[14];
+
+ /* Fortran I/O blocks */
+ static cilist io___141 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___142 = { 0, 0, 0, fmt_9994, 0 };
+
+
+ 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);
+ }
+ io___141.ciunit = *nout;
+ s_wsfe(&io___141);
+ do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, crc, (ftnlen)14);
+ do_fio(&c__1, cta, (ftnlen)14);
+ do_fio(&c__1, ctb, (ftnlen)14);
+ e_wsfe();
+ io___142.ciunit = *nout;
+ s_wsfe(&io___142);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
+ e_wsfe();
+ return 0;
+} /* dprcn1_ */
+
+
+/* Subroutine */ int dchk2_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nalf, doublereal *alf,
+ integer *nbet, doublereal *bet, integer *nmax, doublereal *a,
+ doublereal *aa, doublereal *as, doublereal *b, doublereal *bb,
+ doublereal *bs, doublereal *c__, doublereal *cc, doublereal *cs,
+ doublereal *ct, doublereal *g, integer *iorder)
+{
+ /* Initialized data */
+
+ static char ichs[2] = "LR";
+ static char ichu[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
+ "TAKEN ON VALID CALL *******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
+ "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
+ " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
+ "BER:\002)";
+
+ /* 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;
+ alist al__1;
+
+ /* Local variables */
+ integer i__, m, n, ia, ib, na, nc, im, in, ms, ns, laa, lbb, lda, lcc,
+ ldb, ldc;
+ extern logical lde_(doublereal *, doublereal *, integer *);
+ integer ics;
+ doublereal als, bls;
+ integer icu;
+ doublereal err, beta;
+ integer ldas, ldbs, ldcs;
+ logical same;
+ char side[1];
+ logical left, null;
+ char uplo[1];
+ extern /* Subroutine */ int dmake_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ logical *, doublereal *);
+ doublereal alpha;
+ extern /* Subroutine */ int dmmch_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ logical *, integer *, logical *);
+ logical isame[13];
+ char sides[1];
+ integer nargs;
+ logical reset;
+ char uplos[1];
+ extern /* Subroutine */ int dprcn2_(integer *, integer *, char *, integer
+ *, char *, char *, integer *, integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *);
+ extern logical lderes_(char *, char *, integer *, integer *, doublereal *,
+ doublereal *, integer *);
+ extern /* Subroutine */ int cdsymm_(integer *, char *, char *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ doublereal errmax;
+
+ /* Fortran I/O blocks */
+ static cilist io___180 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___183 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___185 = { 0, 0, 0, fmt_10000, 0 };
+ static cilist io___186 = { 0, 0, 0, fmt_10001, 0 };
+ static cilist io___187 = { 0, 0, 0, fmt_10002, 0 };
+ static cilist io___188 = { 0, 0, 0, fmt_10003, 0 };
+ static cilist io___189 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* 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. */
+
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+
+ 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);
+
+ 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);
+
+ 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);
+
+ ++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)
+ ;
+ }
+ 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);
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___180.ciunit = *nout;
+ s_wsfe(&io___180);
+ e_wsfe();
+ *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);
+ }
+ 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]) {
+ io___183.ciunit = *nout;
+ s_wsfe(&io___183);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* 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);
+ } 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);
+ }
+ 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) {
+ io___185.ciunit = *nout;
+ s_wsfe(&io___185);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___186.ciunit = *nout;
+ s_wsfe(&io___186);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ } else {
+ if (*iorder == 0) {
+ io___187.ciunit = *nout;
+ s_wsfe(&io___187);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___188.ciunit = *nout;
+ s_wsfe(&io___188);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ }
+ goto L120;
+
+L110:
+ io___189.ciunit = *nout;
+ s_wsfe(&io___189);
+ do_fio(&c__1, sname, (ftnlen)13);
+ e_wsfe();
+ dprcn2_(nout, &nc, sname, iorder, side, uplo, &m, &n, &alpha, &lda, &ldb,
+ &beta, &ldc);
+
+L120:
+ return 0;
+
+/* L9995: */
+
+/* End of DCHK2. */
+
+} /* dchk2_ */
+
+
+/* Subroutine */ int dprcn2_(integer *nout, integer *nc, char *sname, integer
+ *iorder, char *side, char *uplo, integer *m, integer *n, doublereal *
+ alpha, integer *lda, integer *ldb, doublereal *beta, integer *ldc)
+{
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
+ "a14,\002,\002,a14,\002,\002)";
+ static char fmt_9994[] = "(20x,2(i3,\002,\002),f4.1,\002, A,\002,i3,\002"
+ ", B,\002,i3,\002,\002,f4.1,\002, \002,\002C,\002,i3,\002).\002)";
+
+ /* Local variables */
+ char cs[14], cu[14], crc[14];
+
+ /* Fortran I/O blocks */
+ static cilist io___193 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___194 = { 0, 0, 0, fmt_9994, 0 };
+
+
+ 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);
+ }
+ io___193.ciunit = *nout;
+ s_wsfe(&io___193);
+ do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, crc, (ftnlen)14);
+ do_fio(&c__1, cs, (ftnlen)14);
+ do_fio(&c__1, cu, (ftnlen)14);
+ e_wsfe();
+ io___194.ciunit = *nout;
+ s_wsfe(&io___194);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
+ e_wsfe();
+ return 0;
+} /* dprcn2_ */
+
+
+/* Subroutine */ int dchk3_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nalf, doublereal *alf,
+ integer *nmax, doublereal *a, doublereal *aa, doublereal *as,
+ doublereal *b, doublereal *bb, doublereal *bs, doublereal *ct,
+ doublereal *g, doublereal *c__, integer *iorder)
+{
+ /* Initialized data */
+
+ static char ichu[2] = "UL";
+ static char icht[3] = "NTC";
+ static char ichd[2] = "UN";
+ static char ichs[2] = "LR";
+
+ /* Format strings */
+ static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
+ "TAKEN ON VALID CALL *******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
+ "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
+ " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
+ "BER:\002)";
+
+ /* 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;
+ alist al__1;
+
+ /* Local variables */
+ integer i__, j, m, n, ia, na, nc, im, in, ms, ns, laa, icd, lbb, lda, ldb;
+ extern logical lde_(doublereal *, doublereal *, integer *);
+ integer ics;
+ doublereal als;
+ integer ict, icu;
+ doublereal err;
+ char diag[1];
+ integer ldas, ldbs;
+ logical same;
+ char side[1];
+ logical left, null;
+ char uplo[1];
+ extern /* Subroutine */ int dmake_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ logical *, doublereal *);
+ doublereal alpha;
+ char diags[1];
+ extern /* Subroutine */ int dmmch_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ logical *, integer *, logical *);
+ logical isame[13];
+ char sides[1];
+ integer nargs;
+ logical reset;
+ char uplos[1];
+ extern /* Subroutine */ int dprcn3_(integer *, integer *, char *, integer
+ *, char *, char *, char *, char *, integer *, integer *,
+ doublereal *, integer *, integer *);
+ extern logical lderes_(char *, char *, integer *, integer *, doublereal *,
+ doublereal *, integer *);
+ extern /* Subroutine */ int cdtrmm_(integer *, char *, char *, char *,
+ char *, integer *, integer *, doublereal *, doublereal *, integer
+ *, doublereal *, integer *);
+ char tranas[1], transa[1];
+ extern /* Subroutine */ int cdtrsm_(integer *, char *, char *, char *,
+ char *, integer *, integer *, doublereal *, doublereal *, integer
+ *, doublereal *, integer *);
+ doublereal errmax;
+
+ /* Fortran I/O blocks */
+ static cilist io___235 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___238 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___240 = { 0, 0, 0, fmt_10000, 0 };
+ static cilist io___241 = { 0, 0, 0, fmt_10001, 0 };
+ static cilist io___242 = { 0, 0, 0, fmt_10002, 0 };
+ static cilist io___243 = { 0, 0, 0, fmt_10003, 0 };
+ static cilist io___244 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* 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. */
+
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --g;
+ --ct;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+
+ 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);
+
+/* Generate the matrix B. */
+
+ dmake_("GE", " ", " ", &m, &n, &b[b_offset],
+ nmax, &bb[1], &ldb, &reset, &c_b104);
+
+ ++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)13, (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);
+ } 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)13, (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);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___235.ciunit = *nout;
+ s_wsfe(&io___235);
+ e_wsfe();
+ *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);
+ }
+ 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]) {
+ io___238.ciunit = *nout;
+ s_wsfe(&io___238);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* 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);
+ }
+ } 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);
+ } 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);
+ }
+ }
+ 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) {
+ io___240.ciunit = *nout;
+ s_wsfe(&io___240);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___241.ciunit = *nout;
+ s_wsfe(&io___241);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ } else {
+ if (*iorder == 0) {
+ io___242.ciunit = *nout;
+ s_wsfe(&io___242);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___243.ciunit = *nout;
+ s_wsfe(&io___243);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ }
+ goto L160;
+
+L150:
+ io___244.ciunit = *nout;
+ s_wsfe(&io___244);
+ do_fio(&c__1, sname, (ftnlen)13);
+ e_wsfe();
+ if (*trace) {
+ dprcn3_(ntra, &nc, sname, iorder, side, uplo, transa, diag, &m, &n, &
+ alpha, &lda, &ldb);
+ }
+
+L160:
+ return 0;
+
+/* L9995: */
+
+/* End of DCHK3. */
+
+} /* dchk3_ */
+
+
+/* Subroutine */ int dprcn3_(integer *nout, integer *nc, char *sname, integer
+ *iorder, char *side, char *uplo, char *transa, char *diag, integer *m,
+ integer *n, doublereal *alpha, integer *lda, integer *ldb)
+{
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
+ "a14,\002,\002,a14,\002,\002)";
+ static char fmt_9994[] = "(22x,2(a14,\002,\002),2(i3,\002,\002),f4.1,"
+ "\002, A,\002,i3,\002, B,\002,i3,\002).\002)";
+
+ /* Local variables */
+ char ca[14], cd[14], cs[14], cu[14], crc[14];
+
+ /* Fortran I/O blocks */
+ static cilist io___250 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___251 = { 0, 0, 0, fmt_9994, 0 };
+
+
+ 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);
+ }
+ io___250.ciunit = *nout;
+ s_wsfe(&io___250);
+ do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, crc, (ftnlen)14);
+ do_fio(&c__1, cs, (ftnlen)14);
+ do_fio(&c__1, cu, (ftnlen)14);
+ e_wsfe();
+ io___251.ciunit = *nout;
+ s_wsfe(&io___251);
+ do_fio(&c__1, ca, (ftnlen)14);
+ do_fio(&c__1, cd, (ftnlen)14);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
+ e_wsfe();
+ return 0;
+} /* dprcn3_ */
+
+
+/* Subroutine */ int dchk4_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nalf, doublereal *alf,
+ integer *nbet, doublereal *bet, integer *nmax, doublereal *a,
+ doublereal *aa, doublereal *as, doublereal *b, doublereal *bb,
+ doublereal *bs, doublereal *c__, doublereal *cc, doublereal *cs,
+ doublereal *ct, doublereal *g, integer *iorder)
+{
+ /* Initialized data */
+
+ static char icht[3] = "NTC";
+ static char ichu[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
+ "TAKEN ON VALID CALL *******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
+ "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
+ " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+ static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
+ "BER:\002)";
+
+ /* 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;
+ alist al__1;
+
+ /* Local variables */
+ integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa,
+ lda, lcc, ldc;
+ extern logical lde_(doublereal *, doublereal *, integer *);
+ doublereal als;
+ integer ict, icu;
+ doublereal err, beta;
+ integer ldas, ldcs;
+ logical same;
+ doublereal bets;
+ logical tran, null;
+ char uplo[1];
+ extern /* Subroutine */ int dmake_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ logical *, doublereal *);
+ doublereal alpha;
+ extern /* Subroutine */ int dmmch_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ logical *, integer *, logical *);
+ logical isame[13];
+ integer nargs;
+ logical reset;
+ char trans[1];
+ logical upper;
+ char uplos[1];
+ extern /* Subroutine */ int dprcn4_(integer *, integer *, char *, integer
+ *, char *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ extern logical lderes_(char *, char *, integer *, integer *, doublereal *,
+ doublereal *, integer *);
+ doublereal errmax;
+ extern /* Subroutine */ int cdsyrk_(integer *, char *, char *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *);
+ char transs[1];
+
+ /* Fortran I/O blocks */
+ static cilist io___288 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___291 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___297 = { 0, 0, 0, fmt_10000, 0 };
+ static cilist io___298 = { 0, 0, 0, fmt_10001, 0 };
+ static cilist io___299 = { 0, 0, 0, fmt_10002, 0 };
+ static cilist io___300 = { 0, 0, 0, fmt_10003, 0 };
+ static cilist io___301 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___302 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* 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. */
+
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+
+ 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)
+ ;
+
+ 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);
+
+ ++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);
+ }
+ 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);
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___288.ciunit = *nout;
+ s_wsfe(&io___288);
+ e_wsfe();
+ *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);
+ }
+ 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]) {
+ io___291.ciunit = *nout;
+ s_wsfe(&io___291);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* 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);
+ } 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);
+ }
+ 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) {
+ io___297.ciunit = *nout;
+ s_wsfe(&io___297);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___298.ciunit = *nout;
+ s_wsfe(&io___298);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ } else {
+ if (*iorder == 0) {
+ io___299.ciunit = *nout;
+ s_wsfe(&io___299);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___300.ciunit = *nout;
+ s_wsfe(&io___300);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ }
+ goto L130;
+
+L110:
+ if (n > 1) {
+ io___301.ciunit = *nout;
+ s_wsfe(&io___301);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L120:
+ io___302.ciunit = *nout;
+ s_wsfe(&io___302);
+ do_fio(&c__1, sname, (ftnlen)13);
+ e_wsfe();
+ dprcn4_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &
+ beta, &ldc);
+
+L130:
+ return 0;
+
+/* L9994: */
+
+/* End of DCHK4. */
+
+} /* dchk4_ */
+
+
+/* Subroutine */ int dprcn4_(integer *nout, integer *nc, char *sname, integer
+ *iorder, char *uplo, char *transa, integer *n, integer *k, doublereal
+ *alpha, integer *lda, doublereal *beta, integer *ldc)
+{
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002,"
+ "\002))";
+ static char fmt_9994[] = "(20x,2(i3,\002,\002),f4.1,\002, A,\002,i3"
+ ",\002,\002,f4.1,\002, C,\002,i3,\002).\002)";
+
+ /* Local variables */
+ char ca[14], cu[14], crc[14];
+
+ /* Fortran I/O blocks */
+ static cilist io___306 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___307 = { 0, 0, 0, fmt_9994, 0 };
+
+
+ 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);
+ }
+ io___306.ciunit = *nout;
+ s_wsfe(&io___306);
+ do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, crc, (ftnlen)14);
+ do_fio(&c__1, cu, (ftnlen)14);
+ do_fio(&c__1, ca, (ftnlen)14);
+ e_wsfe();
+ io___307.ciunit = *nout;
+ s_wsfe(&io___307);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
+ e_wsfe();
+ return 0;
+} /* dprcn4_ */
+
+
+/* Subroutine */ int dchk5_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nalf, doublereal *alf,
+ integer *nbet, doublereal *bet, integer *nmax, doublereal *ab,
+ doublereal *aa, doublereal *as, doublereal *bb, doublereal *bs,
+ doublereal *c__, doublereal *cc, doublereal *cs, doublereal *ct,
+ doublereal *g, doublereal *w, integer *iorder)
+{
+ /* Initialized data */
+
+ static char icht[3] = "NTC";
+ static char ichu[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
+ "TAKEN ON VALID CALL *******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
+ "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
+ " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+ static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
+ "BER:\002)";
+
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8;
+ alist al__1;
+
+ /* Local variables */
+ integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa,
+ lbb, lda, lcc, ldb, ldc;
+ extern logical lde_(doublereal *, doublereal *, integer *);
+ doublereal als;
+ integer ict, icu;
+ doublereal err;
+ integer jjab;
+ doublereal beta;
+ integer ldas, ldbs, ldcs;
+ logical same;
+ doublereal bets;
+ logical tran, null;
+ char uplo[1];
+ extern /* Subroutine */ int dmake_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ logical *, doublereal *);
+ doublereal alpha;
+ extern /* Subroutine */ int dmmch_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ logical *, integer *, logical *);
+ logical isame[13];
+ integer nargs;
+ logical reset;
+ char trans[1];
+ logical upper;
+ char uplos[1];
+ extern /* Subroutine */ int dprcn5_(integer *, integer *, char *, integer
+ *, char *, char *, integer *, integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *);
+ extern logical lderes_(char *, char *, integer *, integer *, doublereal *,
+ doublereal *, integer *);
+ doublereal errmax;
+ char transs[1];
+ extern /* Subroutine */ int cdsyr2k_(integer *, char *, char *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___347 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___350 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___357 = { 0, 0, 0, fmt_10000, 0 };
+ static cilist io___358 = { 0, 0, 0, fmt_10001, 0 };
+ static cilist io___359 = { 0, 0, 0, fmt_10002, 0 };
+ static cilist io___360 = { 0, 0, 0, fmt_10003, 0 };
+ static cilist io___361 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___362 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* 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. */
+
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --w;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ --as;
+ --aa;
+ --ab;
+
+ /* Function Body */
+
+ 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);
+ } else {
+ dmake_("GE", " ", " ", &ma, &na, &ab[1], nmax, &aa[1], &
+ lda, &reset, &c_b104);
+ }
+
+/* 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);
+ } else {
+ dmake_("GE", " ", " ", &ma, &na, &ab[k * *nmax + 1], nmax,
+ &bb[1], &ldb, &reset, &c_b104);
+ }
+
+ 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);
+
+ ++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)
+ ;
+ }
+ 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);
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___347.ciunit = *nout;
+ s_wsfe(&io___347);
+ e_wsfe();
+ *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);
+ }
+ 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]) {
+ io___350.ciunit = *nout;
+ s_wsfe(&io___350);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* 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);
+ } 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);
+ }
+ 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) {
+ io___357.ciunit = *nout;
+ s_wsfe(&io___357);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___358.ciunit = *nout;
+ s_wsfe(&io___358);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ } else {
+ if (*iorder == 0) {
+ io___359.ciunit = *nout;
+ s_wsfe(&io___359);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___360.ciunit = *nout;
+ s_wsfe(&io___360);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ }
+ goto L160;
+
+L140:
+ if (n > 1) {
+ io___361.ciunit = *nout;
+ s_wsfe(&io___361);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L150:
+ io___362.ciunit = *nout;
+ s_wsfe(&io___362);
+ do_fio(&c__1, sname, (ftnlen)13);
+ e_wsfe();
+ dprcn5_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &ldb,
+ &beta, &ldc);
+
+L160:
+ return 0;
+
+/* L9994: */
+
+/* End of DCHK5. */
+
+} /* dchk5_ */
+
+
+/* Subroutine */ int dprcn5_(integer *nout, integer *nc, char *sname, integer
+ *iorder, char *uplo, char *transa, integer *n, integer *k, doublereal
+ *alpha, integer *lda, integer *ldb, doublereal *beta, integer *ldc)
+{
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002,"
+ "\002))";
+ static char fmt_9994[] = "(20x,2(i3,\002,\002),f4.1,\002, A,\002,i3,\002"
+ ", B\002,i3,\002,\002,f4.1,\002, C,\002,i3,\002).\002)";
+
+ /* Local variables */
+ char ca[14], cu[14], crc[14];
+
+ /* Fortran I/O blocks */
+ static cilist io___366 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___367 = { 0, 0, 0, fmt_9994, 0 };
+
+
+ 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);
+ }
+ io___366.ciunit = *nout;
+ s_wsfe(&io___366);
+ do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, crc, (ftnlen)14);
+ do_fio(&c__1, cu, (ftnlen)14);
+ do_fio(&c__1, ca, (ftnlen)14);
+ e_wsfe();
+ io___367.ciunit = *nout;
+ s_wsfe(&io___367);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
+ e_wsfe();
+ return 0;
+} /* dprcn5_ */
+
+
+/* Subroutine */ int dmake_(char *type__, char *uplo, char *diag, integer *m,
+ integer *n, doublereal *a, integer *nmax, doublereal *aa, integer *
+ lda, logical *reset, doublereal *transl)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+ logical gen, tri, sym;
+ extern doublereal dbeg_(logical *);
+ integer ibeg, iend;
+ logical unit, lower, upper;
+
+
+/* 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. */
+
+ /* Parameter adjustments */
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ 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_(char *transa, char *transb, integer *m, integer *
+ n, integer *kk, doublereal *alpha, doublereal *a, integer *lda,
+ doublereal *b, integer *ldb, doublereal *beta, doublereal *c__,
+ integer *ldc, doublereal *ct, doublereal *g, doublereal *cc, integer *
+ ldcc, doublereal *eps, doublereal *err, logical *fatal, integer *nout,
+ logical *mv)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS"
+ " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 EX"
+ "PECTED RESULT COMPU\002,\002TED RESULT\002)";
+ static char fmt_9998[] = "(1x,i7,2g18.6)";
+ static char fmt_9997[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+
+ /* 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;
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal erri;
+ logical trana, tranb;
+
+ /* Fortran I/O blocks */
+ static cilist io___384 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___385 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___386 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___387 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* 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;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --ct;
+ --g;
+ cc_dim1 = *ldcc;
+ cc_offset = 1 + cc_dim1;
+ 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_;
+ io___384.ciunit = *nout;
+ s_wsfe(&io___384);
+ e_wsfe();
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*mv) {
+ io___385.ciunit = *nout;
+ s_wsfe(&io___385);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ct[i__], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ } else {
+ io___386.ciunit = *nout;
+ s_wsfe(&io___386);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&ct[i__], (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+/* L140: */
+ }
+ if (*n > 1) {
+ io___387.ciunit = *nout;
+ s_wsfe(&io___387);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L150:
+ return 0;
+
+
+/* End of DMMCH. */
+
+} /* dmmch_ */
+
+logical lde_(doublereal *ri, doublereal *rj, integer *lr)
+{
+ /* System generated locals */
+ integer i__1;
+ logical ret_val;
+
+ /* Local variables */
+ 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__) {
+ if (ri[i__] != rj[i__]) {
+ goto L20;
+ }
+/* L10: */
+ }
+ ret_val = TRUE_;
+ goto L30;
+L20:
+ ret_val = FALSE_;
+L30:
+ return ret_val;
+
+/* End of LDE. */
+
+} /* lde_ */
+
+logical lderes_(char *type__, char *uplo, integer *m, integer *n, doublereal *
+ aa, doublereal *as, integer *lda)
+{
+ /* System generated locals */
+ integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2;
+ logical ret_val;
+
+ /* Local variables */
+ integer i__, j, ibeg, iend;
+ 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. */
+
+ /* Parameter adjustments */
+ as_dim1 = *lda;
+ as_offset = 1 + as_dim1;
+ as -= as_offset;
+ aa_dim1 = *lda;
+ aa_offset = 1 + aa_dim1;
+ 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: */
+ }
+ }
+
+/* L60: */
+ ret_val = TRUE_;
+ goto L80;
+L70:
+ ret_val = FALSE_;
+L80:
+ return ret_val;
+
+/* End of LDERES. */
+
+} /* lderes_ */
+
+doublereal dbeg_(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. */
+
+ 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_(doublereal *x, doublereal *y)
+{
+ /* System generated locals */
+ doublereal ret_val;
+
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+ ret_val = *x - *y;
+ return ret_val;
+
+/* End of DDIFF. */
+
+} /* ddiff_ */
+
+/* Subroutine */ int dchk6_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nalf, doublereal *alf,
+ integer *nbet, doublereal *bet, integer *nmax, doublereal *a,
+ doublereal *aa, doublereal *as, doublereal *b, doublereal *bb,
+ doublereal *bs, doublereal *c__, doublereal *cc, doublereal *cs,
+ doublereal *ct, doublereal *g, integer *iorder)
+{
+ /* Initialized data */
+
+ static char ich[3] = "NTC";
+ static char ishape[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
+ "TAKEN ON VALID CALL *******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
+ "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
+ " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
+ "BER:\002)";
+
+ /* 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;
+ alist al__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int cdgemmtr_(integer *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *);
+ integer i__, k, n, ia, ib, ma, mb, na, nb, nc, ik, in, is, ks, ns, ica,
+ icb, laa, lbb, lda, lcc, ldb, ldc;
+ extern logical lde_(doublereal *, doublereal *, integer *);
+ doublereal als, bls, err, beta;
+ integer ldas, ldbs, ldcs;
+ logical same, null;
+ char uplo[1];
+ extern /* Subroutine */ int dmake_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ logical *, doublereal *);
+ doublereal alpha;
+ logical isame[13], trana, tranb;
+ integer nargs;
+ logical reset;
+ char uplos[1];
+ extern /* Subroutine */ int dprcn8_(integer *, integer *, char *, integer
+ *, char *, char *, char *, integer *, integer *, doublereal *,
+ integer *, integer *, doublereal *, integer *), dmmtch_(char *, char *, char *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ logical *, integer *, logical *);
+ extern logical lderes_(char *, char *, integer *, integer *, doublereal *,
+ doublereal *, integer *);
+ char tranas[1], tranbs[1], transa[1], transb[1];
+ doublereal errmax;
+
+ /* Fortran I/O blocks */
+ static cilist io___441 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___444 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___446 = { 0, 0, 0, fmt_10000, 0 };
+ static cilist io___447 = { 0, 0, 0, fmt_10001, 0 };
+ static cilist io___448 = { 0, 0, 0, fmt_10002, 0 };
+ static cilist io___449 = { 0, 0, 0, fmt_10003, 0 };
+ static cilist io___450 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* Tests DGEMMTR. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 19-July-2023. */
+/* Martin Koehler, MPI Magdeburg */
+
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+
+ nargs = 13;
+ 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 (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 = 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)
+ ;
+
+ 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);
+
+ 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];
+ for (is = 1; is <= 2; ++is) {
+ *(unsigned char *)uplo = *(unsigned char *)&
+ ishape[is - 1];
+
+/* Generate the matrix C. */
+
+ dmake_("GE", uplo, " ", &n, &n, &c__[c_offset]
+ , nmax, &cc[1], &ldc, &reset, &c_b104);
+
+ ++nc;
+
+/* Save every datum before calling the */
+/* subroutine. */
+
+ *(unsigned char *)uplos = *(unsigned char *)
+ uplo;
+ *(unsigned char *)tranas = *(unsigned char *)
+ transa;
+ *(unsigned char *)tranbs = *(unsigned char *)
+ transb;
+ 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;
+ bls = beta;
+ i__5 = lcc;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ cs[i__] = cc[i__];
+/* L30: */
+ }
+ ldcs = ldc;
+
+/* Call the subroutine. */
+
+ if (*trace) {
+ dprcn8_(ntra, &nc, sname, iorder, uplo,
+ transa, transb, &n, &k, &alpha, &
+ lda, &ldb, &beta, &ldc);
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ cdgemmtr_(iorder, uplo, transa, transb, &n, &
+ k, &alpha, &aa[1], &lda, &bb[1], &ldb,
+ &beta, &cc[1], &ldc);
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_2.ok) {
+ io___441.ciunit = *nout;
+ s_wsfe(&io___441);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)uplo == *(
+ unsigned char *)uplos;
+ isame[1] = *(unsigned char *)transa == *(
+ unsigned char *)tranas;
+ isame[2] = *(unsigned char *)transb == *(
+ unsigned char *)tranbs;
+ 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", " ", &n, &n, &
+ cs[1], &cc[1], &ldc);
+ }
+ isame[12] = 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]) {
+ io___444.ciunit = *nout;
+ s_wsfe(&io___444);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+ if (! null) {
+
+/* Check the result. */
+
+ dmmtch_(uplo, transa, transb, &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;
+ }
+ }
+
+/* L45: */
+ }
+
+/* L50: */
+ }
+
+/* L60: */
+ }
+
+L70:
+ ;
+ }
+
+L80:
+ ;
+ }
+
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ if (*iorder == 0) {
+ io___446.ciunit = *nout;
+ s_wsfe(&io___446);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___447.ciunit = *nout;
+ s_wsfe(&io___447);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ } else {
+ if (*iorder == 0) {
+ io___448.ciunit = *nout;
+ s_wsfe(&io___448);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___449.ciunit = *nout;
+ s_wsfe(&io___449);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ }
+ goto L130;
+
+L120:
+ io___450.ciunit = *nout;
+ s_wsfe(&io___450);
+ do_fio(&c__1, sname, (ftnlen)13);
+ e_wsfe();
+ dprcn8_(nout, &nc, sname, iorder, uplo, transa, transb, &n, &k, &alpha, &
+ lda, &ldb, &beta, &ldc);
+
+L130:
+ return 0;
+
+/* L9997: */
+/* L9995: */
+
+/* End of DCHK6 */
+
+} /* dchk6_ */
+
+/* Subroutine */ int dprcn8_(integer *nout, integer *nc, char *sname, integer
+ *iorder, char *uplo, char *transa, char *transb, integer *n, integer *
+ k, doublereal *alpha, integer *lda, integer *ldb, doublereal *beta,
+ integer *ldc)
+{
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
+ "a14,\002,\002,a14,\002,\002,a14,\002,\002)";
+ static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 \002,f4.1,\002 , A"
+ ",\002,i3,\002, B,\002,i3,\002, \002,f4.1,\002 , C,\002,i3,\002)"
+ ".\002)";
+
+ /* Local variables */
+ char crc[14], cta[14], ctb[14], cuplo[14];
+
+ /* Fortran I/O blocks */
+ static cilist io___455 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___456 = { 0, 0, 0, fmt_9994, 0 };
+
+
+ if (*(unsigned char *)uplo == 'U') {
+ s_copy(cuplo, "CblasUpper", (ftnlen)14, (ftnlen)10);
+ } else {
+ s_copy(cuplo, "CblasLower", (ftnlen)14, (ftnlen)10);
+ }
+ 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);
+ }
+ io___455.ciunit = *nout;
+ s_wsfe(&io___455);
+ do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, crc, (ftnlen)14);
+ do_fio(&c__1, cuplo, (ftnlen)14);
+ do_fio(&c__1, cta, (ftnlen)14);
+ do_fio(&c__1, ctb, (ftnlen)14);
+ e_wsfe();
+ io___456.ciunit = *nout;
+ s_wsfe(&io___456);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
+ e_wsfe();
+ return 0;
+} /* dprcn8_ */
+
+/* Subroutine */ int dmmtch_(char *uplo, char *transa, char *transb, integer *
+ n, integer *kk, doublereal *alpha, doublereal *a, integer *lda,
+ doublereal *b, integer *ldb, doublereal *beta, doublereal *c__,
+ integer *ldc, doublereal *ct, doublereal *g, doublereal *cc, integer *
+ ldcc, doublereal *eps, doublereal *err, logical *fatal, integer *nout,
+ logical *mv)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS"
+ " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 EX"
+ "PECTED RESULT COMPU\002,\002TED RESULT\002)";
+ static char fmt_9998[] = "(1x,i7,2g18.6)";
+ static char fmt_9997[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+
+ /* 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;
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal erri;
+ logical trana, tranb, upper;
+ integer istop, istart;
+
+ /* Fortran I/O blocks */
+ static cilist io___466 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___467 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___468 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___469 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* Checks the results of the computational tests. */
+
+/* Auxiliary routine for test program for Level 3 Blas. (DGEMMTR) */
+
+/* -- Written on 19-July-2023. */
+/* Martin Koehler, MPI Magdeburg */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --ct;
+ --g;
+ cc_dim1 = *ldcc;
+ cc_offset = 1 + cc_dim1;
+ cc -= cc_offset;
+
+ /* Function Body */
+ upper = *(unsigned char *)uplo == 'U';
+ 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. */
+
+ istart = 1;
+ istop = *n;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+ if (upper) {
+ istart = 1;
+ istop = j;
+ } else {
+ istart = j;
+ istop = *n;
+ }
+ i__2 = istop;
+ for (i__ = istart; 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 = istop;
+ for (i__ = istart; 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 = istop;
+ for (i__ = istart; 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 = istop;
+ for (i__ = istart; 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 = istop;
+ for (i__ = istart; 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 = istop;
+ for (i__ = istart; 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 = istop;
+ for (i__ = istart; 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_;
+ io___466.ciunit = *nout;
+ s_wsfe(&io___466);
+ e_wsfe();
+ i__1 = istop;
+ for (i__ = istart; i__ <= i__1; ++i__) {
+ if (*mv) {
+ io___467.ciunit = *nout;
+ s_wsfe(&io___467);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ct[i__], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ } else {
+ io___468.ciunit = *nout;
+ s_wsfe(&io___468);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&ct[i__], (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+/* L140: */
+ }
+ if (*n > 1) {
+ io___469.ciunit = *nout;
+ s_wsfe(&io___469);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L150:
+ return 0;
+
+
+/* End of DMMTCH */
+
+} /* dmmtch_ */
+
+/* Main program alias */ int dblat3_ () { MAIN__ (); return 0; }
diff --git a/ctest/c_sblat3c.c b/ctest/c_sblat3c.c
index 447b23014f..31241f389c 100644
--- a/ctest/c_sblat3c.c
+++ b/ctest/c_sblat3c.c
@@ -10,25 +10,7 @@
#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
+#include "common.h"
typedef blasint integer;
@@ -509,3 +491,4390 @@ static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integ
+/* -- translated by f2c (version 20200916).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+
+
+/* Common Block Declarations */
+
+union {
+ struct {
+ integer infot, noutc;
+ logical ok;
+ } _1;
+ struct {
+ integer infot, noutc;
+ logical ok, lerr;
+ } _2;
+} infoc_;
+
+#define infoc_1 (infoc_._1)
+#define infoc_2 (infoc_._2)
+
+struct {
+ char srnamt[13];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__9 = 9;
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__8 = 8;
+static integer c__4 = 4;
+static integer c__65 = 65;
+static integer c__7 = 7;
+static real c_b89 = 1.f;
+static real c_b103 = 0.f;
+static integer c__6 = 6;
+static logical c_true = TRUE_;
+static integer c__0 = 0;
+static logical c_false = FALSE_;
+
+/* Main program */ int main(void)
+{
+ /* Initialized data */
+
+ static char snames[13*7] = "cblas_sgemm " "cblas_ssymm " "cblas_strmm "
+ "cblas_strsm " "cblas_ssyrk " "cblas_ssyr2k " "cblas_sgemmtr";
+
+ /* Format strings */
+ static char fmt_9997[] = "(\002 NUMBER OF VALUES OF \002,a,\002 IS LESS "
+ "THAN 1 OR GREATER \002,\002THAN \002,i2)";
+ static char fmt_9996[] = "(\002 VALUE OF N IS LESS THAN 0 OR GREATER THA"
+ "N \002,i2)";
+ static char fmt_9995[] = "(\002 TESTS OF THE REAL LEVEL 3 BL"
+ "AS\002,//\002 THE F\002,\002OLLOWING PARAMETER VALUES WILL BE US"
+ "ED:\002)";
+ static char fmt_9994[] = "(\002 FOR N \002,9i6)";
+ static char fmt_9993[] = "(\002 FOR ALPHA \002,7f6.1)";
+ static char fmt_9992[] = "(\002 FOR BETA \002,7f6.1)";
+ static char fmt_9984[] = "(\002 ERROR-CALL MYEXITS WILL NOT BE TESTED"
+ "\002)";
+ static char fmt_9999[] = "(\002 ROUTINES PASS COMPUTATIONAL TESTS IF TES"
+ "T RATIO IS LES\002,\002S THAN\002,f8.2)";
+ static char fmt_10002[] = "(\002 COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS"
+ " ARE TESTED\002)";
+ static char fmt_10001[] = "(\002 ROW-MAJOR DATA LAYOUT IS TESTED\002)";
+ static char fmt_10000[] = "(\002 COLUMN-MAJOR DATA LAYOUT IS TESTED\002)";
+ static char fmt_9988[] = "(a13,l2)";
+ static char fmt_9990[] = "(\002 SUBPROGRAM NAME \002,a13,\002 NOT RECOGN"
+ "IZED\002,/\002 ******* \002,\002TESTS ABANDONED *******\002)";
+ static char fmt_9998[] = "(\002 RELATIVE MACHINE PRECISION IS TAKEN TO"
+ " BE\002,1p,e9.1)";
+ static char fmt_9989[] = "(\002 ERROR IN SMMCH - IN-LINE DOT PRODUCTS A"
+ "RE BEING EVALU\002,\002ATED WRONGLY.\002,/\002 SMMCH WAS CALLED "
+ "WITH TRANSA = \002,a1,\002 AND TRANSB = \002,a1,/\002 AND RETURN"
+ "ED SAME = \002,l1,\002 AND \002,\002ERR = \002,f12.3,\002.\002,"
+ "/\002 THIS MAY BE DUE TO FAULTS IN THE \002,\002ARITHMETIC OR TH"
+ "E COMPILER.\002,/\002 ******* TESTS ABANDONED \002,\002******"
+ "*\002)";
+ static char fmt_9987[] = "(1x,a13,\002 WAS NOT TESTED\002)";
+ static char fmt_9986[] = "(/\002 END OF TESTS\002)";
+ static char fmt_9985[] = "(/\002 ******* FATAL ERROR - TESTS ABANDONED *"
+ "******\002)";
+ static char fmt_9991[] = "(\002 AMEND DATA FILE OR INCREASE ARRAY SIZES "
+ "IN PROGRAM\002,/\002 ******* TESTS ABANDONED *******\002)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ real r__1;
+ olist o__1;
+ cllist cl__1;
+
+ /* Local variables */
+ real c__[4225] /* was [65][65] */, g[65];
+ integer i__, j, n;
+ real w[130], aa[4225], ab[8450] /* was [65][130] */, bb[4225], cc[
+ 4225], as[4225], bs[4225], cs[4225], ct[65], alf[7], bet[7];
+ extern logical lse_(real *, real *, integer *);
+ real eps, err;
+ integer nalf, idim[9];
+ logical same;
+ integer nbet, ntra;
+ logical rewi;
+ extern /* Subroutine */ int schk1_(char *, real *, real *, integer *,
+ integer *, logical *, logical *, logical *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, real *,
+ real *, real *, real *, real *, real *, real *, real *, real *,
+ real *, integer *), schk2_(char *, real *, real *,
+ integer *, integer *, logical *, logical *, logical *, integer *,
+ integer *, integer *, real *, integer *, real *, integer *, real *
+ , real *, real *, real *, real *, real *, real *, real *, real *,
+ real *, real *, integer *), schk3_(char *, real *, real *,
+ integer *, integer *, logical *, logical *, logical *, integer *,
+ integer *, integer *, real *, integer *, real *, real *, real *,
+ real *, real *, real *, real *, real *, real *, integer *)
+ , schk4_(char *, real *, real *, integer *, integer *, logical *,
+ logical *, logical *, integer *, integer *, integer *, real *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ real *, real *, real *, real *, real *, real *, real *, integer *), schk5_(char *, real *, real *, integer *, integer *,
+ logical *, logical *, logical *, integer *, integer *, integer *,
+ real *, integer *, real *, integer *, real *, real *, real *,
+ real *, real *, real *, real *, real *, real *, real *, real *,
+ integer *), schk6_(char *, real *, real *, integer *,
+ integer *, logical *, logical *, logical *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, real *,
+ real *, real *, real *, real *, real *, real *, real *, real *,
+ real *, integer *);
+ logical fatal;
+ extern real sdiff_(real *, real *);
+ logical trace;
+ integer nidim;
+ extern /* Subroutine */ int smmch_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *, real *, real *, real *, integer *, real *,
+ real *, logical *, integer *, logical *);
+ char snaps[32];
+ integer isnum;
+ logical ltest[7], sfatal, corder;
+ char snamet[13], transa[1], transb[1];
+ real thresh;
+ logical rorder;
+ integer layout;
+ logical ltestt, tsterr;
+ extern /* Subroutine */ int cs3chke_(char *);
+
+ /* Fortran I/O blocks */
+ static cilist io___2 = { 0, 5, 0, 0, 0 };
+ static cilist io___4 = { 0, 5, 0, 0, 0 };
+ static cilist io___7 = { 0, 5, 0, 0, 0 };
+ static cilist io___9 = { 0, 5, 0, 0, 0 };
+ static cilist io___11 = { 0, 5, 0, 0, 0 };
+ static cilist io___13 = { 0, 5, 0, 0, 0 };
+ static cilist io___15 = { 0, 5, 0, 0, 0 };
+ static cilist io___17 = { 0, 5, 0, 0, 0 };
+ static cilist io___19 = { 0, 6, 0, fmt_9997, 0 };
+ static cilist io___20 = { 0, 5, 0, 0, 0 };
+ static cilist io___23 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___24 = { 0, 5, 0, 0, 0 };
+ static cilist io___26 = { 0, 6, 0, fmt_9997, 0 };
+ static cilist io___27 = { 0, 5, 0, 0, 0 };
+ static cilist io___29 = { 0, 5, 0, 0, 0 };
+ static cilist io___31 = { 0, 6, 0, fmt_9997, 0 };
+ static cilist io___32 = { 0, 5, 0, 0, 0 };
+ static cilist io___34 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___35 = { 0, 6, 0, fmt_9994, 0 };
+ static cilist io___36 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___37 = { 0, 6, 0, fmt_9992, 0 };
+ static cilist io___38 = { 0, 6, 0, 0, 0 };
+ static cilist io___39 = { 0, 6, 0, fmt_9984, 0 };
+ static cilist io___40 = { 0, 6, 0, 0, 0 };
+ static cilist io___41 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 6, 0, 0, 0 };
+ static cilist io___45 = { 0, 6, 0, fmt_10002, 0 };
+ static cilist io___46 = { 0, 6, 0, fmt_10001, 0 };
+ static cilist io___47 = { 0, 6, 0, fmt_10000, 0 };
+ static cilist io___48 = { 0, 6, 0, 0, 0 };
+ static cilist io___50 = { 0, 5, 1, fmt_9988, 0 };
+ static cilist io___53 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___55 = { 0, 6, 0, fmt_9998, 0 };
+ static cilist io___68 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___69 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___70 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___71 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___73 = { 0, 6, 0, 0, 0 };
+ static cilist io___74 = { 0, 6, 0, fmt_9987, 0 };
+ static cilist io___75 = { 0, 6, 0, 0, 0 };
+ static cilist io___82 = { 0, 6, 0, fmt_9986, 0 };
+ static cilist io___83 = { 0, 6, 0, fmt_9985, 0 };
+ static cilist io___84 = { 0, 6, 0, fmt_9991, 0 };
+
+
+
+/* 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 ( A13, 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 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 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. */
+/* cblas_sgemmtr 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 summary output file and open file. */
+
+ s_rsle(&io___2);
+ do_lio(&c__9, &c__1, snaps, (ftnlen)32);
+ e_rsle();
+ s_rsle(&io___4);
+ do_lio(&c__3, &c__1, (char *)&ntra, (ftnlen)sizeof(integer));
+ e_rsle();
+ trace = ntra >= 0;
+ if (trace) {
+/* OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' ) */
+ 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. */
+ s_rsle(&io___7);
+ do_lio(&c__8, &c__1, (char *)&rewi, (ftnlen)sizeof(logical));
+ e_rsle();
+ rewi = rewi && trace;
+/* Read the flag that directs stopping on any failure. */
+ s_rsle(&io___9);
+ do_lio(&c__8, &c__1, (char *)&sfatal, (ftnlen)sizeof(logical));
+ e_rsle();
+/* Read the flag that indicates whether error exits are to be tested. */
+ s_rsle(&io___11);
+ do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
+ e_rsle();
+/* Read the flag that indicates whether row-major data layout to be tested. */
+ s_rsle(&io___13);
+ do_lio(&c__3, &c__1, (char *)&layout, (ftnlen)sizeof(integer));
+ e_rsle();
+/* Read the threshold value of the test ratio */
+ s_rsle(&io___15);
+ do_lio(&c__4, &c__1, (char *)&thresh, (ftnlen)sizeof(real));
+ e_rsle();
+
+/* Read and check the parameter values for the tests. */
+
+/* Values of N */
+ s_rsle(&io___17);
+ do_lio(&c__3, &c__1, (char *)&nidim, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nidim < 1 || nidim > 9) {
+ s_wsfe(&io___19);
+ do_fio(&c__1, "N", (ftnlen)1);
+ do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+ s_rsle(&io___20);
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) {
+ s_wsfe(&io___23);
+ do_fio(&c__1, (char *)&c__65, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+/* L10: */
+ }
+/* Values of ALPHA */
+ s_rsle(&io___24);
+ do_lio(&c__3, &c__1, (char *)&nalf, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nalf < 1 || nalf > 7) {
+ s_wsfe(&io___26);
+ do_fio(&c__1, "ALPHA", (ftnlen)5);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+ s_rsle(&io___27);
+ i__1 = nalf;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__4, &c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(real));
+ }
+ e_rsle();
+/* Values of BETA */
+ s_rsle(&io___29);
+ do_lio(&c__3, &c__1, (char *)&nbet, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nbet < 1 || nbet > 7) {
+ s_wsfe(&io___31);
+ do_fio(&c__1, "BETA", (ftnlen)4);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+ s_rsle(&io___32);
+ i__1 = nbet;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__4, &c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(real));
+ }
+ e_rsle();
+
+/* Report values of parameters. */
+
+ s_wsfe(&io___34);
+ e_wsfe();
+ s_wsfe(&io___35);
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ s_wsfe(&io___36);
+ i__1 = nalf;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(real));
+ }
+ e_wsfe();
+ s_wsfe(&io___37);
+ i__1 = nbet;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(real));
+ }
+ e_wsfe();
+ if (! tsterr) {
+ s_wsle(&io___38);
+ e_wsle();
+ s_wsfe(&io___39);
+ e_wsfe();
+ }
+ s_wsle(&io___40);
+ e_wsle();
+ s_wsfe(&io___41);
+ do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(real));
+ e_wsfe();
+ s_wsle(&io___42);
+ e_wsle();
+ rorder = FALSE_;
+ corder = FALSE_;
+ if (layout == 2) {
+ rorder = TRUE_;
+ corder = TRUE_;
+ s_wsfe(&io___45);
+ e_wsfe();
+ } else if (layout == 1) {
+ rorder = TRUE_;
+ s_wsfe(&io___46);
+ e_wsfe();
+ } else if (layout == 0) {
+ corder = TRUE_;
+ s_wsfe(&io___47);
+ e_wsfe();
+ }
+ s_wsle(&io___48);
+ e_wsle();
+
+/* Read names of subroutines and flags which indicate */
+/* whether they are to be tested. */
+
+ for (i__ = 1; i__ <= 7; ++i__) {
+ ltest[i__ - 1] = FALSE_;
+/* L20: */
+ }
+L30:
+ i__1 = s_rsfe(&io___50);
+ if (i__1 != 0) {
+ goto L60;
+ }
+ i__1 = do_fio(&c__1, snamet, (ftnlen)13);
+ if (i__1 != 0) {
+ goto L60;
+ }
+ i__1 = do_fio(&c__1, (char *)<estt, (ftnlen)sizeof(logical));
+ if (i__1 != 0) {
+ goto L60;
+ }
+ i__1 = e_rsfe();
+ if (i__1 != 0) {
+ goto L60;
+ }
+ for (i__ = 1; i__ <= 7; ++i__) {
+ if (s_cmp(snamet, snames + (i__ - 1) * 13, (ftnlen)13, (ftnlen)13) ==
+ 0) {
+ goto L50;
+ }
+/* L40: */
+ }
+ s_wsfe(&io___53);
+ do_fio(&c__1, snamet, (ftnlen)13);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+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_b89) == 0.f) {
+ goto L80;
+ }
+ eps *= .5f;
+ goto L70;
+L80:
+ eps += eps;
+ s_wsfe(&io___55);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real));
+ e_wsfe();
+
+/* 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] = 0.f;
+/* 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);
+ same = lse_(cc, ct, &n);
+ if (! same || err != 0.f) {
+ s_wsfe(&io___68);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+ *(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);
+ same = lse_(cc, ct, &n);
+ if (! same || err != 0.f) {
+ s_wsfe(&io___69);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+ 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);
+ same = lse_(cc, ct, &n);
+ if (! same || err != 0.f) {
+ s_wsfe(&io___70);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+ *(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);
+ same = lse_(cc, ct, &n);
+ if (! same || err != 0.f) {
+ s_wsfe(&io___71);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+/* Test each subroutine in turn. */
+
+ for (isnum = 1; isnum <= 7; ++isnum) {
+ s_wsle(&io___73);
+ e_wsle();
+ if (! ltest[isnum - 1]) {
+/* Subprogram is not to be tested. */
+ s_wsfe(&io___74);
+ do_fio(&c__1, snames + (isnum - 1) * 13, (ftnlen)13);
+ e_wsfe();
+ } else {
+ s_copy(srnamc_1.srnamt, snames + (isnum - 1) * 13, (ftnlen)13, (
+ ftnlen)13);
+/* Test error exits. */
+ if (tsterr) {
+ cs3chke_(snames + (isnum - 1) * 13);
+ s_wsle(&io___75);
+ e_wsle();
+ }
+/* 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 L160;
+ case 4: goto L160;
+ case 5: goto L170;
+ case 6: goto L180;
+ case 7: goto L185;
+ }
+/* Test SGEMM, 01. */
+L140:
+ if (corder) {
+ schk1_(snames + (isnum - 1) * 13, &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) {
+ schk1_(snames + (isnum - 1) * 13, &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 SSYMM, 02. */
+L150:
+ if (corder) {
+ schk2_(snames + (isnum - 1) * 13, &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) {
+ schk2_(snames + (isnum - 1) * 13, &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 STRMM, 03, STRSM, 04. */
+L160:
+ if (corder) {
+ schk3_(snames + (isnum - 1) * 13, &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) {
+ schk3_(snames + (isnum - 1) * 13, &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 SSYRK, 05. */
+L170:
+ if (corder) {
+ schk4_(snames + (isnum - 1) * 13, &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) {
+ schk4_(snames + (isnum - 1) * 13, &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 SSYR2K, 06. */
+L180:
+ if (corder) {
+ schk5_(snames + (isnum - 1) * 13, &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) {
+ schk5_(snames + (isnum - 1) * 13, &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;
+/* Test SGEMMTR, 07. */
+L185:
+ if (corder) {
+ schk6_(snames + (isnum - 1) * 13, &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) {
+ schk6_(snames + (isnum - 1) * 13, &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: */
+ }
+ s_wsfe(&io___82);
+ e_wsfe();
+ goto L230;
+
+L210:
+ s_wsfe(&io___83);
+ e_wsfe();
+ goto L230;
+
+L220:
+ s_wsfe(&io___84);
+ e_wsfe();
+
+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);
+
+
+/* End of SBLAT3. */
+
+ return 0;
+} /* MAIN__ */
+
+/* Subroutine */ int schk1_(char *sname, real *eps, real *thresh, integer *
+ nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
+ integer *nidim, integer *idim, integer *nalf, real *alf, integer *
+ nbet, real *bet, integer *nmax, real *a, real *aa, real *as, real *b,
+ real *bb, real *bs, real *c__, real *cc, real *cs, real *ct, real *g,
+ integer *iorder)
+{
+ /* Initialized data */
+
+ static char ich[3] = "NTC";
+
+ /* Format strings */
+ static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
+ "TAKEN ON VALID CALL *******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
+ "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
+ " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
+ "BER:\002)";
+
+ /* 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;
+ alist al__1;
+
+ /* Local variables */
+ integer i__, k, m, n, ia, ib, ma, mb, na, nb, nc, ik, im, in, ks, ms, ns,
+ ica, icb, laa, lbb, lda, lcc, ldb, ldc;
+ real als, bls;
+ extern logical lse_(real *, real *, integer *);
+ real err, beta;
+ integer ldas, ldbs, ldcs;
+ logical same, null;
+ real alpha;
+ logical isame[13];
+ extern /* Subroutine */ int smake_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *, logical *, real *
+ );
+ logical trana, tranb;
+ extern /* Subroutine */ int smmch_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *, real *, real *, real *, integer *, real *,
+ real *, logical *, integer *, logical *);
+ integer nargs;
+ logical reset;
+ extern /* Subroutine */ int sprcn1_(integer *, integer *, char *, integer
+ *, char *, char *, integer *, integer *, integer *, real *,
+ integer *, integer *, real *, integer *),
+ csgemm_(integer *, char *, char *, integer *, integer *, integer *
+ , real *, real *, integer *, real *, integer *, real *, real *,
+ integer *);
+ char tranas[1], tranbs[1], transa[1], transb[1];
+ real errmax;
+ extern logical lseres_(char *, char *, integer *, integer *, real *, real
+ *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___128 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___131 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___133 = { 0, 0, 0, fmt_10000, 0 };
+ static cilist io___134 = { 0, 0, 0, fmt_10001, 0 };
+ static cilist io___135 = { 0, 0, 0, fmt_10002, 0 };
+ static cilist io___136 = { 0, 0, 0, fmt_10003, 0 };
+ static cilist io___137 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* 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. */
+
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ 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. */
+
+ smake_("GE", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[
+ 1], &lda, &reset, &c_b103);
+
+ 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);
+
+ 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);
+
+ ++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);
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ csgemm_(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();
+ *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);
+ }
+ 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]) {
+ io___131.ciunit = *nout;
+ s_wsfe(&io___131);
+ i__7 = i__ + 1;
+ do_fio(&c__1, (char *)&i__7, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* 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);
+ 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) {
+ io___133.ciunit = *nout;
+ s_wsfe(&io___133);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___134.ciunit = *nout;
+ s_wsfe(&io___134);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ } else {
+ if (*iorder == 0) {
+ io___135.ciunit = *nout;
+ s_wsfe(&io___135);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___136.ciunit = *nout;
+ s_wsfe(&io___136);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ }
+ goto L130;
+
+L120:
+ io___137.ciunit = *nout;
+ s_wsfe(&io___137);
+ do_fio(&c__1, sname, (ftnlen)13);
+ e_wsfe();
+ sprcn1_(nout, &nc, sname, iorder, transa, transb, &m, &n, &k, &alpha, &
+ lda, &ldb, &beta, &ldc);
+
+L130:
+ return 0;
+
+/* L9995: */
+
+/* End of SCHK1. */
+
+} /* schk1_ */
+
+
+
+
+/* Subroutine */ int sprcn1_(integer *nout, integer *nc, char *sname, integer
+ *iorder, char *transa, char *transb, integer *m, integer *n, integer *
+ k, real *alpha, integer *lda, integer *ldb, real *beta, integer *ldc)
+{
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
+ "a14,\002,\002,a14,\002,\002)";
+ static char fmt_9994[] = "(20x,3(i3,\002,\002),f4.1,\002, A,\002,i3,\002"
+ ", B,\002,i3,\002,\002,f4.1,\002, \002,\002C,\002,i3,\002).\002)";
+
+ /* Local variables */
+ char crc[14], cta[14], ctb[14];
+
+ /* Fortran I/O blocks */
+ static cilist io___141 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___142 = { 0, 0, 0, fmt_9994, 0 };
+
+
+ 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);
+ }
+ io___141.ciunit = *nout;
+ s_wsfe(&io___141);
+ do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, crc, (ftnlen)14);
+ do_fio(&c__1, cta, (ftnlen)14);
+ do_fio(&c__1, ctb, (ftnlen)14);
+ e_wsfe();
+ io___142.ciunit = *nout;
+ s_wsfe(&io___142);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
+ e_wsfe();
+ return 0;
+} /* sprcn1_ */
+
+
+/* Subroutine */ int schk2_(char *sname, real *eps, real *thresh, integer *
+ nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
+ integer *nidim, integer *idim, integer *nalf, real *alf, integer *
+ nbet, real *bet, integer *nmax, real *a, real *aa, real *as, real *b,
+ real *bb, real *bs, real *c__, real *cc, real *cs, real *ct, real *g,
+ integer *iorder)
+{
+ /* Initialized data */
+
+ static char ichs[2] = "LR";
+ static char ichu[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
+ "TAKEN ON VALID CALL *******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
+ "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
+ " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
+ "BER:\002)";
+
+ /* 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;
+ alist al__1;
+
+ /* Local variables */
+ integer i__, m, n, ia, ib, na, nc, im, in, ms, ns, laa, lbb, lda, lcc,
+ ldb, ldc, ics;
+ real als, bls;
+ integer icu;
+ extern logical lse_(real *, real *, integer *);
+ real err, beta;
+ integer ldas, ldbs, ldcs;
+ logical same;
+ char side[1];
+ logical left, null;
+ char uplo[1];
+ real alpha;
+ logical isame[13];
+ extern /* Subroutine */ int smake_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *, logical *, real *
+ );
+ char sides[1];
+ extern /* Subroutine */ int smmch_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *, real *, real *, real *, integer *, real *,
+ real *, logical *, integer *, logical *);
+ integer nargs;
+ logical reset;
+ char uplos[1];
+ extern /* Subroutine */ int sprcn2_(integer *, integer *, char *, integer
+ *, char *, char *, integer *, integer *, real *, integer *,
+ integer *, real *, integer *);
+ real errmax;
+ extern logical lseres_(char *, char *, integer *, integer *, real *, real
+ *, integer *);
+ extern /* Subroutine */ int cssymm_(integer *, char *, char *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___180 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___183 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___185 = { 0, 0, 0, fmt_10000, 0 };
+ static cilist io___186 = { 0, 0, 0, fmt_10001, 0 };
+ static cilist io___187 = { 0, 0, 0, fmt_10002, 0 };
+ static cilist io___188 = { 0, 0, 0, fmt_10003, 0 };
+ static cilist io___189 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* 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. */
+
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+
+ 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. */
+
+ smake_("GE", " ", " ", &m, &n, &b[b_offset], nmax, &bb[1], &ldb, &
+ reset, &c_b103);
+
+ 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);
+
+ 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);
+
+ ++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)
+ ;
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ cssymm_(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) {
+ io___180.ciunit = *nout;
+ s_wsfe(&io___180);
+ e_wsfe();
+ *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);
+ }
+ 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]) {
+ io___183.ciunit = *nout;
+ s_wsfe(&io___183);
+ i__6 = i__ + 1;
+ do_fio(&c__1, (char *)&i__6, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* 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);
+ } 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);
+ }
+ 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) {
+ io___185.ciunit = *nout;
+ s_wsfe(&io___185);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___186.ciunit = *nout;
+ s_wsfe(&io___186);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ } else {
+ if (*iorder == 0) {
+ io___187.ciunit = *nout;
+ s_wsfe(&io___187);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___188.ciunit = *nout;
+ s_wsfe(&io___188);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ }
+ goto L120;
+
+L110:
+ io___189.ciunit = *nout;
+ s_wsfe(&io___189);
+ do_fio(&c__1, sname, (ftnlen)13);
+ e_wsfe();
+ sprcn2_(nout, &nc, sname, iorder, side, uplo, &m, &n, &alpha, &lda, &ldb,
+ &beta, &ldc);
+
+L120:
+ return 0;
+
+/* L9995: */
+
+/* End of SCHK2. */
+
+} /* schk2_ */
+
+
+/* Subroutine */ int sprcn2_(integer *nout, integer *nc, char *sname, integer
+ *iorder, char *side, char *uplo, integer *m, integer *n, real *alpha,
+ integer *lda, integer *ldb, real *beta, integer *ldc)
+{
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
+ "a14,\002,\002,a14,\002,\002)";
+ static char fmt_9994[] = "(20x,2(i3,\002,\002),f4.1,\002, A,\002,i3,\002"
+ ", B,\002,i3,\002,\002,f4.1,\002, \002,\002C,\002,i3,\002).\002)";
+
+ /* Local variables */
+ char cs[14], cu[14], crc[14];
+
+ /* Fortran I/O blocks */
+ static cilist io___193 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___194 = { 0, 0, 0, fmt_9994, 0 };
+
+
+ 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);
+ }
+ io___193.ciunit = *nout;
+ s_wsfe(&io___193);
+ do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, crc, (ftnlen)14);
+ do_fio(&c__1, cs, (ftnlen)14);
+ do_fio(&c__1, cu, (ftnlen)14);
+ e_wsfe();
+ io___194.ciunit = *nout;
+ s_wsfe(&io___194);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
+ e_wsfe();
+ return 0;
+} /* sprcn2_ */
+
+
+/* Subroutine */ int schk3_(char *sname, real *eps, real *thresh, integer *
+ nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
+ integer *nidim, integer *idim, integer *nalf, real *alf, integer *
+ nmax, real *a, real *aa, real *as, real *b, real *bb, real *bs, real *
+ ct, real *g, real *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";
+
+ /* Format strings */
+ static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
+ "TAKEN ON VALID CALL *******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
+ "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
+ " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
+ "BER:\002)";
+
+ /* 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;
+ alist al__1;
+
+ /* Local variables */
+ integer i__, j, m, n, ia, na, nc, im, in, ms, ns, laa, icd, lbb, lda, ldb,
+ ics;
+ real als;
+ integer ict, icu;
+ extern logical lse_(real *, real *, integer *);
+ real err;
+ char diag[1];
+ integer ldas, ldbs;
+ logical same;
+ char side[1];
+ logical left, null;
+ char uplo[1];
+ real alpha;
+ char diags[1];
+ logical isame[13];
+ extern /* Subroutine */ int smake_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *, logical *, real *
+ );
+ char sides[1];
+ extern /* Subroutine */ int smmch_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *, real *, real *, real *, integer *, real *,
+ real *, logical *, integer *, logical *);
+ integer nargs;
+ logical reset;
+ char uplos[1];
+ extern /* Subroutine */ int sprcn3_(integer *, integer *, char *, integer
+ *, char *, char *, char *, char *, integer *, integer *, real *,
+ integer *, integer *);
+ char tranas[1], transa[1];
+ real errmax;
+ extern logical lseres_(char *, char *, integer *, integer *, real *, real
+ *, integer *);
+ extern /* Subroutine */ int cstrmm_(integer *, char *, char *, char *,
+ char *, integer *, integer *, real *, real *, integer *, real *,
+ integer *), cstrsm_(integer *,
+ char *, char *, char *, char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___235 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___238 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___240 = { 0, 0, 0, fmt_10000, 0 };
+ static cilist io___241 = { 0, 0, 0, fmt_10001, 0 };
+ static cilist io___242 = { 0, 0, 0, fmt_10002, 0 };
+ static cilist io___243 = { 0, 0, 0, fmt_10003, 0 };
+ static cilist io___244 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* 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. */
+
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --g;
+ --ct;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+
+ nargs = 11;
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.f;
+/* 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] = 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) {
+ alpha = alf[ia];
+
+/* Generate the matrix A. */
+
+ smake_("TR", uplo, diag, &na, &na, &a[
+ a_offset], nmax, &aa[1], &lda, &reset,
+ &c_b103);
+
+/* Generate the matrix B. */
+
+ smake_("GE", " ", " ", &m, &n, &b[b_offset],
+ nmax, &bb[1], &ldb, &reset, &c_b103);
+
+ ++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)13, (ftnlen)1, (ftnlen)
+ 1, (ftnlen)1, (ftnlen)1);
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ cstrmm_(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) {
+ sprcn3_(ntra, &nc, sname, iorder,
+ side, uplo, transa, diag, &m,
+ &n, &alpha, &lda, &ldb, (
+ ftnlen)13, (ftnlen)1, (ftnlen)
+ 1, (ftnlen)1, (ftnlen)1);
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ cstrsm_(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) {
+ io___235.ciunit = *nout;
+ s_wsfe(&io___235);
+ e_wsfe();
+ *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);
+ }
+ 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]) {
+ io___238.ciunit = *nout;
+ s_wsfe(&io___238);
+ i__5 = i__ + 1;
+ do_fio(&c__1, (char *)&i__5, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* 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);
+ }
+ } 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);
+ } 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);
+ }
+ }
+ 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) {
+ io___240.ciunit = *nout;
+ s_wsfe(&io___240);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___241.ciunit = *nout;
+ s_wsfe(&io___241);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ } else {
+ if (*iorder == 0) {
+ io___242.ciunit = *nout;
+ s_wsfe(&io___242);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___243.ciunit = *nout;
+ s_wsfe(&io___243);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ }
+ goto L160;
+
+L150:
+ io___244.ciunit = *nout;
+ s_wsfe(&io___244);
+ do_fio(&c__1, sname, (ftnlen)13);
+ e_wsfe();
+ if (*trace) {
+ sprcn3_(ntra, &nc, sname, iorder, side, uplo, transa, diag, &m, &n, &
+ alpha, &lda, &ldb);
+ }
+
+L160:
+ return 0;
+
+/* L9995: */
+
+/* End of SCHK3. */
+
+} /* schk3_ */
+
+
+/* Subroutine */ int sprcn3_(integer *nout, integer *nc, char *sname, integer
+ *iorder, char *side, char *uplo, char *transa, char *diag, integer *m,
+ integer *n, real *alpha, integer *lda, integer *ldb)
+{
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
+ "a14,\002,\002,a14,\002,\002)";
+ static char fmt_9994[] = "(22x,2(a14,\002,\002),2(i3,\002,\002),f4.1,"
+ "\002, A,\002,i3,\002, B,\002,i3,\002).\002)";
+
+ /* Local variables */
+ char ca[14], cd[14], cs[14], cu[14], crc[14];
+
+ /* Fortran I/O blocks */
+ static cilist io___250 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___251 = { 0, 0, 0, fmt_9994, 0 };
+
+
+ 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);
+ }
+ io___250.ciunit = *nout;
+ s_wsfe(&io___250);
+ do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, crc, (ftnlen)14);
+ do_fio(&c__1, cs, (ftnlen)14);
+ do_fio(&c__1, cu, (ftnlen)14);
+ e_wsfe();
+ io___251.ciunit = *nout;
+ s_wsfe(&io___251);
+ do_fio(&c__1, ca, (ftnlen)14);
+ do_fio(&c__1, cd, (ftnlen)14);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
+ e_wsfe();
+ return 0;
+} /* sprcn3_ */
+
+
+/* Subroutine */ int schk4_(char *sname, real *eps, real *thresh, integer *
+ nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
+ integer *nidim, integer *idim, integer *nalf, real *alf, integer *
+ nbet, real *bet, integer *nmax, real *a, real *aa, real *as, real *b,
+ real *bb, real *bs, real *c__, real *cc, real *cs, real *ct, real *g,
+ integer *iorder)
+{
+ /* Initialized data */
+
+ static char icht[3] = "NTC";
+ static char ichu[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
+ "TAKEN ON VALID CALL *******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
+ "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
+ " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+ static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
+ "BER:\002)";
+
+ /* 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;
+ alist al__1;
+
+ /* Local variables */
+ integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa,
+ lda, lcc, ldc;
+ real als;
+ integer ict, icu;
+ extern logical lse_(real *, real *, integer *);
+ real err, beta;
+ integer ldas, ldcs;
+ logical same;
+ real bets;
+ logical tran, null;
+ char uplo[1];
+ real alpha;
+ logical isame[13];
+ extern /* Subroutine */ int smake_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *, logical *, real *
+ ), smmch_(char *, char *, integer *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+ , real *, real *, integer *, real *, real *, real *, integer *,
+ real *, real *, logical *, integer *, logical *);
+ integer nargs;
+ logical reset;
+ char trans[1];
+ logical upper;
+ char uplos[1];
+ extern /* Subroutine */ int sprcn4_(integer *, integer *, char *, integer
+ *, char *, char *, integer *, integer *, real *, integer *, real *
+ , integer *);
+ real errmax;
+ extern logical lseres_(char *, char *, integer *, integer *, real *, real
+ *, integer *);
+ char transs[1];
+ extern /* Subroutine */ int cssyrk_(integer *, char *, char *, integer *,
+ integer *, real *, real *, integer *, real *, real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___288 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___291 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___297 = { 0, 0, 0, fmt_10000, 0 };
+ static cilist io___298 = { 0, 0, 0, fmt_10001, 0 };
+ static cilist io___299 = { 0, 0, 0, fmt_10002, 0 };
+ static cilist io___300 = { 0, 0, 0, fmt_10003, 0 };
+ static cilist io___301 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___302 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* 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. */
+
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+
+ nargs = 10;
+ 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 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)
+ ;
+
+ 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);
+
+ ++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);
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ cssyrk_(iorder, uplo, trans, &n, &k, &alpha, &aa[
+ 1], &lda, &beta, &cc[1], &ldc);
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___288.ciunit = *nout;
+ s_wsfe(&io___288);
+ e_wsfe();
+ *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);
+ }
+ 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]) {
+ io___291.ciunit = *nout;
+ s_wsfe(&io___291);
+ i__6 = i__ + 1;
+ do_fio(&c__1, (char *)&i__6, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* 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);
+ } 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);
+ }
+ 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) {
+ io___297.ciunit = *nout;
+ s_wsfe(&io___297);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___298.ciunit = *nout;
+ s_wsfe(&io___298);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ } else {
+ if (*iorder == 0) {
+ io___299.ciunit = *nout;
+ s_wsfe(&io___299);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___300.ciunit = *nout;
+ s_wsfe(&io___300);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ }
+ goto L130;
+
+L110:
+ if (n > 1) {
+ io___301.ciunit = *nout;
+ s_wsfe(&io___301);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L120:
+ io___302.ciunit = *nout;
+ s_wsfe(&io___302);
+ do_fio(&c__1, sname, (ftnlen)13);
+ e_wsfe();
+ sprcn4_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &
+ beta, &ldc);
+
+L130:
+ return 0;
+
+/* L9994: */
+
+/* End of SCHK4. */
+
+} /* schk4_ */
+
+
+/* Subroutine */ int sprcn4_(integer *nout, integer *nc, char *sname, integer
+ *iorder, char *uplo, char *transa, integer *n, integer *k, real *
+ alpha, integer *lda, real *beta, integer *ldc)
+{
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002,"
+ "\002))";
+ static char fmt_9994[] = "(20x,2(i3,\002,\002),f4.1,\002, A,\002,i3"
+ ",\002,\002,f4.1,\002, C,\002,i3,\002).\002)";
+
+ /* Local variables */
+ char ca[14], cu[14], crc[14];
+
+ /* Fortran I/O blocks */
+ static cilist io___306 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___307 = { 0, 0, 0, fmt_9994, 0 };
+
+
+ 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);
+ }
+ io___306.ciunit = *nout;
+ s_wsfe(&io___306);
+ do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, crc, (ftnlen)14);
+ do_fio(&c__1, cu, (ftnlen)14);
+ do_fio(&c__1, ca, (ftnlen)14);
+ e_wsfe();
+ io___307.ciunit = *nout;
+ s_wsfe(&io___307);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
+ e_wsfe();
+ return 0;
+} /* sprcn4_ */
+
+
+/* Subroutine */ int schk5_(char *sname, real *eps, real *thresh, integer *
+ nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
+ integer *nidim, integer *idim, integer *nalf, real *alf, integer *
+ nbet, real *bet, integer *nmax, real *ab, real *aa, real *as, real *
+ bb, real *bs, real *c__, real *cc, real *cs, real *ct, real *g, real *
+ w, integer *iorder)
+{
+ /* Initialized data */
+
+ static char icht[3] = "NTC";
+ static char ichu[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
+ "TAKEN ON VALID CALL *******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
+ "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
+ " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+ static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
+ "BER:\002)";
+
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8;
+ alist al__1;
+
+ /* Local variables */
+ integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa,
+ lbb, lda, lcc, ldb, ldc;
+ real als;
+ integer ict, icu;
+ extern logical lse_(real *, real *, integer *);
+ real err;
+ integer jjab;
+ real beta;
+ integer ldas, ldbs, ldcs;
+ logical same;
+ real bets;
+ logical tran, null;
+ char uplo[1];
+ real alpha;
+ logical isame[13];
+ extern /* Subroutine */ int smake_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *, logical *, real *
+ ), smmch_(char *, char *, integer *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+ , real *, real *, integer *, real *, real *, real *, integer *,
+ real *, real *, logical *, integer *, logical *);
+ integer nargs;
+ logical reset;
+ char trans[1];
+ logical upper;
+ char uplos[1];
+ extern /* Subroutine */ int sprcn5_(integer *, integer *, char *, integer
+ *, char *, char *, integer *, integer *, real *, integer *,
+ integer *, real *, integer *);
+ real errmax;
+ extern logical lseres_(char *, char *, integer *, integer *, real *, real
+ *, integer *);
+ char transs[1];
+ extern /* Subroutine */ int cssyr2k_(integer *, char *, char *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___347 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___350 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___357 = { 0, 0, 0, fmt_10000, 0 };
+ static cilist io___358 = { 0, 0, 0, fmt_10001, 0 };
+ static cilist io___359 = { 0, 0, 0, fmt_10002, 0 };
+ static cilist io___360 = { 0, 0, 0, fmt_10003, 0 };
+ static cilist io___361 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___362 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* 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. */
+
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --w;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ --as;
+ --aa;
+ --ab;
+
+ /* Function Body */
+
+ 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;
+ 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);
+ } else {
+ smake_("GE", " ", " ", &ma, &na, &ab[1], nmax, &aa[1], &
+ lda, &reset, &c_b103);
+ }
+
+/* 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);
+ } else {
+ smake_("GE", " ", " ", &ma, &na, &ab[k * *nmax + 1], nmax,
+ &bb[1], &ldb, &reset, &c_b103);
+ }
+
+ 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);
+
+ ++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)
+ ;
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ cssyr2k_(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) {
+ io___347.ciunit = *nout;
+ s_wsfe(&io___347);
+ e_wsfe();
+ *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);
+ }
+ 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]) {
+ io___350.ciunit = *nout;
+ s_wsfe(&io___350);
+ i__6 = i__ + 1;
+ do_fio(&c__1, (char *)&i__6, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* 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);
+ } 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);
+ }
+ 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) {
+ io___357.ciunit = *nout;
+ s_wsfe(&io___357);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___358.ciunit = *nout;
+ s_wsfe(&io___358);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ } else {
+ if (*iorder == 0) {
+ io___359.ciunit = *nout;
+ s_wsfe(&io___359);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___360.ciunit = *nout;
+ s_wsfe(&io___360);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ }
+ goto L160;
+
+L140:
+ if (n > 1) {
+ io___361.ciunit = *nout;
+ s_wsfe(&io___361);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L150:
+ io___362.ciunit = *nout;
+ s_wsfe(&io___362);
+ do_fio(&c__1, sname, (ftnlen)13);
+ e_wsfe();
+ sprcn5_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &ldb,
+ &beta, &ldc);
+
+L160:
+ return 0;
+
+/* L9994: */
+
+/* End of SCHK5. */
+
+} /* schk5_ */
+
+
+/* Subroutine */ int sprcn5_(integer *nout, integer *nc, char *sname, integer
+ *iorder, char *uplo, char *transa, integer *n, integer *k, real *
+ alpha, integer *lda, integer *ldb, real *beta, integer *ldc)
+{
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002,"
+ "\002))";
+ static char fmt_9994[] = "(20x,2(i3,\002,\002),f4.1,\002, A,\002,i3,\002"
+ ", B\002,i3,\002,\002,f4.1,\002, C,\002,i3,\002).\002)";
+
+ /* Local variables */
+ char ca[14], cu[14], crc[14];
+
+ /* Fortran I/O blocks */
+ static cilist io___366 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___367 = { 0, 0, 0, fmt_9994, 0 };
+
+
+ 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);
+ }
+ io___366.ciunit = *nout;
+ s_wsfe(&io___366);
+ do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, crc, (ftnlen)14);
+ do_fio(&c__1, cu, (ftnlen)14);
+ do_fio(&c__1, ca, (ftnlen)14);
+ e_wsfe();
+ io___367.ciunit = *nout;
+ s_wsfe(&io___367);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
+ e_wsfe();
+ return 0;
+} /* sprcn5_ */
+
+
+/* Subroutine */ int smake_(char *type__, char *uplo, char *diag, integer *m,
+ integer *n, real *a, integer *nmax, real *aa, integer *lda, logical *
+ reset, real *transl)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+ logical gen, tri, sym;
+ integer ibeg, iend;
+ extern real sbeg_(logical *);
+ logical unit, lower, upper;
+
+
+/* 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. */
+
+ /* Parameter adjustments */
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ 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] = 0.f;
+ }
+ if (sym) {
+ a[j + i__ * a_dim1] = a[i__ + j * a_dim1];
+ } else if (tri) {
+ a[j + i__ * a_dim1] = 0.f;
+ }
+ }
+ }
+/* L10: */
+ }
+ if (tri) {
+ a[j + j * a_dim1] += 1.f;
+ }
+ if (unit) {
+ a[j + j * a_dim1] = 1.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__) {
+ 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] = -1e10f;
+/* 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] = -1e10f;
+/* 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] = -1e10f;
+/* L80: */
+ }
+/* L90: */
+ }
+ }
+ return 0;
+
+/* End of SMAKE. */
+
+} /* smake_ */
+
+/* Subroutine */ int smmch_(char *transa, char *transb, integer *m, integer *
+ n, integer *kk, real *alpha, real *a, integer *lda, real *b, integer *
+ ldb, real *beta, real *c__, integer *ldc, real *ct, real *g, real *cc,
+ integer *ldcc, real *eps, real *err, logical *fatal, integer *nout,
+ logical *mv)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS"
+ " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 EX"
+ "PECTED RESULT COMPU\002,\002TED RESULT\002)";
+ static char fmt_9998[] = "(1x,i7,2g18.6)";
+ static char fmt_9997[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+
+ /* 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;
+
+ /* Local variables */
+ integer i__, j, k;
+ real erri;
+ logical trana, tranb;
+
+ /* Fortran I/O blocks */
+ static cilist io___384 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___385 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___386 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___387 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* 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;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --ct;
+ --g;
+ cc_dim1 = *ldcc;
+ cc_offset = 1 + cc_dim1;
+ 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.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__) {
+ ct[i__] += a[i__ + k * a_dim1] * b[k + j * b_dim1];
+ g[i__] += (r__1 = a[i__ + k * a_dim1], abs(r__1)) * (r__2
+ = b[k + j * b_dim1], abs(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], abs(r__1)) * (r__2
+ = b[k + j * b_dim1], abs(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], abs(r__1)) * (r__2
+ = b[j + k * b_dim1], abs(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], abs(r__1)) * (r__2
+ = b[j + k * b_dim1], abs(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__] = abs(*alpha) * g[i__] + abs(*beta) * (r__1 = c__[i__ + j *
+ c_dim1], abs(r__1));
+/* L100: */
+ }
+
+/* Compute the error ratio for this result. */
+
+ *err = 0.f;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ erri = (r__1 = ct[i__] - cc[i__ + j * cc_dim1], abs(r__1)) / *eps;
+ if (g[i__] != 0.f) {
+ erri /= g[i__];
+ }
+ *err = f2cmax(*err,erri);
+ if (*err * sqrt(*eps) >= 1.f) {
+ goto L130;
+ }
+/* L110: */
+ }
+
+/* L120: */
+ }
+
+/* If the loop completes, all results are at least half accurate. */
+ goto L150;
+
+/* Report fatal error. */
+
+L130:
+ *fatal = TRUE_;
+ io___384.ciunit = *nout;
+ s_wsfe(&io___384);
+ e_wsfe();
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*mv) {
+ io___385.ciunit = *nout;
+ s_wsfe(&io___385);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ct[i__], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ } else {
+ io___386.ciunit = *nout;
+ s_wsfe(&io___386);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(real)
+ );
+ do_fio(&c__1, (char *)&ct[i__], (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+/* L140: */
+ }
+ if (*n > 1) {
+ io___387.ciunit = *nout;
+ s_wsfe(&io___387);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L150:
+ return 0;
+
+
+/* End of SMMCH. */
+
+} /* smmch_ */
+
+logical lse_(real *ri, real *rj, integer *lr)
+{
+ /* System generated locals */
+ integer i__1;
+ logical ret_val;
+
+ /* Local variables */
+ 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__) {
+ if (ri[i__] != rj[i__]) {
+ goto L20;
+ }
+/* L10: */
+ }
+ ret_val = TRUE_;
+ goto L30;
+L20:
+ ret_val = FALSE_;
+L30:
+ return ret_val;
+
+/* End of LSE. */
+
+} /* lse_ */
+
+logical lseres_(char *type__, char *uplo, integer *m, integer *n, real *aa,
+ real *as, integer *lda)
+{
+ /* System generated locals */
+ integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2;
+ logical ret_val;
+
+ /* Local variables */
+ integer i__, j, ibeg, iend;
+ 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. */
+
+ /* Parameter adjustments */
+ as_dim1 = *lda;
+ as_offset = 1 + as_dim1;
+ as -= as_offset;
+ aa_dim1 = *lda;
+ aa_offset = 1 + aa_dim1;
+ 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: */
+ }
+ }
+
+/* L60: */
+ ret_val = TRUE_;
+ goto L80;
+L70:
+ ret_val = FALSE_;
+L80:
+ return ret_val;
+
+/* End of LSERES. */
+
+} /* lseres_ */
+
+real sbeg_(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. */
+
+ 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.f;
+ return ret_val;
+
+/* End of SBEG. */
+
+} /* sbeg_ */
+
+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_ */
+
+/* Subroutine */ int schk6_(char *sname, real *eps, real *thresh, integer *
+ nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
+ integer *nidim, integer *idim, integer *nalf, real *alf, integer *
+ nbet, real *bet, integer *nmax, real *a, real *aa, real *as, real *b,
+ real *bb, real *bs, real *c__, real *cc, real *cs, real *ct, real *g,
+ integer *iorder)
+{
+ /* Initialized data */
+
+ static char ich[3] = "NTC";
+ static char ishape[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
+ "TAKEN ON VALID CALL *******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
+ "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
+ " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
+ "BER:\002)";
+
+ /* 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;
+ alist al__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int csgemmtr_(integer *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+ , real *, real *, integer *);
+ integer i__, k, n, ia, ib, ma, mb, na, nb, nc, ik, in, is, ks, ns, ica,
+ icb, laa, lbb, lda, lcc, ldb, ldc;
+ real als, bls;
+ extern logical lse_(real *, real *, integer *);
+ real err, beta;
+ integer ldas, ldbs, ldcs;
+ logical same, null;
+ char uplo[1];
+ real alpha;
+ logical isame[13];
+ extern /* Subroutine */ int smake_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *, logical *, real *
+ );
+ logical trana, tranb;
+ integer nargs;
+ logical reset;
+ char uplos[1];
+ extern /* Subroutine */ int sprcn8_(integer *, integer *, char *, integer
+ *, char *, char *, char *, integer *, integer *, real *, integer *
+ , integer *, real *, integer *);
+ char tranas[1], tranbs[1], transa[1], transb[1];
+ extern /* Subroutine */ int smmtch_(char *, char *, char *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *, real *, real *, real *, integer *, real *,
+ real *, logical *, integer *, logical *);
+ real errmax;
+ extern logical lseres_(char *, char *, integer *, integer *, real *, real
+ *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___441 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___444 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___446 = { 0, 0, 0, fmt_10000, 0 };
+ static cilist io___447 = { 0, 0, 0, fmt_10001, 0 };
+ static cilist io___448 = { 0, 0, 0, fmt_10002, 0 };
+ static cilist io___449 = { 0, 0, 0, fmt_10003, 0 };
+ static cilist io___450 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* Tests SGEMMTR. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 19-July-2023. */
+/* Martin Koehler, MPI Magdeburg */
+
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+
+ nargs = 13;
+ 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 L100;
+ }
+ lcc = ldc * n;
+ null = n <= 0;
+
+ i__2 = *nidim;
+ for (ik = 1; ik <= i__2; ++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 = 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)
+ ;
+
+ 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);
+
+ 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];
+ for (is = 1; is <= 2; ++is) {
+ *(unsigned char *)uplo = *(unsigned char *)&
+ ishape[is - 1];
+
+/* Generate the matrix C. */
+
+ smake_("GE", uplo, " ", &n, &n, &c__[c_offset]
+ , nmax, &cc[1], &ldc, &reset, &c_b103);
+
+ ++nc;
+
+/* Save every datum before calling the */
+/* subroutine. */
+
+ *(unsigned char *)uplos = *(unsigned char *)
+ uplo;
+ *(unsigned char *)tranas = *(unsigned char *)
+ transa;
+ *(unsigned char *)tranbs = *(unsigned char *)
+ transb;
+ 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;
+ bls = beta;
+ i__5 = lcc;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ cs[i__] = cc[i__];
+/* L30: */
+ }
+ ldcs = ldc;
+
+/* Call the subroutine. */
+
+ if (*trace) {
+ sprcn8_(ntra, &nc, sname, iorder, uplo,
+ transa, transb, &n, &k, &alpha, &
+ lda, &ldb, &beta, &ldc);
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ csgemmtr_(iorder, uplo, transa, transb, &n, &
+ k, &alpha, &aa[1], &lda, &bb[1], &ldb,
+ &beta, &cc[1], &ldc);
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_2.ok) {
+ io___441.ciunit = *nout;
+ s_wsfe(&io___441);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)uplo == *(
+ unsigned char *)uplos;
+ isame[1] = *(unsigned char *)transa == *(
+ unsigned char *)tranas;
+ isame[2] = *(unsigned char *)transb == *(
+ unsigned char *)tranbs;
+ 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", " ", &n, &n, &
+ cs[1], &cc[1], &ldc);
+ }
+ isame[12] = 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]) {
+ io___444.ciunit = *nout;
+ s_wsfe(&io___444);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+ if (! null) {
+
+/* Check the result. */
+
+ smmtch_(uplo, transa, transb, &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;
+ }
+ }
+
+/* L45: */
+ }
+
+/* L50: */
+ }
+
+/* L60: */
+ }
+
+L70:
+ ;
+ }
+
+L80:
+ ;
+ }
+
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ if (*iorder == 0) {
+ io___446.ciunit = *nout;
+ s_wsfe(&io___446);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___447.ciunit = *nout;
+ s_wsfe(&io___447);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ } else {
+ if (*iorder == 0) {
+ io___448.ciunit = *nout;
+ s_wsfe(&io___448);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___449.ciunit = *nout;
+ s_wsfe(&io___449);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ }
+ goto L130;
+
+L120:
+ io___450.ciunit = *nout;
+ s_wsfe(&io___450);
+ do_fio(&c__1, sname, (ftnlen)13);
+ e_wsfe();
+ sprcn8_(nout, &nc, sname, iorder, uplo, transa, transb, &n, &k, &alpha, &
+ lda, &ldb, &beta, &ldc);
+
+L130:
+ return 0;
+
+/* L9997: */
+/* L9995: */
+
+/* End of SCHK6 */
+
+} /* schk6_ */
+
+/* Subroutine */ int sprcn8_(integer *nout, integer *nc, char *sname, integer
+ *iorder, char *uplo, char *transa, char *transb, integer *n, integer *
+ k, real *alpha, integer *lda, integer *ldb, real *beta, integer *ldc)
+{
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
+ "a14,\002,\002,a14,\002,\002,a14,\002,\002)";
+ static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 \002,f4.1,\002 , A"
+ ",\002,i3,\002, B,\002,i3,\002, \002,f4.1,\002 , C,\002,i3,\002)"
+ ".\002)";
+
+ /* Local variables */
+ char crc[14], cta[14], ctb[14], cuplo[14];
+
+ /* Fortran I/O blocks */
+ static cilist io___455 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___456 = { 0, 0, 0, fmt_9994, 0 };
+
+
+ if (*(unsigned char *)uplo == 'U') {
+ s_copy(cuplo, "CblasUpper", (ftnlen)14, (ftnlen)10);
+ } else {
+ s_copy(cuplo, "CblasLower", (ftnlen)14, (ftnlen)10);
+ }
+ 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);
+ }
+ io___455.ciunit = *nout;
+ s_wsfe(&io___455);
+ do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, crc, (ftnlen)14);
+ do_fio(&c__1, cuplo, (ftnlen)14);
+ do_fio(&c__1, cta, (ftnlen)14);
+ do_fio(&c__1, ctb, (ftnlen)14);
+ e_wsfe();
+ io___456.ciunit = *nout;
+ s_wsfe(&io___456);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
+ e_wsfe();
+ return 0;
+} /* sprcn8_ */
+
+/* Subroutine */ int smmtch_(char *uplo, char *transa, char *transb, integer *
+ n, integer *kk, real *alpha, real *a, integer *lda, real *b, integer *
+ ldb, real *beta, real *c__, integer *ldc, real *ct, real *g, real *cc,
+ integer *ldcc, real *eps, real *err, logical *fatal, integer *nout,
+ logical *mv)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS"
+ " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 EX"
+ "PECTED RESULT COMPU\002,\002TED RESULT\002)";
+ static char fmt_9998[] = "(1x,i7,2g18.6)";
+ static char fmt_9997[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+
+ /* 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;
+
+ /* Local variables */
+ integer i__, j, k;
+ real erri;
+ logical trana, tranb, upper;
+ integer istop, istart;
+
+ /* Fortran I/O blocks */
+ static cilist io___466 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___467 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___468 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___469 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* Checks the results of the computational tests. */
+
+/* Auxiliary routine for test program for Level 3 Blas. (DGEMMTR) */
+
+/* -- Written on 19-July-2023. */
+/* Martin Koehler, MPI Magdeburg */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --ct;
+ --g;
+ cc_dim1 = *ldcc;
+ cc_offset = 1 + cc_dim1;
+ cc -= cc_offset;
+
+ /* Function Body */
+ upper = *(unsigned char *)uplo == 'U';
+ 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. */
+
+ istart = 1;
+ istop = *n;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+ if (upper) {
+ istart = 1;
+ istop = j;
+ } else {
+ istart = j;
+ istop = *n;
+ }
+ i__2 = istop;
+ for (i__ = istart; i__ <= i__2; ++i__) {
+ ct[i__] = 0.f;
+ g[i__] = 0.f;
+/* L10: */
+ }
+ if (! trana && ! tranb) {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = istop;
+ for (i__ = istart; 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], abs(r__1)) * (r__2
+ = b[k + j * b_dim1], abs(r__2));
+/* L20: */
+ }
+/* L30: */
+ }
+ } else if (trana && ! tranb) {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = istop;
+ for (i__ = istart; 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], abs(r__1)) * (r__2
+ = b[k + j * b_dim1], abs(r__2));
+/* L40: */
+ }
+/* L50: */
+ }
+ } else if (! trana && tranb) {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = istop;
+ for (i__ = istart; 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], abs(r__1)) * (r__2
+ = b[j + k * b_dim1], abs(r__2));
+/* L60: */
+ }
+/* L70: */
+ }
+ } else if (trana && tranb) {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = istop;
+ for (i__ = istart; 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], abs(r__1)) * (r__2
+ = b[j + k * b_dim1], abs(r__2));
+/* L80: */
+ }
+/* L90: */
+ }
+ }
+ i__2 = istop;
+ for (i__ = istart; i__ <= i__2; ++i__) {
+ ct[i__] = *alpha * ct[i__] + *beta * c__[i__ + j * c_dim1];
+ g[i__] = abs(*alpha) * g[i__] + abs(*beta) * (r__1 = c__[i__ + j *
+ c_dim1], abs(r__1));
+/* L100: */
+ }
+
+/* Compute the error ratio for this result. */
+
+ *err = 0.f;
+ i__2 = istop;
+ for (i__ = istart; i__ <= i__2; ++i__) {
+ erri = (r__1 = ct[i__] - cc[i__ + j * cc_dim1], abs(r__1)) / *eps;
+ if (g[i__] != 0.f) {
+ erri /= g[i__];
+ }
+ *err = f2cmax(*err,erri);
+ if (*err * sqrt(*eps) >= 1.f) {
+ goto L130;
+ }
+/* L110: */
+ }
+
+/* L120: */
+ }
+
+/* If the loop completes, all results are at least half accurate. */
+ goto L150;
+
+/* Report fatal error. */
+
+L130:
+ *fatal = TRUE_;
+ io___466.ciunit = *nout;
+ s_wsfe(&io___466);
+ e_wsfe();
+ i__1 = istop;
+ for (i__ = istart; i__ <= i__1; ++i__) {
+ if (*mv) {
+ io___467.ciunit = *nout;
+ s_wsfe(&io___467);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ct[i__], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ } else {
+ io___468.ciunit = *nout;
+ s_wsfe(&io___468);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(real)
+ );
+ do_fio(&c__1, (char *)&ct[i__], (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+/* L140: */
+ }
+ if (*n > 1) {
+ io___469.ciunit = *nout;
+ s_wsfe(&io___469);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L150:
+ return 0;
+
+
+/* End of SMMTCH */
+
+} /* smmtch_ */
+
+/* Main program alias */ int sblat3_ () { MAIN__ (); return 0; }
diff --git a/ctest/c_zblat3c.c b/ctest/c_zblat3c.c
index 447b23014f..58c8cb8c84 100644
--- a/ctest/c_zblat3c.c
+++ b/ctest/c_zblat3c.c
@@ -10,25 +10,7 @@
#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
+#include "common.h"
typedef blasint integer;
@@ -509,3 +491,5312 @@ static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integ
+/* -- translated by f2c (version 20200916).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, noutc;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[13];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__9 = 9;
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__8 = 8;
+static integer c__5 = 5;
+static integer c__65 = 65;
+static integer c__7 = 7;
+static integer c__2 = 2;
+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 */ int main(void)
+{
+ /* Initialized data */
+
+ static char snames[13*10] = "cblas_zgemm " "cblas_zhemm " "cblas_zsymm"
+ " " "cblas_ztrmm " "cblas_ztrsm " "cblas_zherk " "cblas_zsyrk"
+ " " "cblas_zher2k " "cblas_zsyr2k " "cblas_zgemmtr";
+
+ /* Format strings */
+ static char fmt_9997[] = "(\002 NUMBER OF VALUES OF \002,a,\002 IS LESS "
+ "THAN 1 OR GREATER \002,\002THAN \002,i2)";
+ static char fmt_9996[] = "(\002 VALUE OF N IS LESS THAN 0 OR GREATER THA"
+ "N \002,i2)";
+ static char fmt_9995[] = "(\002TESTS OF THE COMPLEX*16 LEVEL 3 BL"
+ "AS\002,//\002 THE F\002,\002OLLOWING PARAMETER VALUES WILL BE US"
+ "ED:\002)";
+ static char fmt_9994[] = "(\002 FOR N \002,9i6)";
+ static char fmt_9993[] = "(\002 FOR ALPHA \002,7(\002(\002,f4"
+ ".1,\002,\002,f4.1,\002) \002,:))";
+ static char fmt_9992[] = "(\002 FOR BETA \002,7(\002(\002,f4"
+ ".1,\002,\002,f4.1,\002) \002,:))";
+ static char fmt_9984[] = "(\002 ERROR-CALL MYEXITS WILL NOT BE TESTED"
+ "\002)";
+ static char fmt_9999[] = "(\002 ROUTINES PASS COMPUTATIONAL TESTS IF TES"
+ "T RATIO IS LES\002,\002S THAN\002,f8.2)";
+ static char fmt_10002[] = "(\002 COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS"
+ " ARE TESTED\002)";
+ static char fmt_10001[] = "(\002 ROW-MAJOR DATA LAYOUT IS TESTED\002)";
+ static char fmt_10000[] = "(\002 COLUMN-MAJOR DATA LAYOUT IS TESTED\002)";
+ static char fmt_9988[] = "(a13,l2)";
+ static char fmt_9990[] = "(\002 SUBPROGRAM NAME \002,a13,\002 NOT RECOGN"
+ "IZED\002,/\002 ******* T\002,\002ESTS ABANDONED *******\002)";
+ static char fmt_9998[] = "(\002 RELATIVE MACHINE PRECISION IS TAKEN TO"
+ " BE\002,1p,e9.1)";
+ static char fmt_9989[] = "(\002 ERROR IN ZMMCH - IN-LINE DOT PRODUCTS A"
+ "RE BEING EVALU\002,\002ATED WRONGLY.\002,/\002 ZMMCH WAS CALLED "
+ "WITH TRANSA = \002,a1,\002AND TRANSB = \002,a1,/\002 AND RETURNE"
+ "D SAME = \002,l1,\002 AND \002,\002 ERR = \002,f12.3,\002.\002,"
+ "/\002 THIS MAY BE DUE TO FAULTS IN THE \002,\002ARITHMETIC OR TH"
+ "E COMPILER.\002,/\002 ******* TESTS ABANDONED \002,\002******"
+ "*\002)";
+ static char fmt_9987[] = "(1x,a13,\002 WAS NOT TESTED\002)";
+ static char fmt_9986[] = "(/\002 END OF TESTS\002)";
+ static char fmt_9985[] = "(/\002 ******* FATAL ERROR - TESTS ABANDONED *"
+ "******\002)";
+ static char fmt_9991[] = "(\002 AMEND DATA FILE OR INCREASE ARRAY SIZES "
+ "IN PROGRAM\002,/\002 ******* TESTS ABANDONED *******\002)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1;
+ olist o__1;
+ cllist cl__1;
+
+ /* Local variables */
+ doublecomplex c__[4225] /* was [65][65] */;
+ doublereal g[65];
+ integer i__, j, n;
+ doublecomplex w[130], aa[4225], ab[8450] /* was [65][130] */, bb[4225],
+ cc[4225], as[4225], bs[4225], cs[4225], ct[65], alf[7], bet[7];
+ doublereal eps, err;
+ extern logical lze_(doublecomplex *, doublecomplex *, integer *);
+ integer nalf, idim[9];
+ logical same;
+ integer nbet, ntra;
+ logical rewi;
+ extern /* Subroutine */ int zchk1_(char *, doublereal *, doublereal *,
+ integer *, integer *, logical *, logical *, logical *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+ , doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
+ integer *), zchk2_(char *, doublereal *, doublereal *,
+ integer *, integer *, logical *, logical *, logical *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+ , doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
+ integer *), zchk3_(char *, doublereal *, doublereal *,
+ integer *, integer *, logical *, logical *, logical *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex
+ *, doublecomplex *, doublecomplex *, doublereal *, doublecomplex *
+ , integer *), zchk4_(char *, doublereal *, doublereal *,
+ integer *, integer *, logical *, logical *, logical *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+ , doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
+ integer *), zchk5_(char *, doublereal *, doublereal *,
+ integer *, integer *, logical *, logical *, logical *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+ , doublecomplex *, doublecomplex *, doublereal *, doublecomplex *,
+ integer *), zchk6_(char *, doublereal *, doublereal *,
+ integer *, integer *, logical *, logical *, logical *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+ , doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
+ integer *);
+ extern doublereal ddiff_(doublereal *, doublereal *);
+ logical fatal, trace;
+ integer nidim;
+ extern /* Subroutine */ int zmmch_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, doublereal *, doublecomplex *,
+ integer *, doublereal *, doublereal *, logical *, integer *,
+ logical *);
+ char snaps[32];
+ integer isnum;
+ logical ltest[10], sfatal, corder;
+ char snamet[13], transa[1], transb[1];
+ doublereal thresh;
+ logical rorder;
+ integer layout;
+ logical ltestt, tsterr;
+ extern /* Subroutine */ int cz3chke_(char *);
+
+ /* Fortran I/O blocks */
+ static cilist io___2 = { 0, 5, 0, 0, 0 };
+ static cilist io___4 = { 0, 5, 0, 0, 0 };
+ static cilist io___7 = { 0, 5, 0, 0, 0 };
+ static cilist io___9 = { 0, 5, 0, 0, 0 };
+ static cilist io___11 = { 0, 5, 0, 0, 0 };
+ static cilist io___13 = { 0, 5, 0, 0, 0 };
+ static cilist io___15 = { 0, 5, 0, 0, 0 };
+ static cilist io___17 = { 0, 5, 0, 0, 0 };
+ static cilist io___19 = { 0, 6, 0, fmt_9997, 0 };
+ static cilist io___20 = { 0, 5, 0, 0, 0 };
+ static cilist io___23 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___24 = { 0, 5, 0, 0, 0 };
+ static cilist io___26 = { 0, 6, 0, fmt_9997, 0 };
+ static cilist io___27 = { 0, 5, 0, 0, 0 };
+ static cilist io___29 = { 0, 5, 0, 0, 0 };
+ static cilist io___31 = { 0, 6, 0, fmt_9997, 0 };
+ static cilist io___32 = { 0, 5, 0, 0, 0 };
+ static cilist io___34 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___35 = { 0, 6, 0, fmt_9994, 0 };
+ static cilist io___36 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___37 = { 0, 6, 0, fmt_9992, 0 };
+ static cilist io___38 = { 0, 6, 0, 0, 0 };
+ static cilist io___39 = { 0, 6, 0, fmt_9984, 0 };
+ static cilist io___40 = { 0, 6, 0, 0, 0 };
+ static cilist io___41 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 6, 0, 0, 0 };
+ static cilist io___45 = { 0, 6, 0, fmt_10002, 0 };
+ static cilist io___46 = { 0, 6, 0, fmt_10001, 0 };
+ static cilist io___47 = { 0, 6, 0, fmt_10000, 0 };
+ static cilist io___48 = { 0, 6, 0, 0, 0 };
+ static cilist io___50 = { 0, 5, 1, fmt_9988, 0 };
+ static cilist io___53 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___55 = { 0, 6, 0, fmt_9998, 0 };
+ static cilist io___68 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___69 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___70 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___71 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___73 = { 0, 6, 0, 0, 0 };
+ static cilist io___74 = { 0, 6, 0, fmt_9987, 0 };
+ static cilist io___75 = { 0, 6, 0, 0, 0 };
+ static cilist io___82 = { 0, 6, 0, fmt_9986, 0 };
+ static cilist io___83 = { 0, 6, 0, fmt_9985, 0 };
+ static cilist io___84 = { 0, 6, 0, fmt_9991, 0 };
+
+
+
+/* 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 ( A13,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_zgemm T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_zhemm T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_zsymm T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_ztrmm T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_ztrsm T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_zherk T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_zsyrk T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_zher2k T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_zsyr2k T PUT F FOR NO TEST. SAME COLUMNS. */
+/* cblas_zgemmtr 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. */
+
+ s_rsle(&io___2);
+ do_lio(&c__9, &c__1, snaps, (ftnlen)32);
+ e_rsle();
+ s_rsle(&io___4);
+ do_lio(&c__3, &c__1, (char *)&ntra, (ftnlen)sizeof(integer));
+ e_rsle();
+ 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. */
+ s_rsle(&io___7);
+ do_lio(&c__8, &c__1, (char *)&rewi, (ftnlen)sizeof(logical));
+ e_rsle();
+ rewi = rewi && trace;
+/* Read the flag that directs stopping on any failure. */
+ s_rsle(&io___9);
+ do_lio(&c__8, &c__1, (char *)&sfatal, (ftnlen)sizeof(logical));
+ e_rsle();
+/* Read the flag that indicates whether error exits are to be tested. */
+ s_rsle(&io___11);
+ do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
+ e_rsle();
+/* Read the flag that indicates whether row-major data layout to be tested. */
+ s_rsle(&io___13);
+ do_lio(&c__3, &c__1, (char *)&layout, (ftnlen)sizeof(integer));
+ e_rsle();
+/* Read the threshold value of the test ratio */
+ s_rsle(&io___15);
+ do_lio(&c__5, &c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_rsle();
+
+/* Read and check the parameter values for the tests. */
+
+/* Values of N */
+ s_rsle(&io___17);
+ do_lio(&c__3, &c__1, (char *)&nidim, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nidim < 1 || nidim > 9) {
+ s_wsfe(&io___19);
+ do_fio(&c__1, "N", (ftnlen)1);
+ do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+ s_rsle(&io___20);
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) {
+ s_wsfe(&io___23);
+ do_fio(&c__1, (char *)&c__65, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+/* L10: */
+ }
+/* Values of ALPHA */
+ s_rsle(&io___24);
+ do_lio(&c__3, &c__1, (char *)&nalf, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nalf < 1 || nalf > 7) {
+ s_wsfe(&io___26);
+ do_fio(&c__1, "ALPHA", (ftnlen)5);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+ s_rsle(&io___27);
+ i__1 = nalf;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__7, &c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(
+ doublecomplex));
+ }
+ e_rsle();
+/* Values of BETA */
+ s_rsle(&io___29);
+ do_lio(&c__3, &c__1, (char *)&nbet, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nbet < 1 || nbet > 7) {
+ s_wsfe(&io___31);
+ do_fio(&c__1, "BETA", (ftnlen)4);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+ s_rsle(&io___32);
+ i__1 = nbet;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__7, &c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(
+ doublecomplex));
+ }
+ e_rsle();
+
+/* Report values of parameters. */
+
+ s_wsfe(&io___34);
+ e_wsfe();
+ s_wsfe(&io___35);
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ s_wsfe(&io___36);
+ i__1 = nalf;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__2, (char *)&alf[i__ - 1], (ftnlen)sizeof(doublereal));
+ }
+ e_wsfe();
+ s_wsfe(&io___37);
+ i__1 = nbet;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__2, (char *)&bet[i__ - 1], (ftnlen)sizeof(doublereal));
+ }
+ e_wsfe();
+ if (! tsterr) {
+ s_wsle(&io___38);
+ e_wsle();
+ s_wsfe(&io___39);
+ e_wsfe();
+ }
+ s_wsle(&io___40);
+ e_wsle();
+ s_wsfe(&io___41);
+ do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ s_wsle(&io___42);
+ e_wsle();
+ rorder = FALSE_;
+ corder = FALSE_;
+ if (layout == 2) {
+ rorder = TRUE_;
+ corder = TRUE_;
+ s_wsfe(&io___45);
+ e_wsfe();
+ } else if (layout == 1) {
+ rorder = TRUE_;
+ s_wsfe(&io___46);
+ e_wsfe();
+ } else if (layout == 0) {
+ corder = TRUE_;
+ s_wsfe(&io___47);
+ e_wsfe();
+ }
+ s_wsle(&io___48);
+ e_wsle();
+
+/* Read names of subroutines and flags which indicate */
+/* whether they are to be tested. */
+
+ for (i__ = 1; i__ <= 10; ++i__) {
+ ltest[i__ - 1] = FALSE_;
+/* L20: */
+ }
+L30:
+ i__1 = s_rsfe(&io___50);
+ if (i__1 != 0) {
+ goto L60;
+ }
+ i__1 = do_fio(&c__1, snamet, (ftnlen)13);
+ if (i__1 != 0) {
+ goto L60;
+ }
+ i__1 = do_fio(&c__1, (char *)<estt, (ftnlen)sizeof(logical));
+ if (i__1 != 0) {
+ goto L60;
+ }
+ i__1 = e_rsfe();
+ if (i__1 != 0) {
+ goto L60;
+ }
+ for (i__ = 1; i__ <= 10; ++i__) {
+ if (s_cmp(snamet, snames + (i__ - 1) * 13, (ftnlen)13, (ftnlen)13) ==
+ 0) {
+ goto L50;
+ }
+/* L40: */
+ }
+ s_wsfe(&io___53);
+ do_fio(&c__1, snamet, (ftnlen)13);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+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;
+ s_wsfe(&io___55);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+
+/* 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);
+ same = lze_(cc, ct, &n);
+ if (! same || err != 0.) {
+ s_wsfe(&io___68);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+ *(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);
+ same = lze_(cc, ct, &n);
+ if (! same || err != 0.) {
+ s_wsfe(&io___69);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+ 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);
+ same = lze_(cc, ct, &n);
+ if (! same || err != 0.) {
+ s_wsfe(&io___70);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+ *(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);
+ same = lze_(cc, ct, &n);
+ if (! same || err != 0.) {
+ s_wsfe(&io___71);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+/* Test each subroutine in turn. */
+
+ for (isnum = 1; isnum <= 10; ++isnum) {
+ s_wsle(&io___73);
+ e_wsle();
+ if (! ltest[isnum - 1]) {
+/* Subprogram is not to be tested. */
+ s_wsfe(&io___74);
+ do_fio(&c__1, snames + (isnum - 1) * 13, (ftnlen)13);
+ e_wsfe();
+ } else {
+ s_copy(srnamc_1.srnamt, snames + (isnum - 1) * 13, (ftnlen)13, (
+ ftnlen)13);
+/* Test error exits. */
+ if (tsterr) {
+ cz3chke_(snames + (isnum - 1) * 13);
+ s_wsle(&io___75);
+ e_wsle();
+ }
+/* 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;
+ case 10: goto L185;
+ }
+/* Test ZGEMM, 01. */
+L140:
+ if (corder) {
+ zchk1_(snames + (isnum - 1) * 13, &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) {
+ zchk1_(snames + (isnum - 1) * 13, &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 ZHEMM, 02, ZSYMM, 03. */
+L150:
+ if (corder) {
+ zchk2_(snames + (isnum - 1) * 13, &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) {
+ zchk2_(snames + (isnum - 1) * 13, &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 ZTRMM, 04, ZTRSM, 05. */
+L160:
+ if (corder) {
+ zchk3_(snames + (isnum - 1) * 13, &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) {
+ zchk3_(snames + (isnum - 1) * 13, &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 ZHERK, 06, ZSYRK, 07. */
+L170:
+ if (corder) {
+ zchk4_(snames + (isnum - 1) * 13, &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) {
+ zchk4_(snames + (isnum - 1) * 13, &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 ZHER2K, 08, ZSYR2K, 09. */
+L180:
+ if (corder) {
+ zchk5_(snames + (isnum - 1) * 13, &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) {
+ zchk5_(snames + (isnum - 1) * 13, &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;
+/* Test ZGEMMTR, 10 */
+L185:
+ if (corder) {
+ zchk6_(snames + (isnum - 1) * 13, &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) {
+ zchk6_(snames + (isnum - 1) * 13, &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;
+
+L190:
+ if (fatal && sfatal) {
+ goto L210;
+ }
+ }
+/* L200: */
+ }
+ s_wsfe(&io___82);
+ e_wsfe();
+ goto L230;
+
+L210:
+ s_wsfe(&io___83);
+ e_wsfe();
+ goto L230;
+
+L220:
+ s_wsfe(&io___84);
+ e_wsfe();
+
+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);
+
+
+/* End of ZBLAT3. */
+
+ return 0;
+} /* MAIN__ */
+
+/* Subroutine */ int zchk1_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nalf, doublecomplex *
+ alf, integer *nbet, doublecomplex *bet, integer *nmax, doublecomplex *
+ a, doublecomplex *aa, doublecomplex *as, doublecomplex *b,
+ doublecomplex *bb, doublecomplex *bs, doublecomplex *c__,
+ doublecomplex *cc, doublecomplex *cs, doublecomplex *ct, doublereal *
+ g, integer *iorder)
+{
+ /* Initialized data */
+
+ static char ich[3] = "NTC";
+
+ /* Format strings */
+ static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
+ "TAKEN ON VALID CALL *******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
+ "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
+ " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
+ "BER:\002)";
+
+ /* 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;
+ alist al__1;
+
+ /* Local variables */
+ integer i__, k, m, n, ia, ib, ma, mb, na, nb, nc, ik, im, in, ks, ms, ns,
+ ica, icb, laa, lbb, lda, lcc, ldb, ldc;
+ doublecomplex als, bls;
+ doublereal err;
+ extern logical lze_(doublecomplex *, doublecomplex *, integer *);
+ doublecomplex beta;
+ integer ldas, ldbs, ldcs;
+ logical same, null;
+ doublecomplex alpha;
+ logical isame[13], trana, tranb;
+ extern /* Subroutine */ int zmake_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ logical *, doublecomplex *);
+ integer nargs;
+ extern /* Subroutine */ int zmmch_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, doublereal *, doublecomplex *,
+ integer *, doublereal *, doublereal *, logical *, integer *,
+ logical *);
+ logical reset;
+ extern /* Subroutine */ int zprcn1_(integer *, integer *, char *, integer
+ *, char *, char *, integer *, integer *, integer *, doublecomplex
+ *, integer *, integer *, doublecomplex *, integer *), czgemm_(integer *, char *, char *, integer *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ char tranas[1], tranbs[1], transa[1], transb[1];
+ doublereal errmax;
+ extern logical lzeres_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___128 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___131 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___133 = { 0, 0, 0, fmt_10000, 0 };
+ static cilist io___134 = { 0, 0, 0, fmt_10001, 0 };
+ static cilist io___135 = { 0, 0, 0, fmt_10002, 0 };
+ static cilist io___136 = { 0, 0, 0, fmt_10003, 0 };
+ static cilist io___137 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* 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. */
+
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+
+ 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);
+
+ 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);
+
+ 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);
+
+ ++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);
+ }
+ 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);
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___128.ciunit = *nout;
+ s_wsfe(&io___128);
+ e_wsfe();
+ *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);
+ }
+ 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]) {
+ io___131.ciunit = *nout;
+ s_wsfe(&io___131);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* 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);
+ 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) {
+ io___133.ciunit = *nout;
+ s_wsfe(&io___133);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___134.ciunit = *nout;
+ s_wsfe(&io___134);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ } else {
+ if (*iorder == 0) {
+ io___135.ciunit = *nout;
+ s_wsfe(&io___135);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___136.ciunit = *nout;
+ s_wsfe(&io___136);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ }
+ goto L130;
+
+L120:
+ io___137.ciunit = *nout;
+ s_wsfe(&io___137);
+ do_fio(&c__1, sname, (ftnlen)13);
+ e_wsfe();
+ zprcn1_(nout, &nc, sname, iorder, transa, transb, &m, &n, &k, &alpha, &
+ lda, &ldb, &beta, &ldc);
+
+L130:
+ return 0;
+
+/* L9995: */
+
+/* End of ZCHK1. */
+
+} /* zchk1_ */
+
+
+/* Subroutine */ int zprcn1_(integer *nout, integer *nc, char *sname, integer
+ *iorder, char *transa, char *transb, integer *m, integer *n, integer *
+ k, doublecomplex *alpha, integer *lda, integer *ldb, doublecomplex *
+ beta, integer *ldc)
+{
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
+ "a14,\002,\002,a14,\002,\002)";
+ static char fmt_9994[] = "(10x,3(i3,\002,\002),\002 (\002,f4.1,\002,\002"
+ ",f4.1,\002) , A,\002,i3,\002, B,\002,i3,\002, (\002,f4.1,\002"
+ ",\002,f4.1,\002) , C,\002,i3,\002).\002)";
+
+ /* Local variables */
+ char crc[14], cta[14], ctb[14];
+
+ /* Fortran I/O blocks */
+ static cilist io___141 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___142 = { 0, 0, 0, fmt_9994, 0 };
+
+
+ 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);
+ }
+ io___141.ciunit = *nout;
+ s_wsfe(&io___141);
+ do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, crc, (ftnlen)14);
+ do_fio(&c__1, cta, (ftnlen)14);
+ do_fio(&c__1, ctb, (ftnlen)14);
+ e_wsfe();
+ io___142.ciunit = *nout;
+ s_wsfe(&io___142);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
+ e_wsfe();
+ return 0;
+} /* zprcn1_ */
+
+
+/* Subroutine */ int zchk2_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nalf, doublecomplex *
+ alf, integer *nbet, doublecomplex *bet, integer *nmax, doublecomplex *
+ a, doublecomplex *aa, doublecomplex *as, doublecomplex *b,
+ doublecomplex *bb, doublecomplex *bs, doublecomplex *c__,
+ doublecomplex *cc, doublecomplex *cs, doublecomplex *ct, doublereal *
+ g, integer *iorder)
+{
+ /* Initialized data */
+
+ static char ichs[2] = "LR";
+ static char ichu[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
+ "TAKEN ON VALID CALL *******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
+ "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
+ " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
+ "BER:\002)";
+
+ /* 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;
+ alist al__1;
+
+ /* Local variables */
+ integer i__, m, n, ia, ib, na, nc, im, in, ms, ns, laa, lbb, lda, lcc,
+ ldb, ldc, ics;
+ doublecomplex als, bls;
+ integer icu;
+ doublereal err;
+ extern logical lze_(doublecomplex *, doublecomplex *, integer *);
+ doublecomplex beta;
+ integer ldas, ldbs, ldcs;
+ logical same;
+ char side[1];
+ logical conj, left, null;
+ char uplo[1];
+ doublecomplex alpha;
+ logical isame[13];
+ char sides[1];
+ extern /* Subroutine */ int zmake_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ logical *, doublecomplex *);
+ integer nargs;
+ extern /* Subroutine */ int zmmch_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, doublereal *, doublecomplex *,
+ integer *, doublereal *, doublereal *, logical *, integer *,
+ logical *);
+ logical reset;
+ char uplos[1];
+ extern /* Subroutine */ int zprcn2_(integer *, integer *, char *, integer
+ *, char *, char *, integer *, integer *, doublecomplex *, integer
+ *, integer *, doublecomplex *, integer *),
+ czhemm_(integer *, char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ doublereal errmax;
+ extern logical lzeres_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *);
+ extern /* Subroutine */ int czsymm_(integer *, char *, char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___181 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___184 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___186 = { 0, 0, 0, fmt_10000, 0 };
+ static cilist io___187 = { 0, 0, 0, fmt_10001, 0 };
+ static cilist io___188 = { 0, 0, 0, fmt_10002, 0 };
+ static cilist io___189 = { 0, 0, 0, fmt_10003, 0 };
+ static cilist io___190 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* 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. */
+
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ conj = 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);
+
+ 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);
+
+ 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);
+
+ ++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)
+ ;
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ if (conj) {
+ czhemm_(iorder, side, uplo, &m, &n, &alpha, &
+ aa[1], &lda, &bb[1], &ldb, &beta, &cc[
+ 1], &ldc);
+ } else {
+ czsymm_(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) {
+ io___181.ciunit = *nout;
+ s_wsfe(&io___181);
+ e_wsfe();
+ *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);
+ }
+ 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]) {
+ io___184.ciunit = *nout;
+ s_wsfe(&io___184);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* 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);
+ } 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);
+ }
+ 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) {
+ io___186.ciunit = *nout;
+ s_wsfe(&io___186);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___187.ciunit = *nout;
+ s_wsfe(&io___187);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ } else {
+ if (*iorder == 0) {
+ io___188.ciunit = *nout;
+ s_wsfe(&io___188);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___189.ciunit = *nout;
+ s_wsfe(&io___189);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ }
+ goto L120;
+
+L110:
+ io___190.ciunit = *nout;
+ s_wsfe(&io___190);
+ do_fio(&c__1, sname, (ftnlen)13);
+ e_wsfe();
+ zprcn2_(nout, &nc, sname, iorder, side, uplo, &m, &n, &alpha, &lda, &ldb,
+ &beta, &ldc);
+
+L120:
+ return 0;
+
+/* L9995: */
+
+/* End of ZCHK2. */
+
+} /* zchk2_ */
+
+
+/* Subroutine */ int zprcn2_(integer *nout, integer *nc, char *sname, integer
+ *iorder, char *side, char *uplo, integer *m, integer *n,
+ doublecomplex *alpha, integer *lda, integer *ldb, doublecomplex *beta,
+ integer *ldc)
+{
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
+ "a14,\002,\002,a14,\002,\002)";
+ static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002"
+ ",f4.1,\002), A,\002,i3,\002, B,\002,i3,\002, (\002,f4.1,\002,"
+ "\002,f4.1,\002), \002,\002C,\002,i3,\002).\002)";
+
+ /* Local variables */
+ char cs[14], cu[14], crc[14];
+
+ /* Fortran I/O blocks */
+ static cilist io___194 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___195 = { 0, 0, 0, fmt_9994, 0 };
+
+
+ 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);
+ }
+ io___194.ciunit = *nout;
+ s_wsfe(&io___194);
+ do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, crc, (ftnlen)14);
+ do_fio(&c__1, cs, (ftnlen)14);
+ do_fio(&c__1, cu, (ftnlen)14);
+ e_wsfe();
+ io___195.ciunit = *nout;
+ s_wsfe(&io___195);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
+ e_wsfe();
+ return 0;
+} /* zprcn2_ */
+
+
+/* Subroutine */ int zchk3_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nalf, doublecomplex *
+ alf, integer *nmax, doublecomplex *a, doublecomplex *aa,
+ doublecomplex *as, doublecomplex *b, doublecomplex *bb, doublecomplex
+ *bs, doublecomplex *ct, doublereal *g, doublecomplex *c__, integer *
+ iorder)
+{
+ /* Initialized data */
+
+ static char ichu[2] = "UL";
+ static char icht[3] = "NTC";
+ static char ichd[2] = "UN";
+ static char ichs[2] = "LR";
+
+ /* Format strings */
+ static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
+ "TAKEN ON VALID CALL *******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
+ "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
+ " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
+ "BER:\002)";
+
+ /* 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;
+ alist al__1;
+
+ /* Local variables */
+ integer i__, j, m, n, ia, na, nc, im, in, ms, ns, laa, icd, lbb, lda, ldb,
+ ics;
+ doublecomplex als;
+ integer ict, icu;
+ doublereal err;
+ extern logical lze_(doublecomplex *, doublecomplex *, integer *);
+ char diag[1];
+ integer ldas, ldbs;
+ logical same;
+ char side[1];
+ logical left, null;
+ char uplo[1];
+ doublecomplex alpha;
+ char diags[1];
+ logical isame[13];
+ char sides[1];
+ extern /* Subroutine */ int zmake_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ logical *, doublecomplex *);
+ integer nargs;
+ extern /* Subroutine */ int zmmch_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, doublereal *, doublecomplex *,
+ integer *, doublereal *, doublereal *, logical *, integer *,
+ logical *);
+ logical reset;
+ char uplos[1];
+ extern /* Subroutine */ int zprcn3_(integer *, integer *, char *, integer
+ *, char *, char *, char *, char *, integer *, integer *,
+ doublecomplex *, integer *, integer *);
+ char tranas[1], transa[1];
+ doublereal errmax;
+ extern logical lzeres_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *);
+ extern /* Subroutine */ int cztrmm_(integer *, char *, char *, char *,
+ char *, integer *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *), cztrsm_(integer *, char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___236 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___239 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___241 = { 0, 0, 0, fmt_10000, 0 };
+ static cilist io___242 = { 0, 0, 0, fmt_10001, 0 };
+ static cilist io___243 = { 0, 0, 0, fmt_10002, 0 };
+ static cilist io___244 = { 0, 0, 0, fmt_10003, 0 };
+ static cilist io___245 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* 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. */
+
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --g;
+ --ct;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+
+ 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);
+
+/* Generate the matrix B. */
+
+ zmake_("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) {
+ zprcn3_(ntra, &nc, sname, iorder,
+ side, uplo, transa, diag, &m,
+ &n, &alpha, &lda, &ldb, (
+ ftnlen)13, (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);
+ } 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)13, (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);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___236.ciunit = *nout;
+ s_wsfe(&io___236);
+ e_wsfe();
+ *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);
+ }
+ 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]) {
+ io___239.ciunit = *nout;
+ s_wsfe(&io___239);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* 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);
+ }
+ } 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);
+ } 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);
+ }
+ }
+ 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) {
+ io___241.ciunit = *nout;
+ s_wsfe(&io___241);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___242.ciunit = *nout;
+ s_wsfe(&io___242);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ } else {
+ if (*iorder == 0) {
+ io___243.ciunit = *nout;
+ s_wsfe(&io___243);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___244.ciunit = *nout;
+ s_wsfe(&io___244);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ }
+ goto L160;
+
+L150:
+ io___245.ciunit = *nout;
+ s_wsfe(&io___245);
+ do_fio(&c__1, sname, (ftnlen)13);
+ e_wsfe();
+ if (*trace) {
+ zprcn3_(ntra, &nc, sname, iorder, side, uplo, transa, diag, &m, &n, &
+ alpha, &lda, &ldb);
+ }
+
+L160:
+ return 0;
+
+/* L9995: */
+
+/* End of ZCHK3. */
+
+} /* zchk3_ */
+
+
+/* Subroutine */ int zprcn3_(integer *nout, integer *nc, char *sname, integer
+ *iorder, char *side, char *uplo, char *transa, char *diag, integer *m,
+ integer *n, doublecomplex *alpha, integer *lda, integer *ldb)
+{
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
+ "a14,\002,\002,a14,\002,\002)";
+ static char fmt_9994[] = "(10x,2(a14,\002,\002),2(i3,\002,\002),\002 "
+ "(\002,f4.1,\002,\002,f4.1,\002), A,\002,i3,\002, B,\002,i3,\002)."
+ "\002)";
+
+ /* Local variables */
+ char ca[14], cd[14], cs[14], cu[14], crc[14];
+
+ /* Fortran I/O blocks */
+ static cilist io___251 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___252 = { 0, 0, 0, fmt_9994, 0 };
+
+
+ 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);
+ }
+ io___251.ciunit = *nout;
+ s_wsfe(&io___251);
+ do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, crc, (ftnlen)14);
+ do_fio(&c__1, cs, (ftnlen)14);
+ do_fio(&c__1, cu, (ftnlen)14);
+ e_wsfe();
+ io___252.ciunit = *nout;
+ s_wsfe(&io___252);
+ do_fio(&c__1, ca, (ftnlen)14);
+ do_fio(&c__1, cd, (ftnlen)14);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
+ e_wsfe();
+ return 0;
+} /* zprcn3_ */
+
+
+/* Subroutine */ int zchk4_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nalf, doublecomplex *
+ alf, integer *nbet, doublecomplex *bet, integer *nmax, doublecomplex *
+ a, doublecomplex *aa, doublecomplex *as, doublecomplex *b,
+ doublecomplex *bb, doublecomplex *bs, doublecomplex *c__,
+ doublecomplex *cc, doublecomplex *cs, doublecomplex *ct, doublereal *
+ g, integer *iorder)
+{
+ /* Initialized data */
+
+ static char icht[2] = "NC";
+ static char ichu[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
+ "TAKEN ON VALID CALL *******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
+ "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
+ " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+ static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
+ "BER:\002)";
+
+ /* 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;
+ alist al__1;
+
+ /* Local variables */
+ integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa,
+ lda, lcc, ldc;
+ doublecomplex als;
+ integer ict, icu;
+ doublereal err;
+ extern logical lze_(doublecomplex *, doublecomplex *, integer *);
+ doublecomplex beta;
+ integer ldas, ldcs;
+ logical same, conj;
+ doublecomplex bets;
+ doublereal rals;
+ logical tran, null;
+ char uplo[1];
+ doublecomplex alpha;
+ doublereal rbeta;
+ logical isame[13];
+ extern /* Subroutine */ int zmake_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ logical *, doublecomplex *);
+ integer nargs;
+ extern /* Subroutine */ int zmmch_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, doublereal *, doublecomplex *,
+ integer *, doublereal *, doublereal *, logical *, integer *,
+ logical *);
+ doublereal rbets;
+ logical reset;
+ char trans[1];
+ logical upper;
+ char uplos[1];
+ extern /* Subroutine */ int zprcn4_(integer *, integer *, char *, integer
+ *, char *, char *, integer *, integer *, doublecomplex *, integer
+ *, doublecomplex *, integer *), zprcn6_(
+ integer *, integer *, char *, integer *, char *, char *, integer *
+ , integer *, doublereal *, integer *, doublereal *, integer *);
+ doublereal ralpha;
+ extern /* Subroutine */ int czherk_(integer *, char *, char *, integer *,
+ integer *, doublereal *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *);
+ doublereal errmax;
+ extern logical lzeres_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *);
+ char transs[1], transt[1];
+ extern /* Subroutine */ int czsyrk_(integer *, char *, char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___294 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___297 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___304 = { 0, 0, 0, fmt_10000, 0 };
+ static cilist io___305 = { 0, 0, 0, fmt_10001, 0 };
+ static cilist io___306 = { 0, 0, 0, fmt_10002, 0 };
+ static cilist io___307 = { 0, 0, 0, fmt_10003, 0 };
+ static cilist io___308 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___309 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* 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. */
+
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ conj = s_cmp(sname + 7, "he", (ftnlen)2, (ftnlen)2) == 0;
+
+ 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;
+
+ 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. */
+
+ zmake_("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;
+ 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 (conj) {
+ 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 (conj) {
+ 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);
+
+ ++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) {
+ zprcn6_(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);
+ }
+ czherk_(iorder, uplo, trans, &n, &k, &ralpha,
+ &aa[1], &lda, &rbeta, &cc[1], &ldc);
+ } else {
+ if (*trace) {
+ zprcn4_(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);
+ }
+ czsyrk_(iorder, uplo, trans, &n, &k, &alpha, &
+ aa[1], &lda, &beta, &cc[1], &ldc);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___294.ciunit = *nout;
+ s_wsfe(&io___294);
+ e_wsfe();
+ *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] = lze_(&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] = lze_(&cs[1], &cc[1], &lcc);
+ } else {
+ isame[8] = lzeres_(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]) {
+ io___297.ciunit = *nout;
+ s_wsfe(&io___297);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* 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) {
+ 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);
+ } 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);
+ }
+ 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) {
+ io___304.ciunit = *nout;
+ s_wsfe(&io___304);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___305.ciunit = *nout;
+ s_wsfe(&io___305);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ } else {
+ if (*iorder == 0) {
+ io___306.ciunit = *nout;
+ s_wsfe(&io___306);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___307.ciunit = *nout;
+ s_wsfe(&io___307);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ }
+ goto L130;
+
+L110:
+ if (n > 1) {
+ io___308.ciunit = *nout;
+ s_wsfe(&io___308);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L120:
+ io___309.ciunit = *nout;
+ s_wsfe(&io___309);
+ do_fio(&c__1, sname, (ftnlen)13);
+ e_wsfe();
+ if (conj) {
+ zprcn6_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &ralpha, &lda,
+ &rbeta, &ldc);
+ } else {
+ zprcn4_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &
+ beta, &ldc);
+ }
+
+L130:
+ return 0;
+
+/* L9994: */
+/* L9993: */
+
+/* End of CCHK4. */
+
+} /* zchk4_ */
+
+
+/* Subroutine */ int zprcn4_(integer *nout, integer *nc, char *sname, integer
+ *iorder, char *uplo, char *transa, integer *n, integer *k,
+ doublecomplex *alpha, integer *lda, doublecomplex *beta, integer *ldc)
+{
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002,"
+ "\002))";
+ static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002"
+ ",f4.1,\002), A,\002,i3,\002, (\002,f4.1,\002,\002,f4.1,\002), C"
+ ",\002,i3,\002).\002)";
+
+ /* Local variables */
+ char ca[14], cu[14], crc[14];
+
+ /* Fortran I/O blocks */
+ static cilist io___313 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___314 = { 0, 0, 0, fmt_9994, 0 };
+
+
+ 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);
+ }
+ io___313.ciunit = *nout;
+ s_wsfe(&io___313);
+ do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, crc, (ftnlen)14);
+ do_fio(&c__1, cu, (ftnlen)14);
+ do_fio(&c__1, ca, (ftnlen)14);
+ e_wsfe();
+ io___314.ciunit = *nout;
+ s_wsfe(&io___314);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
+ e_wsfe();
+ return 0;
+} /* zprcn4_ */
+
+
+
+/* Subroutine */ int zprcn6_(integer *nout, integer *nc, char *sname, integer
+ *iorder, char *uplo, char *transa, integer *n, integer *k, doublereal
+ *alpha, integer *lda, doublereal *beta, integer *ldc)
+{
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002,"
+ "\002))";
+ static char fmt_9994[] = "(10x,2(i3,\002,\002),f4.1,\002, A,\002,i3"
+ ",\002,\002,f4.1,\002, C,\002,i3,\002).\002)";
+
+ /* Local variables */
+ char ca[14], cu[14], crc[14];
+
+ /* Fortran I/O blocks */
+ static cilist io___318 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___319 = { 0, 0, 0, fmt_9994, 0 };
+
+
+ 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);
+ }
+ io___318.ciunit = *nout;
+ s_wsfe(&io___318);
+ do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, crc, (ftnlen)14);
+ do_fio(&c__1, cu, (ftnlen)14);
+ do_fio(&c__1, ca, (ftnlen)14);
+ e_wsfe();
+ io___319.ciunit = *nout;
+ s_wsfe(&io___319);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
+ e_wsfe();
+ return 0;
+} /* zprcn6_ */
+
+
+/* Subroutine */ int zchk5_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nalf, doublecomplex *
+ alf, integer *nbet, doublecomplex *bet, integer *nmax, doublecomplex *
+ ab, doublecomplex *aa, doublecomplex *as, doublecomplex *bb,
+ doublecomplex *bs, doublecomplex *c__, doublecomplex *cc,
+ doublecomplex *cs, doublecomplex *ct, doublereal *g, doublecomplex *w,
+ integer *iorder)
+{
+ /* Initialized data */
+
+ static char icht[2] = "NC";
+ static char ichu[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
+ "TAKEN ON VALID CALL *******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
+ "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
+ " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+ static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
+ "BER:\002)";
+
+ /* 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;
+ alist al__1;
+
+ /* Local variables */
+ integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa,
+ lbb, lda, lcc, ldb, ldc;
+ doublecomplex als;
+ integer ict, icu;
+ doublereal err;
+ extern logical lze_(doublecomplex *, doublecomplex *, integer *);
+ integer jjab;
+ doublecomplex beta;
+ integer ldas, ldbs, ldcs;
+ logical same, conj;
+ doublecomplex bets;
+ logical tran, null;
+ char uplo[1];
+ doublecomplex alpha;
+ doublereal rbeta;
+ logical isame[13];
+ extern /* Subroutine */ int zmake_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ logical *, doublecomplex *);
+ integer nargs;
+ extern /* Subroutine */ int zmmch_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, doublereal *, doublecomplex *,
+ integer *, doublereal *, doublereal *, logical *, integer *,
+ logical *);
+ doublereal rbets;
+ logical reset;
+ char trans[1];
+ logical upper;
+ char uplos[1];
+ extern /* Subroutine */ int zprcn5_(integer *, integer *, char *, integer
+ *, char *, char *, integer *, integer *, doublecomplex *, integer
+ *, integer *, doublecomplex *, integer *),
+ zprcn7_(integer *, integer *, char *, integer *, char *, char *,
+ integer *, integer *, doublecomplex *, integer *, integer *,
+ doublereal *, integer *);
+ doublereal errmax;
+ extern logical lzeres_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *);
+ char transs[1], transt[1];
+ extern /* Subroutine */ int czher2k_(integer *, char *, char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *,
+ integer *), czsyr2k_(integer *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___362 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___365 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___373 = { 0, 0, 0, fmt_10000, 0 };
+ static cilist io___374 = { 0, 0, 0, fmt_10001, 0 };
+ static cilist io___375 = { 0, 0, 0, fmt_10002, 0 };
+ static cilist io___376 = { 0, 0, 0, fmt_10003, 0 };
+ static cilist io___377 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___378 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* 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. */
+
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --w;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ 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.;
+
+ 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;
+ zmake_("ge", " ", " ", &ma, &na, &ab[1], &i__3, &aa[1], &
+ lda, &reset, &c_b1);
+ } else {
+ zmake_("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;
+ zmake_("ge", " ", " ", &ma, &na, &ab[k + 1], &i__3, &bb[1]
+ , &ldb, &reset, &c_b1);
+ } else {
+ zmake_("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;
+ z__1.r = rbeta, z__1.i = 0.;
+ beta.r = z__1.r, beta.i = z__1.i;
+ }
+ null = n <= 0;
+ if (conj) {
+ 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);
+
+ ++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) {
+ zprcn7_(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);
+ }
+ czher2k_(iorder, uplo, trans, &n, &k, &alpha,
+ &aa[1], &lda, &bb[1], &ldb, &rbeta, &
+ cc[1], &ldc);
+ } else {
+ if (*trace) {
+ zprcn5_(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);
+ }
+ czsyr2k_(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) {
+ io___362.ciunit = *nout;
+ s_wsfe(&io___362);
+ e_wsfe();
+ *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 (conj) {
+ 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);
+ }
+ 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]) {
+ io___365.ciunit = *nout;
+ s_wsfe(&io___365);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* 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__;
+ 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 (conj) {
+ 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);
+ } else {
+ i__6 = k;
+ for (i__ = 1; i__ <= i__6; ++i__) {
+ if (conj) {
+ 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);
+ }
+ 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) {
+ io___373.ciunit = *nout;
+ s_wsfe(&io___373);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___374.ciunit = *nout;
+ s_wsfe(&io___374);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ } else {
+ if (*iorder == 0) {
+ io___375.ciunit = *nout;
+ s_wsfe(&io___375);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___376.ciunit = *nout;
+ s_wsfe(&io___376);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ }
+ goto L160;
+
+L140:
+ if (n > 1) {
+ io___377.ciunit = *nout;
+ s_wsfe(&io___377);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L150:
+ io___378.ciunit = *nout;
+ s_wsfe(&io___378);
+ do_fio(&c__1, sname, (ftnlen)13);
+ e_wsfe();
+ if (conj) {
+ zprcn7_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &
+ ldb, &rbeta, &ldc);
+ } else {
+ zprcn5_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &
+ ldb, &beta, &ldc);
+ }
+
+L160:
+ return 0;
+
+/* L9994: */
+/* L9993: */
+
+/* End of ZCHK5. */
+
+} /* zchk5_ */
+
+
+/* Subroutine */ int zprcn5_(integer *nout, integer *nc, char *sname, integer
+ *iorder, char *uplo, char *transa, integer *n, integer *k,
+ doublecomplex *alpha, integer *lda, integer *ldb, doublecomplex *beta,
+ integer *ldc)
+{
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002,"
+ "\002))";
+ static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002"
+ ",f4.1,\002), A,\002,i3,\002, B\002,i3,\002, (\002,f4.1,\002,\002"
+ ",f4.1,\002), C,\002,i3,\002).\002)";
+
+ /* Local variables */
+ char ca[14], cu[14], crc[14];
+
+ /* Fortran I/O blocks */
+ static cilist io___382 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___383 = { 0, 0, 0, fmt_9994, 0 };
+
+
+ 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);
+ }
+ io___382.ciunit = *nout;
+ s_wsfe(&io___382);
+ do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, crc, (ftnlen)14);
+ do_fio(&c__1, cu, (ftnlen)14);
+ do_fio(&c__1, ca, (ftnlen)14);
+ e_wsfe();
+ io___383.ciunit = *nout;
+ s_wsfe(&io___383);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
+ e_wsfe();
+ return 0;
+} /* zprcn5_ */
+
+
+
+/* Subroutine */ int zprcn7_(integer *nout, integer *nc, char *sname, integer
+ *iorder, char *uplo, char *transa, integer *n, integer *k,
+ doublecomplex *alpha, integer *lda, integer *ldb, doublereal *beta,
+ integer *ldc)
+{
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002,"
+ "\002))";
+ static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002"
+ ",f4.1,\002), A,\002,i3,\002, B\002,i3,\002,\002,f4.1,\002, C,"
+ "\002,i3,\002).\002)";
+
+ /* Local variables */
+ char ca[14], cu[14], crc[14];
+
+ /* Fortran I/O blocks */
+ static cilist io___387 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___388 = { 0, 0, 0, fmt_9994, 0 };
+
+
+ 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);
+ }
+ io___387.ciunit = *nout;
+ s_wsfe(&io___387);
+ do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, crc, (ftnlen)14);
+ do_fio(&c__1, cu, (ftnlen)14);
+ do_fio(&c__1, ca, (ftnlen)14);
+ e_wsfe();
+ io___388.ciunit = *nout;
+ s_wsfe(&io___388);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
+ e_wsfe();
+ return 0;
+} /* zprcn7_ */
+
+
+/* Subroutine */ int zmake_(char *type__, char *uplo, char *diag, integer *m,
+ integer *n, doublecomplex *a, integer *nmax, doublecomplex *aa,
+ integer *lda, logical *reset, doublecomplex *transl)
+{
+ /* 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 */
+ integer i__, j, jj;
+ logical gen, her, tri, sym;
+ integer ibeg, iend;
+ extern /* Double Complex */ VOID zbeg_(doublecomplex *, logical *);
+ logical unit, lower, upper;
+
+
+/* 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;
+ a -= a_offset;
+ --aa;
+
+ /* Function Body */
+ gen = s_cmp(type__, "ge", (ftnlen)2, (ftnlen)2) == 0;
+ her = s_cmp(type__, "he", (ftnlen)2, (ftnlen)2) == 0;
+ sym = s_cmp(type__, "sy", (ftnlen)2, (ftnlen)2) == 0;
+ tri = s_cmp(type__, "tr", (ftnlen)2, (ftnlen)2) == 0;
+ upper = (her || sym || tri) && *(unsigned char *)uplo == 'U';
+ lower = (her || sym || tri) && *(unsigned char *)uplo == 'L';
+ unit = tri && *(unsigned char *)diag == 'U';
+
+/* Generate data in array A. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (gen || upper && i__ <= j || lower && i__ >= j) {
+ i__3 = i__ + j * a_dim1;
+ zbeg_(&z__2, reset);
+ z__1.r = z__2.r + transl->r, z__1.i = z__2.i + transl->i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ if (i__ != j) {
+/* Set some elements to zero */
+ if (*n > 3 && j == *n / 2) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ }
+ if (her) {
+ i__3 = j + i__ * a_dim1;
+ d_cnjg(&z__1, &a[i__ + j * a_dim1]);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ } else if (sym) {
+ i__3 = j + i__ * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i;
+ } else if (tri) {
+ i__3 = j + i__ * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ }
+ }
+ }
+/* L10: */
+ }
+ if (her) {
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ d__1 = a[i__3].r;
+ z__1.r = d__1, z__1.i = 0.;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ }
+ if (tri) {
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ z__1.r = a[i__3].r + 1., z__1.i = a[i__3].i + 0.;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ }
+ if (unit) {
+ i__2 = j + j * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+ }
+/* L20: */
+ }
+
+/* Store elements in array AS in data structure required by routine. */
+
+ if (s_cmp(type__, "ge", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ i__4 = i__ + j * a_dim1;
+ aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i;
+/* L30: */
+ }
+ i__2 = *lda;
+ for (i__ = *m + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ aa[i__3].r = -1e10, aa[i__3].i = 1e10;
+/* L40: */
+ }
+/* L50: */
+ }
+ } else if (s_cmp(type__, "he", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
+ "sy", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__, "tr", (ftnlen)
+ 2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (upper) {
+ ibeg = 1;
+ if (unit) {
+ iend = j - 1;
+ } else {
+ iend = j;
+ }
+ } else {
+ if (unit) {
+ ibeg = j + 1;
+ } else {
+ ibeg = j;
+ }
+ iend = *n;
+ }
+ i__2 = ibeg - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ aa[i__3].r = -1e10, aa[i__3].i = 1e10;
+/* L60: */
+ }
+ i__2 = iend;
+ for (i__ = ibeg; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ i__4 = i__ + j * a_dim1;
+ aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i;
+/* L70: */
+ }
+ i__2 = *lda;
+ for (i__ = iend + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ aa[i__3].r = -1e10, aa[i__3].i = 1e10;
+/* L80: */
+ }
+ if (her) {
+ jj = j + (j - 1) * *lda;
+ i__2 = jj;
+ i__3 = jj;
+ d__1 = aa[i__3].r;
+ z__1.r = d__1, z__1.i = -1e10;
+ aa[i__2].r = z__1.r, aa[i__2].i = z__1.i;
+ }
+/* L90: */
+ }
+ }
+ return 0;
+
+/* End of ZMAKE. */
+
+} /* zmake_ */
+
+/* Subroutine */ int zmmch_(char *transa, char *transb, integer *m, integer *
+ n, integer *kk, doublecomplex *alpha, doublecomplex *a, integer *lda,
+ doublecomplex *b, integer *ldb, doublecomplex *beta, doublecomplex *
+ c__, integer *ldc, doublecomplex *ct, doublereal *g, doublecomplex *
+ cc, integer *ldcc, doublereal *eps, doublereal *err, logical *fatal,
+ integer *nout, logical *mv)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS"
+ " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 "
+ " EXPECTED RE\002,\002SULT COMPUTED R"
+ "ESULT\002)";
+ static char fmt_9998[] = "(1x,i7,2(\002 (\002,g15.6,\002,\002,g15.6,"
+ "\002)\002))";
+ static char fmt_9997[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+
+ /* 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;
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal erri;
+ logical trana, tranb, ctrana, ctranb;
+
+ /* Fortran I/O blocks */
+ static cilist io___409 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___410 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___411 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___412 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* 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;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --ct;
+ --g;
+ cc_dim1 = *ldcc;
+ cc_offset = 1 + cc_dim1;
+ 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_;
+ io___409.ciunit = *nout;
+ s_wsfe(&io___409);
+ e_wsfe();
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*mv) {
+ io___410.ciunit = *nout;
+ s_wsfe(&io___410);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&ct[i__], (ftnlen)sizeof(doublereal));
+ do_fio(&c__2, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ } else {
+ io___411.ciunit = *nout;
+ s_wsfe(&io___411);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__2, (char *)&ct[i__], (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+/* L240: */
+ }
+ if (*n > 1) {
+ io___412.ciunit = *nout;
+ s_wsfe(&io___412);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L250:
+ return 0;
+
+
+/* End of ZMMCH. */
+
+} /* zmmch_ */
+
+logical lze_(doublecomplex *ri, doublecomplex *rj, integer *lr)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ logical ret_val;
+
+ /* Local variables */
+ 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 LZE. */
+
+} /* lze_ */
+
+logical lzeres_(char *type__, char *uplo, integer *m, integer *n,
+ doublecomplex *aa, doublecomplex *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 i__, j, ibeg, iend;
+ 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;
+ as -= as_offset;
+ aa_dim1 = *lda;
+ aa_offset = 1 + aa_dim1;
+ 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: */
+ }
+ }
+
+/* L60: */
+ ret_val = TRUE_;
+ goto L80;
+L70:
+ ret_val = FALSE_;
+L80:
+ return ret_val;
+
+/* End of LZERES. */
+
+} /* lzeres_ */
+
+/* Double Complex */ VOID zbeg_(doublecomplex * ret_val, logical *reset)
+{
+ /* System generated locals */
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Local variables */
+ static integer i__, j, ic, mi, mj;
+
+
+/* Generates complex numbers as pairs of random numbers uniformly */
+/* distributed between -0.5 and 0.5. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+ if (*reset) {
+/* Initialize local variables. */
+ mi = 891;
+ mj = 457;
+ i__ = 7;
+ j = 7;
+ ic = 0;
+ *reset = FALSE_;
+ }
+
+/* The sequence of values of I or J is bounded between 1 and 999. */
+/* If initial I or J = 1,2,3,6,7 or 9, the period will be 50. */
+/* If initial I or J = 4 or 8, the period will be 25. */
+/* If initial I or J = 5, the period will be 10. */
+/* IC is used to break up the period by skipping 1 value of I or J */
+/* in 6. */
+
+ ++ic;
+L10:
+ i__ *= mi;
+ j *= mj;
+ i__ -= i__ / 1000 * 1000;
+ j -= j / 1000 * 1000;
+ if (ic >= 5) {
+ ic = 0;
+ goto L10;
+ }
+ d__1 = (i__ - 500) / 1001.;
+ d__2 = (j - 500) / 1001.;
+ z__1.r = d__1, z__1.i = d__2;
+ ret_val->r = z__1.r, ret_val->i = z__1.i;
+ return ;
+
+/* End of ZBEG. */
+
+} /* zbeg_ */
+
+doublereal ddiff_(doublereal *x, doublereal *y)
+{
+ /* System generated locals */
+ doublereal ret_val;
+
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+ ret_val = *x - *y;
+ return ret_val;
+
+/* End of DDIFF. */
+
+} /* ddiff_ */
+
+/* Subroutine */ int zchk6_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nalf, doublecomplex *
+ alf, integer *nbet, doublecomplex *bet, integer *nmax, doublecomplex *
+ a, doublecomplex *aa, doublecomplex *as, doublecomplex *b,
+ doublecomplex *bb, doublecomplex *bs, doublecomplex *c__,
+ doublecomplex *cc, doublecomplex *cs, doublecomplex *ct, doublereal *
+ g, integer *iorder)
+{
+ /* Initialized data */
+
+ static char ich[3] = "NTC";
+ static char ishape[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
+ "TAKEN ON VALID CALL *******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
+ "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
+ "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
+ " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+ "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+ "ECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
+ "BER:\002)";
+
+ /* 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;
+ alist al__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int czgemmtr_(integer *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ integer i__, k, n, ia, ib, ma, mb, na, nb, nc, ik, in, is, ks, ns, ica,
+ icb, laa, lbb, lda, lcc, ldb, ldc;
+ doublecomplex als, bls;
+ doublereal err;
+ extern logical lze_(doublecomplex *, doublecomplex *, integer *);
+ doublecomplex beta;
+ integer ldas, ldbs, ldcs;
+ logical same, null;
+ char uplo[1];
+ doublecomplex alpha;
+ logical isame[13], trana, tranb;
+ extern /* Subroutine */ int zmake_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ logical *, doublecomplex *);
+ integer nargs;
+ logical reset;
+ char uplos[1];
+ extern /* Subroutine */ int zprcn8_(integer *, integer *, char *, integer
+ *, char *, char *, char *, integer *, integer *, doublecomplex *,
+ integer *, integer *, doublecomplex *, integer *);
+ char tranas[1], tranbs[1], transa[1], transb[1];
+ doublereal errmax;
+ extern /* Subroutine */ int zmmtch_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, doublereal *, doublecomplex *,
+ integer *, doublereal *, doublereal *, logical *, integer *,
+ logical *);
+ extern logical lzeres_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___468 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___471 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___473 = { 0, 0, 0, fmt_10000, 0 };
+ static cilist io___474 = { 0, 0, 0, fmt_10001, 0 };
+ static cilist io___475 = { 0, 0, 0, fmt_10002, 0 };
+ static cilist io___476 = { 0, 0, 0, fmt_10003, 0 };
+ static cilist io___477 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* Tests CGEMMTR. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 24-June-2024. */
+/* Martin Koehler, Max Planck Institute Magdeburg */
+
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+
+ nargs = 13;
+ 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 = (real) n <= 0.f;
+
+ i__2 = *nidim;
+ for (ik = 1; ik <= i__2; ++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 = 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);
+
+ 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);
+
+ 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;
+ for (is = 1; is <= 2; ++is) {
+ *(unsigned char *)uplo = *(unsigned char *)&
+ ishape[is - 1];
+
+/* Generate the matrix C. */
+
+ zmake_("ge", 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 *)tranas = *(unsigned char *)
+ transa;
+ *(unsigned char *)tranbs = *(unsigned char *)
+ transb;
+ 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;
+ 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) {
+ zprcn8_(ntra, &nc, sname, iorder, uplo,
+ transa, transb, &n, &k, &alpha, &
+ lda, &ldb, &beta, &ldc);
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ czgemmtr_(iorder, uplo, transa, transb, &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___468.ciunit = *nout;
+ s_wsfe(&io___468);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)uplo == *(
+ unsigned char *)uplos;
+ isame[1] = *(unsigned char *)transa == *(
+ unsigned char *)tranas;
+ isame[2] = *(unsigned char *)transb == *(
+ unsigned char *)tranbs;
+ 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", " ", &n, &n, &
+ cs[1], &cc[1], &ldc);
+ }
+ isame[12] = 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]) {
+ io___471.ciunit = *nout;
+ s_wsfe(&io___471);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+ if (! null) {
+
+/* Check the result. */
+
+ zmmtch_(uplo, transa, transb, &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;
+ }
+ }
+
+/* L45: */
+ }
+
+/* L50: */
+ }
+
+/* L60: */
+ }
+
+L70:
+ ;
+ }
+
+L80:
+ ;
+ }
+
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ if (*iorder == 0) {
+ io___473.ciunit = *nout;
+ s_wsfe(&io___473);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___474.ciunit = *nout;
+ s_wsfe(&io___474);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ } else {
+ if (*iorder == 0) {
+ io___475.ciunit = *nout;
+ s_wsfe(&io___475);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ if (*iorder == 1) {
+ io___476.ciunit = *nout;
+ s_wsfe(&io___476);
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ }
+ goto L130;
+
+L120:
+ io___477.ciunit = *nout;
+ s_wsfe(&io___477);
+ do_fio(&c__1, sname, (ftnlen)13);
+ e_wsfe();
+ zprcn8_(nout, &nc, sname, iorder, uplo, transa, transb, &n, &k, &alpha, &
+ lda, &ldb, &beta, &ldc);
+
+L130:
+ return 0;
+
+/* L9995: */
+
+/* End of ZCHK6. */
+
+} /* zchk6_ */
+
+/* Subroutine */ int zprcn8_(integer *nout, integer *nc, char *sname, integer
+ *iorder, char *uplo, char *transa, char *transb, integer *n, integer *
+ k, doublecomplex *alpha, integer *lda, integer *ldb, doublecomplex *
+ beta, integer *ldc)
+{
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
+ "a14,\002,\002,a14,\002,\002,a14,\002,\002)";
+ static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002"
+ ",f4.1,\002) , A,\002,i3,\002, B,\002,i3,\002, (\002,f4.1,\002"
+ ",\002,f4.1,\002) , C,\002,i3,\002).\002)";
+
+ /* Local variables */
+ char crc[14], cta[14], ctb[14], cuplo[14];
+
+ /* Fortran I/O blocks */
+ static cilist io___482 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___483 = { 0, 0, 0, fmt_9994, 0 };
+
+
+ if (*(unsigned char *)uplo == 'U') {
+ s_copy(cuplo, "CblasUpper", (ftnlen)14, (ftnlen)10);
+ } else {
+ s_copy(cuplo, "CblasLower", (ftnlen)14, (ftnlen)10);
+ }
+ 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);
+ }
+ io___482.ciunit = *nout;
+ s_wsfe(&io___482);
+ do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)13);
+ do_fio(&c__1, crc, (ftnlen)14);
+ do_fio(&c__1, cuplo, (ftnlen)14);
+ do_fio(&c__1, cta, (ftnlen)14);
+ do_fio(&c__1, ctb, (ftnlen)14);
+ e_wsfe();
+ io___483.ciunit = *nout;
+ s_wsfe(&io___483);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
+ e_wsfe();
+ return 0;
+} /* zprcn8_ */
+
+/* Subroutine */ int zmmtch_(char *uplo, char *transa, char *transb, integer *
+ n, integer *kk, doublecomplex *alpha, doublecomplex *a, integer *lda,
+ doublecomplex *b, integer *ldb, doublecomplex *beta, doublecomplex *
+ c__, integer *ldc, doublecomplex *ct, doublereal *g, doublecomplex *
+ cc, integer *ldcc, doublereal *eps, doublereal *err, logical *fatal,
+ integer *nout, logical *mv)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS"
+ " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 "
+ " EXPECTED RE\002,\002SULT COMPUTED R"
+ "ESULT\002)";
+ static char fmt_9998[] = "(1x,i7,2(\002 (\002,g15.6,\002,\002,g15.6,"
+ "\002)\002))";
+ static char fmt_9997[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+
+ /* 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;
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal erri;
+ logical trana, tranb, upper;
+ integer istop;
+ logical ctrana, ctranb;
+ integer istart;
+
+ /* Fortran I/O blocks */
+ static cilist io___495 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___496 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___497 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___498 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* Checks the results of the computational tests for GEMMTR. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 24-June-2024. */
+/* Martin Koehler, Max Planck Institute, Magdeburg */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --ct;
+ --g;
+ cc_dim1 = *ldcc;
+ cc_offset = 1 + cc_dim1;
+ cc -= cc_offset;
+
+ /* Function Body */
+ upper = *(unsigned char *)uplo == 'U';
+ 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';
+ istart = 1;
+ istop = *n;
+
+/* 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) {
+
+ if (upper) {
+ istart = 1;
+ istop = j;
+ } else {
+ istart = j;
+ istop = *n;
+ }
+ i__2 = istop;
+ for (i__ = istart; 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 = istop;
+ for (i__ = istart; 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 = istop;
+ for (i__ = istart; 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 = istop;
+ for (i__ = istart; 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 = istop;
+ for (i__ = istart; 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 = istop;
+ for (i__ = istart; 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 = istop;
+ for (i__ = istart; 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 = istop;
+ for (i__ = istart; 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 = istop;
+ for (i__ = istart; 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 = istop;
+ for (i__ = istart; 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 = istop;
+ for (i__ = istart; 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 = istop;
+ for (i__ = istart; 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_;
+ io___495.ciunit = *nout;
+ s_wsfe(&io___495);
+ e_wsfe();
+ i__1 = istop;
+ for (i__ = istart; i__ <= i__1; ++i__) {
+ if (*mv) {
+ io___496.ciunit = *nout;
+ s_wsfe(&io___496);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&ct[i__], (ftnlen)sizeof(doublereal));
+ do_fio(&c__2, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ } else {
+ io___497.ciunit = *nout;
+ s_wsfe(&io___497);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__2, (char *)&ct[i__], (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+/* L240: */
+ }
+ if (*n > 1) {
+ io___498.ciunit = *nout;
+ s_wsfe(&io___498);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L250:
+ return 0;
+
+
+/* End of ZMMTCH. */
+
+} /* zmmtch_ */
+
+/* Main program alias */ int zblat3_ () { MAIN__ (); return 0; }
From 030bfd1b34d1a615dd72aa6a8f3ba97a654e0773 Mon Sep 17 00:00:00 2001
From: Martin Kroeker <martin@ruby.chemie.uni-freiburg.de>
Date: Fri, 21 Mar 2025 09:21:16 +0100
Subject: [PATCH 08/17] Remove unused and conflicting declarations from the f2c
preamble
---
ctest/c_cblat3c.c | 161 ----------------------------------------------
ctest/c_dblat3c.c | 161 ----------------------------------------------
ctest/c_sblat3c.c | 161 ----------------------------------------------
ctest/c_zblat3c.c | 161 ----------------------------------------------
4 files changed, 644 deletions(-)
diff --git a/ctest/c_cblat3c.c b/ctest/c_cblat3c.c
index 48dbaf82f6..1735e2a90b 100644
--- a/ctest/c_cblat3c.c
+++ b/ctest/c_cblat3c.c
@@ -229,7 +229,6 @@ typedef struct Namelist Namelist;
#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
#define sig_die(s, kill) { exit(1); }
#define s_stop(s, n) {exit(0);}
-static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
#define z_abs(z) (cabs(Cd(z)))
#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
@@ -237,8 +236,6 @@ static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
#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++ */
@@ -346,164 +343,6 @@ static integer pow_ii(integer x, integer n) {
}
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;
-}
-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)
-*/
-
-
-
-/* -- translated by f2c (version 20200916).
- You must link the resulting object file with libf2c:
- on Microsoft Windows system, link with libf2c.lib;
- on Linux or Unix systems, link with .../path/to/libf2c.a -lm
- or, if you install libf2c.a in a standard place, with -lf2c -lm
- -- in that order, at the end of the command line, as in
- cc *.o -lf2c -lm
- Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
- http://www.netlib.org/f2c/libf2c.zip
-*/
-
-
/* Common Block Declarations */
diff --git a/ctest/c_dblat3c.c b/ctest/c_dblat3c.c
index 2dea060673..eeb65e675b 100644
--- a/ctest/c_dblat3c.c
+++ b/ctest/c_dblat3c.c
@@ -229,7 +229,6 @@ typedef struct Namelist Namelist;
#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
#define sig_die(s, kill) { exit(1); }
#define s_stop(s, n) {exit(0);}
-static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
#define z_abs(z) (cabs(Cd(z)))
#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
@@ -237,8 +236,6 @@ static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
#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++ */
@@ -346,164 +343,6 @@ static integer pow_ii(integer x, integer n) {
}
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;
-}
-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)
-*/
-
-
-
-/* -- translated by f2c (version 20200916).
- You must link the resulting object file with libf2c:
- on Microsoft Windows system, link with libf2c.lib;
- on Linux or Unix systems, link with .../path/to/libf2c.a -lm
- or, if you install libf2c.a in a standard place, with -lf2c -lm
- -- in that order, at the end of the command line, as in
- cc *.o -lf2c -lm
- Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
- http://www.netlib.org/f2c/libf2c.zip
-*/
-
-
/* Common Block Declarations */
diff --git a/ctest/c_sblat3c.c b/ctest/c_sblat3c.c
index 31241f389c..83b253585f 100644
--- a/ctest/c_sblat3c.c
+++ b/ctest/c_sblat3c.c
@@ -229,7 +229,6 @@ typedef struct Namelist Namelist;
#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
#define sig_die(s, kill) { exit(1); }
#define s_stop(s, n) {exit(0);}
-static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
#define z_abs(z) (cabs(Cd(z)))
#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
@@ -237,8 +236,6 @@ static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
#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++ */
@@ -346,164 +343,6 @@ static integer pow_ii(integer x, integer n) {
}
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;
-}
-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)
-*/
-
-
-
-/* -- translated by f2c (version 20200916).
- You must link the resulting object file with libf2c:
- on Microsoft Windows system, link with libf2c.lib;
- on Linux or Unix systems, link with .../path/to/libf2c.a -lm
- or, if you install libf2c.a in a standard place, with -lf2c -lm
- -- in that order, at the end of the command line, as in
- cc *.o -lf2c -lm
- Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
- http://www.netlib.org/f2c/libf2c.zip
-*/
-
-
/* Common Block Declarations */
diff --git a/ctest/c_zblat3c.c b/ctest/c_zblat3c.c
index 58c8cb8c84..ce66fd4fd3 100644
--- a/ctest/c_zblat3c.c
+++ b/ctest/c_zblat3c.c
@@ -229,7 +229,6 @@ typedef struct Namelist Namelist;
#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
#define sig_die(s, kill) { exit(1); }
#define s_stop(s, n) {exit(0);}
-static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
#define z_abs(z) (cabs(Cd(z)))
#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
@@ -237,8 +236,6 @@ static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
#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++ */
@@ -346,164 +343,6 @@ static integer pow_ii(integer x, integer n) {
}
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;
-}
-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)
-*/
-
-
-
-/* -- translated by f2c (version 20200916).
- You must link the resulting object file with libf2c:
- on Microsoft Windows system, link with libf2c.lib;
- on Linux or Unix systems, link with .../path/to/libf2c.a -lm
- or, if you install libf2c.a in a standard place, with -lf2c -lm
- -- in that order, at the end of the command line, as in
- cc *.o -lf2c -lm
- Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
-
- http://www.netlib.org/f2c/libf2c.zip
-*/
-
-
/* Common Block Declarations */
From 13aa7d81d68cc1e6a36be39b7fbebadc8d15a490 Mon Sep 17 00:00:00 2001
From: Martin Kroeker <martin@ruby.chemie.uni-freiburg.de>
Date: Sun, 11 May 2025 18:20:59 +0200
Subject: [PATCH 09/17] Update c_sblat3c.c
---
ctest/c_sblat3c.c | 8 ++------
1 file changed, 2 insertions(+), 6 deletions(-)
diff --git a/ctest/c_sblat3c.c b/ctest/c_sblat3c.c
index 83b253585f..bf2f871f2c 100644
--- a/ctest/c_sblat3c.c
+++ b/ctest/c_sblat3c.c
@@ -2220,9 +2220,7 @@ static logical c_false = FALSE_;
if (*trace) {
sprcn3_(ntra, &nc, sname, iorder,
side, uplo, transa, diag, &m,
- &n, &alpha, &lda, &ldb, (
- ftnlen)13, (ftnlen)1, (ftnlen)
- 1, (ftnlen)1, (ftnlen)1);
+ &n, &alpha, &lda, &ldb);
}
if (*rewi) {
al__1.aerr = 0;
@@ -2237,9 +2235,7 @@ static logical c_false = FALSE_;
if (*trace) {
sprcn3_(ntra, &nc, sname, iorder,
side, uplo, transa, diag, &m,
- &n, &alpha, &lda, &ldb, (
- ftnlen)13, (ftnlen)1, (ftnlen)
- 1, (ftnlen)1, (ftnlen)1);
+ &n, &alpha, &lda, &ldb);
}
if (*rewi) {
al__1.aerr = 0;
From 11004a77d7f1eeb6e407068bdcdc4e61cf282404 Mon Sep 17 00:00:00 2001
From: Martin Kroeker <martin@ruby.chemie.uni-freiburg.de>
Date: Sun, 11 May 2025 18:27:31 +0200
Subject: [PATCH 10/17] Update c_dblat3c.c
---
ctest/c_dblat3c.c | 8 ++------
1 file changed, 2 insertions(+), 6 deletions(-)
diff --git a/ctest/c_dblat3c.c b/ctest/c_dblat3c.c
index eeb65e675b..3bbdb2bbb7 100644
--- a/ctest/c_dblat3c.c
+++ b/ctest/c_dblat3c.c
@@ -2234,9 +2234,7 @@ static logical c_false = FALSE_;
if (*trace) {
dprcn3_(ntra, &nc, sname, iorder,
side, uplo, transa, diag, &m,
- &n, &alpha, &lda, &ldb, (
- ftnlen)13, (ftnlen)1, (ftnlen)
- 1, (ftnlen)1, (ftnlen)1);
+ &n, &alpha, &lda, &ldb);
}
if (*rewi) {
al__1.aerr = 0;
@@ -2251,9 +2249,7 @@ static logical c_false = FALSE_;
if (*trace) {
dprcn3_(ntra, &nc, sname, iorder,
side, uplo, transa, diag, &m,
- &n, &alpha, &lda, &ldb, (
- ftnlen)13, (ftnlen)1, (ftnlen)
- 1, (ftnlen)1, (ftnlen)1);
+ &n, &alpha, &lda, &ldb);
}
if (*rewi) {
al__1.aerr = 0;
From 47f7d36942b09961f4a017150b55d8071f244a9b Mon Sep 17 00:00:00 2001
From: Martin Kroeker <martin@ruby.chemie.uni-freiburg.de>
Date: Sun, 11 May 2025 18:28:35 +0200
Subject: [PATCH 11/17] Update c_cblat3c.c
---
ctest/c_cblat3c.c | 8 ++------
1 file changed, 2 insertions(+), 6 deletions(-)
diff --git a/ctest/c_cblat3c.c b/ctest/c_cblat3c.c
index 1735e2a90b..f6719b6c28 100644
--- a/ctest/c_cblat3c.c
+++ b/ctest/c_cblat3c.c
@@ -2287,9 +2287,7 @@ static logical c_false = FALSE_;
if (*trace) {
cprcn3_(ntra, &nc, sname, iorder,
side, uplo, transa, diag, &m,
- &n, &alpha, &lda, &ldb, (
- ftnlen)13, (ftnlen)1, (ftnlen)
- 1, (ftnlen)1, (ftnlen)1);
+ &n, &alpha, &lda, &ldb);
}
if (*rewi) {
al__1.aerr = 0;
@@ -2304,9 +2302,7 @@ static logical c_false = FALSE_;
if (*trace) {
cprcn3_(ntra, &nc, sname, iorder,
side, uplo, transa, diag, &m,
- &n, &alpha, &lda, &ldb, (
- ftnlen)13, (ftnlen)1, (ftnlen)
- 1, (ftnlen)1, (ftnlen)1);
+ &n, &alpha, &lda, &ldb);
}
if (*rewi) {
al__1.aerr = 0;
From b167ae1baed73ddacddbad962ab294cc31683de6 Mon Sep 17 00:00:00 2001
From: Martin Kroeker <martin@ruby.chemie.uni-freiburg.de>
Date: Sun, 11 May 2025 18:29:33 +0200
Subject: [PATCH 12/17] Update c_zblat3c.c
---
ctest/c_zblat3c.c | 8 ++------
1 file changed, 2 insertions(+), 6 deletions(-)
diff --git a/ctest/c_zblat3c.c b/ctest/c_zblat3c.c
index ce66fd4fd3..cee0ed1671 100644
--- a/ctest/c_zblat3c.c
+++ b/ctest/c_zblat3c.c
@@ -2307,9 +2307,7 @@ static logical c_false = FALSE_;
if (*trace) {
zprcn3_(ntra, &nc, sname, iorder,
side, uplo, transa, diag, &m,
- &n, &alpha, &lda, &ldb, (
- ftnlen)13, (ftnlen)1, (ftnlen)
- 1, (ftnlen)1, (ftnlen)1);
+ &n, &alpha, &lda, &ldb);
}
if (*rewi) {
al__1.aerr = 0;
@@ -2324,9 +2322,7 @@ static logical c_false = FALSE_;
if (*trace) {
zprcn3_(ntra, &nc, sname, iorder,
side, uplo, transa, diag, &m,
- &n, &alpha, &lda, &ldb, (
- ftnlen)13, (ftnlen)1, (ftnlen)
- 1, (ftnlen)1, (ftnlen)1);
+ &n, &alpha, &lda, &ldb);
}
if (*rewi) {
al__1.aerr = 0;
From 4eb65e25fe18db5c6ea67f9835e87d2404fa4da5 Mon Sep 17 00:00:00 2001
From: Martin Kroeker <martin@ruby.chemie.uni-freiburg.de>
Date: Sun, 11 May 2025 14:29:49 -0700
Subject: [PATCH 13/17] Fix up f2c conversions
---
ctest/c_cblat3c.c | 1555 +++++++++--------------------------
ctest/c_dblat3c.c | 1838 +++++++++++-------------------------------
ctest/c_sblat3c.c | 1903 ++++++++++++-------------------------------
ctest/c_zblat3c.c | 1967 ++++++++++++---------------------------------
4 files changed, 1883 insertions(+), 5380 deletions(-)
diff --git a/ctest/c_cblat3c.c b/ctest/c_cblat3c.c
index f6719b6c28..f2fe2fce42 100644
--- a/ctest/c_cblat3c.c
+++ b/ctest/c_cblat3c.c
@@ -240,109 +240,6 @@ typedef struct Namelist Namelist;
/* 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
-
-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;
-}
/* Common Block Declarations */
@@ -363,73 +260,25 @@ struct {
static complex c_b1 = {0.f,0.f};
static complex c_b2 = {1.f,0.f};
-static integer c__9 = 9;
static integer c__1 = 1;
-static integer c__3 = 3;
-static integer c__8 = 8;
-static integer c__4 = 4;
static integer c__65 = 65;
-static integer c__7 = 7;
static integer c__6 = 6;
-static integer c__2 = 2;
static real c_b91 = 1.f;
static logical c_true = TRUE_;
static integer c__0 = 0;
static logical c_false = FALSE_;
-/* Main program */ int main(void)
+int /* Main program */ main(void)
{
/* Initialized data */
- static char snames[13*10] = "cblas_cgemm " "cblas_chemm " "cblas_csymm"
- " " "cblas_ctrmm " "cblas_ctrsm " "cblas_cherk " "cblas_csyrk"
- " " "cblas_cher2k " "cblas_csyr2k " "cblas_cgemmtr";
-
- /* Format strings */
- static char fmt_9997[] = "(\002 NUMBER OF VALUES OF \002,a,\002 IS LESS "
- "THAN 1 OR GREATER \002,\002THAN \002,i2)";
- static char fmt_9996[] = "(\002 VALUE OF N IS LESS THAN 0 OR GREATER THA"
- "N \002,i2)";
- static char fmt_9995[] = "(\002 TESTS OF THE COMPLEX LEVEL 3 BL"
- "AS\002,//\002 THE F\002,\002OLLOWING PARAMETER VALUES WILL BE US"
- "ED:\002)";
- static char fmt_9994[] = "(\002 FOR N \002,9i6)";
- static char fmt_9993[] = "(\002 FOR ALPHA \002,7(\002(\002,f4"
- ".1,\002,\002,f4.1,\002) \002,:))";
- static char fmt_9992[] = "(\002 FOR BETA \002,7(\002(\002,f4"
- ".1,\002,\002,f4.1,\002) \002,:))";
- static char fmt_9984[] = "(\002 ERROR-CALL MYEXITS WILL NOT BE TESTED"
- "\002)";
- static char fmt_9999[] = "(\002 ROUTINES PASS COMPUTATIONAL TESTS IF TES"
- "T RATIO IS LES\002,\002S THAN\002,f8.2)";
- static char fmt_10002[] = "(\002 COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS"
- " ARE TESTED\002)";
- static char fmt_10001[] = "(\002 ROW-MAJOR DATA LAYOUT IS TESTED\002)";
- static char fmt_10000[] = "(\002 COLUMN-MAJOR DATA LAYOUT IS TESTED\002)";
- static char fmt_9988[] = "(a13,l2)";
- static char fmt_9990[] = "(\002 SUBPROGRAM NAME \002,a13,\002 NOT RECOGN"
- "IZED\002,/\002 ******* T\002,\002ESTS ABANDONED *******\002)";
- static char fmt_9998[] = "(\002 RELATIVE MACHINE PRECISION IS TAKEN TO"
- " BE\002,1p,e9.1)";
- static char fmt_9989[] = "(\002 ERROR IN CMMCH - IN-LINE DOT PRODUCTS A"
- "RE BEING EVALU\002,\002ATED WRONGLY.\002,/\002 CMMCH WAS CALLED "
- "WITH TRANSA = \002,a1,\002AND TRANSB = \002,a1,/\002 AND RETURNE"
- "D SAME = \002,l1,\002 AND \002,\002 ERR = \002,f12.3,\002.\002,"
- "/\002 THIS MAY BE DUE TO FAULTS IN THE \002,\002ARITHMETIC OR TH"
- "E COMPILER.\002,/\002 ******* TESTS ABANDONED \002,\002******"
- "*\002)";
- static char fmt_9987[] = "(1x,a13,\002 WAS NOT TESTED\002)";
- static char fmt_9986[] = "(/\002 END OF TESTS\002)";
- static char fmt_9985[] = "(/\002 ******* FATAL ERROR - TESTS ABANDONED *"
- "******\002)";
- static char fmt_9991[] = "(\002 AMEND DATA FILE OR INCREASE ARRAY SIZES "
- "IN PROGRAM\002,/\002 ******* TESTS ABANDONED *******\002)";
+ static char snames[10][14] = {"cblas_cgemm ", "cblas_chemm ", "cblas_csymm ",
+ "cblas_ctrmm ", "cblas_ctrsm ", "cblas_cherk ", "cblas_csyrk ",
+ "cblas_cher2k ", "cblas_csyr2k ", "cblas_cgemmtr"};
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
real r__1;
- olist o__1;
- cllist cl__1;
/* Local variables */
complex c__[4225] /* was [65][65] */;
@@ -490,52 +339,6 @@ static logical c_false = FALSE_;
integer layout;
logical ltestt, tsterr;
- /* Fortran I/O blocks */
- static cilist io___2 = { 0, 5, 0, 0, 0 };
- static cilist io___4 = { 0, 5, 0, 0, 0 };
- static cilist io___7 = { 0, 5, 0, 0, 0 };
- static cilist io___9 = { 0, 5, 0, 0, 0 };
- static cilist io___11 = { 0, 5, 0, 0, 0 };
- static cilist io___13 = { 0, 5, 0, 0, 0 };
- static cilist io___15 = { 0, 5, 0, 0, 0 };
- static cilist io___17 = { 0, 5, 0, 0, 0 };
- static cilist io___19 = { 0, 6, 0, fmt_9997, 0 };
- static cilist io___20 = { 0, 5, 0, 0, 0 };
- static cilist io___23 = { 0, 6, 0, fmt_9996, 0 };
- static cilist io___24 = { 0, 5, 0, 0, 0 };
- static cilist io___26 = { 0, 6, 0, fmt_9997, 0 };
- static cilist io___27 = { 0, 5, 0, 0, 0 };
- static cilist io___29 = { 0, 5, 0, 0, 0 };
- static cilist io___31 = { 0, 6, 0, fmt_9997, 0 };
- static cilist io___32 = { 0, 5, 0, 0, 0 };
- static cilist io___34 = { 0, 6, 0, fmt_9995, 0 };
- static cilist io___35 = { 0, 6, 0, fmt_9994, 0 };
- static cilist io___36 = { 0, 6, 0, fmt_9993, 0 };
- static cilist io___37 = { 0, 6, 0, fmt_9992, 0 };
- static cilist io___38 = { 0, 6, 0, 0, 0 };
- static cilist io___39 = { 0, 6, 0, fmt_9984, 0 };
- static cilist io___40 = { 0, 6, 0, 0, 0 };
- static cilist io___41 = { 0, 6, 0, fmt_9999, 0 };
- static cilist io___42 = { 0, 6, 0, 0, 0 };
- static cilist io___45 = { 0, 6, 0, fmt_10002, 0 };
- static cilist io___46 = { 0, 6, 0, fmt_10001, 0 };
- static cilist io___47 = { 0, 6, 0, fmt_10000, 0 };
- static cilist io___48 = { 0, 6, 0, 0, 0 };
- static cilist io___50 = { 0, 5, 1, fmt_9988, 0 };
- static cilist io___53 = { 0, 6, 0, fmt_9990, 0 };
- static cilist io___55 = { 0, 6, 0, fmt_9998, 0 };
- static cilist io___68 = { 0, 6, 0, fmt_9989, 0 };
- static cilist io___69 = { 0, 6, 0, fmt_9989, 0 };
- static cilist io___70 = { 0, 6, 0, fmt_9989, 0 };
- static cilist io___71 = { 0, 6, 0, fmt_9989, 0 };
- static cilist io___73 = { 0, 6, 0, 0, 0 };
- static cilist io___74 = { 0, 6, 0, fmt_9987, 0 };
- static cilist io___75 = { 0, 6, 0, 0, 0 };
- static cilist io___82 = { 0, 6, 0, fmt_9986, 0 };
- static cilist io___83 = { 0, 6, 0, fmt_9985, 0 };
- static cilist io___84 = { 0, 6, 0, fmt_9991, 0 };
-
-
/* Test program for the COMPLEX Level 3 Blas. */
@@ -587,16 +390,21 @@ static logical c_false = FALSE_;
infoc_1.noutc = 6;
/* Read name and unit number for snapshot output file and open file. */
-
- s_rsle(&io___2);
- do_lio(&c__9, &c__1, snaps, (ftnlen)32);
- e_rsle();
- s_rsle(&io___4);
- do_lio(&c__3, &c__1, (char *)&ntra, (ftnlen)sizeof(integer));
- e_rsle();
+ char tmpchar;
+ char line[80];
+
+ fgets(line,80,stdin);
+ sscanf(line,"'%s'",snaps);
+ fgets(line,80,stdin);
+#ifdef USE64BITINT
+ sscanf(line,"%ld",&ntra);
+#else
+ sscanf(line,"%d",&ntra);
+#endif
trace = ntra >= 0;
if (trace) {
- o__1.oerr = 0;
+/*
+ o__1.oerr = 0;
o__1.ounit = ntra;
o__1.ofnmlen = 32;
o__1.ofnm = snaps;
@@ -606,146 +414,122 @@ static logical c_false = FALSE_;
o__1.ofm = 0;
o__1.oblnk = 0;
f_open(&o__1);
+*/
}
/* Read the flag that directs rewinding of the snapshot file. */
- s_rsle(&io___7);
- do_lio(&c__8, &c__1, (char *)&rewi, (ftnlen)sizeof(logical));
- e_rsle();
- rewi = rewi && trace;
+ fgets(line,80,stdin);
+ sscanf(line,"%d",&rewi);
+ rewi = rewi && trace;
/* Read the flag that directs stopping on any failure. */
- s_rsle(&io___9);
- do_lio(&c__8, &c__1, (char *)&sfatal, (ftnlen)sizeof(logical));
- e_rsle();
+ fgets(line,80,stdin);
+ sscanf(line,"%c",&tmpchar);
+ 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. */
- s_rsle(&io___11);
- do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
- e_rsle();
+ tsterr=FALSE_;
+ if (tmpchar=='T')tsterr=TRUE_;
/* Read the flag that indicates whether row-major data layout to be tested. */
- s_rsle(&io___13);
- do_lio(&c__3, &c__1, (char *)&layout, (ftnlen)sizeof(integer));
- e_rsle();
+ fgets(line,80,stdin);
+ sscanf(line,"%d",&layout);
/* Read the threshold value of the test ratio */
- s_rsle(&io___15);
- do_lio(&c__4, &c__1, (char *)&thresh, (ftnlen)sizeof(real));
- e_rsle();
+ fgets(line,80,stdin);
+ sscanf(line,"%f",&thresh);
+
/* Read and check the parameter values for the tests. */
/* Values of N */
- s_rsle(&io___17);
- do_lio(&c__3, &c__1, (char *)&nidim, (ftnlen)sizeof(integer));
- e_rsle();
+ fgets(line,80,stdin);
+#ifdef USE64BITINT
+ sscanf(line,"%ld",&nidim);
+#else
+ sscanf(line,"%d",&nidim);
+#endif
+
if (nidim < 1 || nidim > 9) {
- s_wsfe(&io___19);
- do_fio(&c__1, "N", (ftnlen)1);
- do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
- e_wsfe();
- goto L220;
- }
- s_rsle(&io___20);
- i__1 = nidim;
- for (i__ = 1; i__ <= i__1; ++i__) {
- do_lio(&c__3, &c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
+ fprintf(stderr,"NUMBER OF VALUES OF N IS LESS THAN 1 OR GREATER THAN 9");
+ goto L220;
}
- e_rsle();
+ fgets(line,80,stdin);
+#ifdef USE64BITINT
+ sscanf(line,"%ld %ld %ld %ld %ld %ld %ld %ld %ld",&idim[0],&idim[1],&idim[2],
+ &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]);
+#else
+ sscanf(line,"%d %d %d %d %d %d %d %d %d",&idim[0],&idim[1],&idim[2],
+ &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]);
+#endif
i__1 = nidim;
for (i__ = 1; i__ <= i__1; ++i__) {
- if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) {
- s_wsfe(&io___23);
- do_fio(&c__1, (char *)&c__65, (ftnlen)sizeof(integer));
- e_wsfe();
- goto L220;
- }
+ 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 */
- s_rsle(&io___24);
- do_lio(&c__3, &c__1, (char *)&nalf, (ftnlen)sizeof(integer));
- e_rsle();
+ fgets(line,80,stdin);
+#ifdef USE64BITINT
+ sscanf(line,"%ld",&nalf);
+#else
+ sscanf(line,"%d",&nalf);
+#endif
if (nalf < 1 || nalf > 7) {
- s_wsfe(&io___26);
- do_fio(&c__1, "ALPHA", (ftnlen)5);
- do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
- e_wsfe();
- goto L220;
- }
- s_rsle(&io___27);
- i__1 = nalf;
- for (i__ = 1; i__ <= i__1; ++i__) {
- do_lio(&c__6, &c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(complex));
+ fprintf(stderr,"NUMBER OF VALUES OF ALPHA IS LESS THAN 0 OR GREATER THAN 7\n");
+ goto L220;
}
- e_rsle();
+ 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 */
- s_rsle(&io___29);
- do_lio(&c__3, &c__1, (char *)&nbet, (ftnlen)sizeof(integer));
- e_rsle();
- if (nbet < 1 || nbet > 7) {
- s_wsfe(&io___31);
- do_fio(&c__1, "BETA", (ftnlen)4);
- do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
- e_wsfe();
+ fgets(line,80,stdin);
+#ifdef USE64BITINT
+ sscanf(line,"%ld",&nbet);
+#else
+ sscanf(line,"%d",&nbet);
+#endif
+ if (nalf < 1 || nbet > 7) {
+ fprintf(stderr,"VALUE OF BETA IS LESS THAN 0 OR GREATER THAN 7\n");
goto L220;
}
- s_rsle(&io___32);
- i__1 = nbet;
- for (i__ = 1; i__ <= i__1; ++i__) {
- do_lio(&c__6, &c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(complex));
- }
- e_rsle();
+ 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. */
- s_wsfe(&io___34);
- e_wsfe();
- s_wsfe(&io___35);
- i__1 = nidim;
- for (i__ = 1; i__ <= i__1; ++i__) {
- do_fio(&c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
- }
- e_wsfe();
- s_wsfe(&io___36);
- i__1 = nalf;
- for (i__ = 1; i__ <= i__1; ++i__) {
- do_fio(&c__2, (char *)&alf[i__ - 1], (ftnlen)sizeof(real));
- }
- e_wsfe();
- s_wsfe(&io___37);
- i__1 = nbet;
- for (i__ = 1; i__ <= i__1; ++i__) {
- do_fio(&c__2, (char *)&bet[i__ - 1], (ftnlen)sizeof(real));
- }
- e_wsfe();
+ 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) {
- s_wsle(&io___38);
- e_wsle();
- s_wsfe(&io___39);
- e_wsfe();
+ printf(" ERROR-EXITS WILL NOT BE TESTED\n");
}
- s_wsle(&io___40);
- e_wsle();
- s_wsfe(&io___41);
- do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(real));
- e_wsfe();
- s_wsle(&io___42);
- e_wsle();
+ 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_;
- s_wsfe(&io___45);
- e_wsfe();
+ printf("COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED\n");
} else if (layout == 1) {
rorder = TRUE_;
- s_wsfe(&io___46);
- e_wsfe();
+ printf("ROW-MAJOR DATA LAYOUT IS TESTED\n");
} else if (layout == 0) {
corder = TRUE_;
- s_wsfe(&io___47);
- e_wsfe();
+ printf("COLUMN-MAJOR DATA LAYOUT IS TESTED\n");
}
- s_wsle(&io___48);
- e_wsle();
/* Read names of subroutines and flags which indicate */
/* whether they are to be tested. */
@@ -755,43 +539,35 @@ static logical c_false = FALSE_;
/* L20: */
}
L30:
- i__1 = s_rsfe(&io___50);
- if (i__1 != 0) {
- goto L60;
- }
- i__1 = do_fio(&c__1, snamet, (ftnlen)13);
- if (i__1 != 0) {
- goto L60;
- }
- i__1 = do_fio(&c__1, (char *)<estt, (ftnlen)sizeof(logical));
- if (i__1 != 0) {
+ if (! fgets(line,80,stdin)) {
goto L60;
}
- i__1 = e_rsfe();
- if (i__1 != 0) {
+ i__1 = sscanf(line,"%13c %c",snamet,&tmpchar);
+ ltestt=FALSE_;
+ if (tmpchar=='T')ltestt=TRUE_;
+ if (i__1 < 2) {
goto L60;
}
for (i__ = 1; i__ <= 10; ++i__) {
- if (s_cmp(snamet, snames + (i__ - 1) * 13, (ftnlen)13, (ftnlen)13) ==
+ if (s_cmp(snamet, snames[i__ - 1] , (ftnlen)13, (ftnlen)13) ==
0) {
goto L50;
}
/* L40: */
}
- s_wsfe(&io___53);
- do_fio(&c__1, snamet, (ftnlen)13);
- e_wsfe();
- s_stop("", (ftnlen)0);
+ 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;
@@ -804,9 +580,7 @@ static logical c_false = FALSE_;
goto L70;
L80:
eps += eps;
- s_wsfe(&io___55);
- do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real));
- e_wsfe();
+ printf("RELATIVE MACHINE PRECISION IS TAKEN TO BE %9.1g\n",eps);
/* Check the reliability of CMMCH using exact data. */
@@ -846,13 +620,12 @@ static logical c_false = FALSE_;
&c__6, &c_true);
same = lce_(cc, ct, &n);
if (! same || err != 0.f) {
- s_wsfe(&io___68);
- do_fio(&c__1, transa, (ftnlen)1);
- do_fio(&c__1, transb, (ftnlen)1);
- do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
- do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
- e_wsfe();
- s_stop("", (ftnlen)0);
+ 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], &
@@ -860,13 +633,12 @@ static logical c_false = FALSE_;
&c__6, &c_true);
same = lce_(cc, ct, &n);
if (! same || err != 0.f) {
- s_wsfe(&io___69);
- do_fio(&c__1, transa, (ftnlen)1);
- do_fio(&c__1, transb, (ftnlen)1);
- do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
- do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
- e_wsfe();
- s_stop("", (ftnlen)0);
+ 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) {
@@ -892,13 +664,12 @@ static logical c_false = FALSE_;
&c__6, &c_true);
same = lce_(cc, ct, &n);
if (! same || err != 0.f) {
- s_wsfe(&io___70);
- do_fio(&c__1, transa, (ftnlen)1);
- do_fio(&c__1, transb, (ftnlen)1);
- do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
- do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
- e_wsfe();
- s_stop("", (ftnlen)0);
+ 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], &
@@ -906,33 +677,26 @@ static logical c_false = FALSE_;
&c__6, &c_true);
same = lce_(cc, ct, &n);
if (! same || err != 0.f) {
- s_wsfe(&io___71);
- do_fio(&c__1, transa, (ftnlen)1);
- do_fio(&c__1, transb, (ftnlen)1);
- do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
- do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
- e_wsfe();
- s_stop("", (ftnlen)0);
+ 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 <= 10; ++isnum) {
- s_wsle(&io___73);
- e_wsle();
if (! ltest[isnum - 1]) {
/* Subprogram is not to be tested. */
- s_wsfe(&io___74);
- do_fio(&c__1, snames + (isnum - 1) * 13, (ftnlen)13);
- e_wsfe();
+ printf("%12s WAS NOT TESTED\n",snames[isnum-1]);
} else {
- s_copy(srnamc_1.srnamt, snames + (isnum - 1) * 13, (ftnlen)13, (
+ s_copy(srnamc_1.srnamt, snames [isnum - 1] , (ftnlen)13, (
ftnlen)13);
/* Test error exits. */
if (tsterr) {
- cc3chke_(snames + (isnum - 1) * 13);
- s_wsle(&io___75);
- e_wsle();
+ cc3chke_(snames[isnum - 1]);
}
/* Test computations. */
infoc_1.infot = 0;
@@ -953,13 +717,13 @@ static logical c_false = FALSE_;
/* Test CGEMM, 01. */
L140:
if (corder) {
- cchk1_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
@@ -968,13 +732,13 @@ static logical c_false = FALSE_;
/* Test CHEMM, 02, CSYMM, 03. */
L150:
if (corder) {
- cchk2_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
@@ -983,13 +747,13 @@ static logical c_false = FALSE_;
/* Test CTRMM, 04, CTRSM, 05. */
L160:
if (corder) {
- cchk3_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
@@ -998,13 +762,13 @@ static logical c_false = FALSE_;
/* Test CHERK, 06, CSYRK, 07. */
L170:
if (corder) {
- cchk4_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
@@ -1013,13 +777,13 @@ static logical c_false = FALSE_;
/* Test CHER2K, 08, CSYR2K, 09. */
L180:
if (corder) {
- cchk5_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
@@ -1028,13 +792,13 @@ static logical c_false = FALSE_;
/* Test CGEMMTR, 10. */
L185:
if (corder) {
- cchk6_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ cchk6_(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) {
- cchk6_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ cchk6_(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);
@@ -1048,32 +812,32 @@ static logical c_false = FALSE_;
}
/* L200: */
}
- s_wsfe(&io___82);
- e_wsfe();
+ printf("\nEND OF TESTS\n");
goto L230;
L210:
- s_wsfe(&io___83);
- e_wsfe();
+ printf("\n****** FATAL ERROR - TESTS ABANDONED ******\n");
goto L230;
L220:
- s_wsfe(&io___84);
- e_wsfe();
+ 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.cerr = 0;
cl__1.cunit = 6;
cl__1.csta = 0;
f_clos(&cl__1);
- s_stop("", (ftnlen)0);
-
+ s_stop("", (ftnlen)0);*/
+ exit(0);
/* End of CBLAT3. */
@@ -1091,30 +855,9 @@ static logical c_false = FALSE_;
static char ich[3] = "NTC";
- /* Format strings */
- static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
- "TAKEN ON VALID CALL *******\002)";
- static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
- " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
- static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
- "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
- " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
- "BER:\002)";
-
/* 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;
- alist al__1;
/* Local variables */
integer i__, k, m, n, ia, ib, ma, mb, na, nb, nc, ik, im, in, ks, ms, ns,
@@ -1138,24 +881,15 @@ static logical c_false = FALSE_;
logical reset;
extern /* Subroutine */ int cprcn1_(integer *, integer *, char *, integer
*, char *, char *, integer *, integer *, integer *, complex *,
- integer *, integer *, complex *, integer *), ccgemm_(integer *, char *, char *, integer *, integer *,
- integer *, complex *, complex *, integer *, complex *, integer *,
- complex *, complex *, integer *);
+ integer *, integer *, complex *, integer *);
+ extern /* Subroutine */ int ccgemm_(integer *, char *, char *, integer *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *, complex *, complex *, integer *);
extern logical lceres_(char *, char *, integer *, integer *, complex *,
complex *, integer *);
char tranas[1], tranbs[1], transa[1], transb[1];
real errmax;
-
- /* Fortran I/O blocks */
- static cilist io___128 = { 0, 0, 0, fmt_9994, 0 };
- static cilist io___131 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___133 = { 0, 0, 0, fmt_10000, 0 };
- static cilist io___134 = { 0, 0, 0, fmt_10001, 0 };
- static cilist io___135 = { 0, 0, 0, fmt_10002, 0 };
- static cilist io___136 = { 0, 0, 0, fmt_10003, 0 };
- static cilist io___137 = { 0, 0, 0, fmt_9996, 0 };
-
-
+ extern logical lce_(complex *, complex *, integer *);
/* Tests CGEMM. */
@@ -1342,9 +1076,9 @@ static logical c_false = FALSE_;
&ldb, &beta, &ldc);
}
if (*rewi) {
- al__1.aerr = 0;
+/* al__1.aerr = 0;
al__1.aunit = *ntra;
- f_rew(&al__1);
+ f_rew(&al__1); */
}
ccgemm_(iorder, transa, transb, &m, &n, &k, &
alpha, &aa[1], &lda, &bb[1], &ldb, &
@@ -1353,9 +1087,10 @@ static logical c_false = FALSE_;
/* Check if error-exit was taken incorrectly. */
if (! infoc_1.ok) {
- io___128.ciunit = *nout;
- s_wsfe(&io___128);
- e_wsfe();
+// 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;
}
@@ -1393,11 +1128,7 @@ static logical c_false = FALSE_;
for (i__ = 1; i__ <= i__6; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
- io___131.ciunit = *nout;
- s_wsfe(&io___131);
- do_fio(&c__1, (char *)&i__, (ftnlen)
- sizeof(integer));
- e_wsfe();
+ printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);;
}
/* L40: */
}
@@ -1451,51 +1182,32 @@ static logical c_false = FALSE_;
if (errmax < *thresh) {
if (*iorder == 0) {
- io___133.ciunit = *nout;
- s_wsfe(&io___133);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
if (*iorder == 1) {
- io___134.ciunit = *nout;
- s_wsfe(&io___134);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
} else {
if (*iorder == 0) {
- io___135.ciunit = *nout;
- s_wsfe(&io___135);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
- e_wsfe();
+ 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) {
- io___136.ciunit = *nout;
- s_wsfe(&io___136);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
- e_wsfe();
+ 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:
- io___137.ciunit = *nout;
- s_wsfe(&io___137);
- do_fio(&c__1, sname, (ftnlen)13);
- e_wsfe();
+ 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, ': ', A13,'(''', A1, ''',''', A1, ''',', */
+/* 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',', */
/* $ 3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, */
/* $ ',(', F4.1, ',', F4.1, '), C,', I3, ').' ) */
@@ -1509,21 +1221,9 @@ static logical c_false = FALSE_;
k, complex *alpha, integer *lda, integer *ldb, complex *beta, integer
*ldc)
{
- /* Format strings */
- static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
- "a14,\002,\002,a14,\002,\002)";
- static char fmt_9994[] = "(10x,3(i3,\002,\002),\002 (\002,f4.1,\002,\002"
- ",f4.1,\002) , A,\002,i3,\002, B,\002,i3,\002, (\002,f4.1,\002"
- ",\002,f4.1,\002) , C,\002,i3,\002).\002)";
-
/* Local variables */
char crc[14], cta[14], ctb[14];
- /* Fortran I/O blocks */
- static cilist io___141 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___142 = { 0, 0, 0, fmt_9994, 0 };
-
-
if (*(unsigned char *)transa == 'N') {
s_copy(cta, " CblasNoTrans", (ftnlen)14, (ftnlen)14);
} else if (*(unsigned char *)transa == 'T') {
@@ -1543,25 +1243,8 @@ static logical c_false = FALSE_;
} else {
s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
}
- io___141.ciunit = *nout;
- s_wsfe(&io___141);
- do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, crc, (ftnlen)14);
- do_fio(&c__1, cta, (ftnlen)14);
- do_fio(&c__1, ctb, (ftnlen)14);
- e_wsfe();
- io___142.ciunit = *nout;
- s_wsfe(&io___142);
- do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(real));
- do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(real));
- do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
- e_wsfe();
+ 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_ */
@@ -1578,30 +1261,9 @@ static logical c_false = FALSE_;
static char ichs[2] = "LR";
static char ichu[2] = "UL";
- /* Format strings */
- static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
- "TAKEN ON VALID CALL *******\002)";
- static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
- " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
- static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
- "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
- " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
- "BER:\002)";
-
/* 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;
- alist al__1;
/* Local variables */
integer i__, m, n, ia, ib, na, nc, im, in, ms, ns, laa, lbb, lda, lcc,
@@ -1632,27 +1294,17 @@ static logical c_false = FALSE_;
char uplos[1];
extern /* Subroutine */ int cprcn2_(integer *, integer *, char *, integer
*, char *, char *, integer *, integer *, complex *, integer *,
- integer *, complex *, integer *), cchemm_(
- integer *, char *, char *, integer *, integer *, complex *,
- complex *, integer *, complex *, integer *, complex *, complex *,
- integer *);
+ integer *, complex *, integer *);
+ extern /* Subroutine */ int cchemm_(integer *, char *, char *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
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;
-
- /* Fortran I/O blocks */
- static cilist io___181 = { 0, 0, 0, fmt_9994, 0 };
- static cilist io___184 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___186 = { 0, 0, 0, fmt_10000, 0 };
- static cilist io___187 = { 0, 0, 0, fmt_10001, 0 };
- static cilist io___188 = { 0, 0, 0, fmt_10002, 0 };
- static cilist io___189 = { 0, 0, 0, fmt_10003, 0 };
- static cilist io___190 = { 0, 0, 0, fmt_9996, 0 };
-
-
+ extern logical lce_(complex *, complex *, integer *);
/* Tests CHEMM and CSYMM. */
@@ -1819,9 +1471,9 @@ static logical c_false = FALSE_;
;
}
if (*rewi) {
- al__1.aerr = 0;
+/* al__1.aerr = 0;
al__1.aunit = *ntra;
- f_rew(&al__1);
+ f_rew(&al__1);*/
}
if (conj) {
cchemm_(iorder, side, uplo, &m, &n, &alpha, &
@@ -1836,9 +1488,7 @@ static logical c_false = FALSE_;
/* Check if error-exit was taken incorrectly. */
if (! infoc_1.ok) {
- io___181.ciunit = *nout;
- s_wsfe(&io___181);
- e_wsfe();
+ printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");
*fatal = TRUE_;
goto L110;
}
@@ -1873,11 +1523,7 @@ static logical c_false = FALSE_;
for (i__ = 1; i__ <= i__5; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
- io___184.ciunit = *nout;
- s_wsfe(&io___184);
- do_fio(&c__1, (char *)&i__, (ftnlen)
- sizeof(integer));
- e_wsfe();
+ printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
}
/* L40: */
}
@@ -1935,51 +1581,34 @@ static logical c_false = FALSE_;
if (errmax < *thresh) {
if (*iorder == 0) {
- io___186.ciunit = *nout;
- s_wsfe(&io___186);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
if (*iorder == 1) {
- io___187.ciunit = *nout;
- s_wsfe(&io___187);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
} else {
if (*iorder == 0) {
- io___188.ciunit = *nout;
- s_wsfe(&io___188);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
- e_wsfe();
+ 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) {
- io___189.ciunit = *nout;
- s_wsfe(&io___189);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
- e_wsfe();
+ 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:
- io___190.ciunit = *nout;
- s_wsfe(&io___190);
- do_fio(&c__1, sname, (ftnlen)13);
- e_wsfe();
+ 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;
-/* L9995: */
+/* 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. */
@@ -1990,21 +1619,9 @@ static logical c_false = FALSE_;
*iorder, char *side, char *uplo, integer *m, integer *n, complex *
alpha, integer *lda, integer *ldb, complex *beta, integer *ldc)
{
- /* Format strings */
- static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
- "a14,\002,\002,a14,\002,\002)";
- static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002"
- ",f4.1,\002), A,\002,i3,\002, B,\002,i3,\002, (\002,f4.1,\002,"
- "\002,f4.1,\002), \002,\002C,\002,i3,\002).\002)";
-
/* Local variables */
char cs[14], cu[14], crc[14];
- /* Fortran I/O blocks */
- static cilist io___194 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___195 = { 0, 0, 0, fmt_9994, 0 };
-
-
if (*(unsigned char *)side == 'L') {
s_copy(cs, " CblasLeft", (ftnlen)14, (ftnlen)14);
} else {
@@ -2020,24 +1637,8 @@ static logical c_false = FALSE_;
} else {
s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
}
- io___194.ciunit = *nout;
- s_wsfe(&io___194);
- do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, crc, (ftnlen)14);
- do_fio(&c__1, cs, (ftnlen)14);
- do_fio(&c__1, cu, (ftnlen)14);
- e_wsfe();
- io___195.ciunit = *nout;
- s_wsfe(&io___195);
- do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(real));
- do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(real));
- do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
- e_wsfe();
+ 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_ */
@@ -2055,45 +1656,19 @@ static logical c_false = FALSE_;
static char ichd[2] = "UN";
static char ichs[2] = "LR";
- /* Format strings */
- static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
- "TAKEN ON VALID CALL *******\002)";
- static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
- " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
- static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
- "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
- " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
- "BER:\002)";
-
/* 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;
- alist al__1;
/* Local variables */
- integer i__, j, m, n, ia, na, nc, im, in, ms, ns, laa, icd, lbb, lda, ldb;
- extern logical lce_(complex *, complex *, integer *);
- integer ics;
- complex als;
- integer ict, icu;
- real err;
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 *);
@@ -2111,6 +1686,7 @@ static logical c_false = FALSE_;
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 *,
@@ -2121,17 +1697,12 @@ static logical c_false = FALSE_;
char *, integer *, integer *, complex *, complex *, integer *,
complex *, integer *);
real errmax;
-
- /* Fortran I/O blocks */
- static cilist io___236 = { 0, 0, 0, fmt_9994, 0 };
- static cilist io___239 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___241 = { 0, 0, 0, fmt_10000, 0 };
- static cilist io___242 = { 0, 0, 0, fmt_10001, 0 };
- static cilist io___243 = { 0, 0, 0, fmt_10002, 0 };
- static cilist io___244 = { 0, 0, 0, fmt_10003, 0 };
- static cilist io___245 = { 0, 0, 0, fmt_9996, 0 };
-
-
+ 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. */
@@ -2287,12 +1858,14 @@ static logical c_false = FALSE_;
if (*trace) {
cprcn3_(ntra, &nc, sname, iorder,
side, uplo, transa, diag, &m,
- &n, &alpha, &lda, &ldb);
+ &n, &alpha, &lda, &ldb/*, (
+ ftnlen)12, (ftnlen)1, (ftnlen)
+ 1, (ftnlen)1, (ftnlen)1*/);
}
if (*rewi) {
- al__1.aerr = 0;
+/* al__1.aerr = 0;
al__1.aunit = *ntra;
- f_rew(&al__1);
+ f_rew(&al__1);*/
}
cctrmm_(iorder, side, uplo, transa, diag,
&m, &n, &alpha, &aa[1], &lda, &bb[
@@ -2302,12 +1875,14 @@ static logical c_false = FALSE_;
if (*trace) {
cprcn3_(ntra, &nc, sname, iorder,
side, uplo, transa, diag, &m,
- &n, &alpha, &lda, &ldb);
+ &n, &alpha, &lda, &ldb/*, (
+ ftnlen)12, (ftnlen)1, (ftnlen)
+ 1, (ftnlen)1, (ftnlen)1*/);
}
if (*rewi) {
- al__1.aerr = 0;
+/* al__1.aerr = 0;
al__1.aunit = *ntra;
- f_rew(&al__1);
+ f_rew(&al__1);*/
}
cctrsm_(iorder, side, uplo, transa, diag,
&m, &n, &alpha, &aa[1], &lda, &bb[
@@ -2317,9 +1892,7 @@ static logical c_false = FALSE_;
/* Check if error-exit was taken incorrectly. */
if (! infoc_1.ok) {
- io___236.ciunit = *nout;
- s_wsfe(&io___236);
- e_wsfe();
+ printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");
*fatal = TRUE_;
goto L150;
}
@@ -2356,11 +1929,7 @@ static logical c_false = FALSE_;
for (i__ = 1; i__ <= i__4; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
- io___239.ciunit = *nout;
- s_wsfe(&io___239);
- do_fio(&c__1, (char *)&i__, (ftnlen)
- sizeof(integer));
- e_wsfe();
+ printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
}
/* L50: */
}
@@ -2382,8 +1951,8 @@ static logical c_false = FALSE_;
c_b1, &c__[c_offset],
nmax, &ct[1], &g[1], &bb[
1], &ldb, eps, &err,
- fatal, nout, &c_true, (
- ftnlen)1, (ftnlen)1);
+ fatal, nout, &c_true/*, (
+ ftnlen)1, (ftnlen)1*/);
} else {
cmmch_("N", transa, &m, &n, &n, &
alpha, &b[b_offset], nmax,
@@ -2470,44 +2039,25 @@ static logical c_false = FALSE_;
if (errmax < *thresh) {
if (*iorder == 0) {
- io___241.ciunit = *nout;
- s_wsfe(&io___241);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
if (*iorder == 1) {
- io___242.ciunit = *nout;
- s_wsfe(&io___242);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
} else {
if (*iorder == 0) {
- io___243.ciunit = *nout;
- s_wsfe(&io___243);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
- e_wsfe();
+ 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) {
- io___244.ciunit = *nout;
- s_wsfe(&io___244);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
- e_wsfe();
+ 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:
- io___245.ciunit = *nout;
- s_wsfe(&io___245);
- do_fio(&c__1, sname, (ftnlen)13);
- e_wsfe();
+ printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
if (*trace) {
cprcn3_(ntra, &nc, sname, iorder, side, uplo, transa, diag, &m, &n, &
alpha, &lda, &ldb);
@@ -2516,7 +2066,9 @@ static logical c_false = FALSE_;
L160:
return 0;
-/* L9995: */
+/* 9995 FORMAT(1X, I6, ': ', A12,'(', 4( '''', A1, ''',' ), 2( I3, ',' ), */
+/* $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ') ', */
+/* $ ' .' ) */
/* End of CCHK3. */
@@ -2527,21 +2079,9 @@ static logical c_false = FALSE_;
*iorder, char *side, char *uplo, char *transa, char *diag, integer *m,
integer *n, complex *alpha, integer *lda, integer *ldb)
{
- /* Format strings */
- static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
- "a14,\002,\002,a14,\002,\002)";
- static char fmt_9994[] = "(10x,2(a14,\002,\002),2(i3,\002,\002),\002 "
- "(\002,f4.1,\002,\002,f4.1,\002), A,\002,i3,\002, B,\002,i3,\002)."
- "\002)";
-
/* Local variables */
char ca[14], cd[14], cs[14], cu[14], crc[14];
- /* Fortran I/O blocks */
- static cilist io___251 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___252 = { 0, 0, 0, fmt_9994, 0 };
-
-
if (*(unsigned char *)side == 'L') {
s_copy(cs, " CblasLeft", (ftnlen)14, (ftnlen)14);
} else {
@@ -2569,24 +2109,9 @@ static logical c_false = FALSE_;
} else {
s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
}
- io___251.ciunit = *nout;
- s_wsfe(&io___251);
- do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, crc, (ftnlen)14);
- do_fio(&c__1, cs, (ftnlen)14);
- do_fio(&c__1, cu, (ftnlen)14);
- e_wsfe();
- io___252.ciunit = *nout;
- s_wsfe(&io___252);
- do_fio(&c__1, ca, (ftnlen)14);
- do_fio(&c__1, cd, (ftnlen)14);
- do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(real));
- do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
- e_wsfe();
+ 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_ */
@@ -2603,41 +2128,12 @@ static logical c_false = FALSE_;
static char icht[2] = "NC";
static char ichu[2] = "UL";
- /* Format strings */
- static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
- "TAKEN ON VALID CALL *******\002)";
- static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
- " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
- static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
- "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
- " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
- " \002,i3)";
- static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
- "BER:\002)";
-
/* 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;
- alist al__1;
/* Local variables */
- integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa,
- lda, lcc, ldc;
- extern logical lce_(complex *, complex *, integer *);
- complex als;
- integer ict, icu;
- real err;
complex beta;
integer ldas, ldcs;
logical same, conj;
@@ -2645,6 +2141,7 @@ static logical c_false = FALSE_;
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 *);
@@ -2665,9 +2162,12 @@ static logical c_false = FALSE_;
*, char *, char *, integer *, integer *, complex *, integer *,
complex *, integer *), cprcn6_(integer *,
integer *, char *, integer *, char *, char *, integer *, integer *
- , real *, integer *, real *, integer *),
- ccherk_(integer *, char *, char *, integer *, integer *, real *,
- complex *, integer *, real *, complex *, 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 *);
@@ -2676,18 +2176,11 @@ static logical c_false = FALSE_;
integer *, complex *, complex *, integer *, complex *, complex *,
integer *);
char transs[1], transt[1];
-
- /* Fortran I/O blocks */
- static cilist io___294 = { 0, 0, 0, fmt_9992, 0 };
- static cilist io___297 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___304 = { 0, 0, 0, fmt_10000, 0 };
- static cilist io___305 = { 0, 0, 0, fmt_10001, 0 };
- static cilist io___306 = { 0, 0, 0, fmt_10002, 0 };
- static cilist io___307 = { 0, 0, 0, fmt_10003, 0 };
- static cilist io___308 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___309 = { 0, 0, 0, fmt_9996, 0 };
-
-
+ integer laa, lda, lcc, ldc;
+ extern logical lce_(complex *, complex *, integer *);
+ complex als;
+ integer ict, icu;
+ real err;
/* Tests CHERK and CSYRK. */
@@ -2728,7 +2221,10 @@ static logical c_false = FALSE_;
nc = 0;
reset = TRUE_;
errmax = 0.f;
-
+ rals = 1.f;
+ rbets = 1.f;
+ bets.r=bets.i=0.f;
+
i__1 = *nidim;
for (in = 1; in <= i__1; ++in) {
n = idim[in];
@@ -2801,8 +2297,8 @@ static logical c_false = FALSE_;
}
null = n <= 0;
if (conj) {
- null = null || (k <= 0 || ralpha == 0.f) &&
- rbeta == 1.f;
+ null = null || ((k <= 0 || ralpha == 0.f) &&
+ rbeta == 1.f);
}
/* Generate the matrix C. */
@@ -2858,9 +2354,9 @@ static logical c_false = FALSE_;
rbeta, &ldc);
}
if (*rewi) {
- al__1.aerr = 0;
+/* al__1.aerr = 0;
al__1.aunit = *ntra;
- f_rew(&al__1);
+ f_rew(&al__1);*/
}
ccherk_(iorder, uplo, trans, &n, &k, &ralpha,
&aa[1], &lda, &rbeta, &cc[1], &ldc);
@@ -2871,9 +2367,9 @@ static logical c_false = FALSE_;
beta, &ldc);
}
if (*rewi) {
- al__1.aerr = 0;
+/* al__1.aerr = 0;
al__1.aunit = *ntra;
- f_rew(&al__1);
+ f_rew(&al__1);*/
}
ccsyrk_(iorder, uplo, trans, &n, &k, &alpha, &
aa[1], &lda, &beta, &cc[1], &ldc);
@@ -2882,9 +2378,7 @@ static logical c_false = FALSE_;
/* Check if error-exit was taken incorrectly. */
if (! infoc_1.ok) {
- io___294.ciunit = *nout;
- s_wsfe(&io___294);
- e_wsfe();
+ printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");
*fatal = TRUE_;
goto L120;
}
@@ -2927,11 +2421,7 @@ static logical c_false = FALSE_;
for (i__ = 1; i__ <= i__5; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
- io___297.ciunit = *nout;
- s_wsfe(&io___297);
- do_fio(&c__1, (char *)&i__, (ftnlen)
- sizeof(integer));
- e_wsfe();
+ printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
}
/* L30: */
}
@@ -3015,52 +2505,30 @@ static logical c_false = FALSE_;
if (errmax < *thresh) {
if (*iorder == 0) {
- io___304.ciunit = *nout;
- s_wsfe(&io___304);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
if (*iorder == 1) {
- io___305.ciunit = *nout;
- s_wsfe(&io___305);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
} else {
if (*iorder == 0) {
- io___306.ciunit = *nout;
- s_wsfe(&io___306);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
- e_wsfe();
+ 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) {
- io___307.ciunit = *nout;
- s_wsfe(&io___307);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
- e_wsfe();
+ 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) {
- io___308.ciunit = *nout;
- s_wsfe(&io___308);
- do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j);
}
L120:
- io___309.ciunit = *nout;
- s_wsfe(&io___309);
- do_fio(&c__1, sname, (ftnlen)13);
- e_wsfe();
+ printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
if (conj) {
cprcn6_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &ralpha, &lda,
&rbeta, &ldc);
@@ -3072,8 +2540,12 @@ static logical c_false = FALSE_;
L130:
return 0;
-/* L9994: */
-/* L9993: */
+/* 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. */
@@ -3084,21 +2556,9 @@ static logical c_false = FALSE_;
*iorder, char *uplo, char *transa, integer *n, integer *k, complex *
alpha, integer *lda, complex *beta, integer *ldc)
{
- /* Format strings */
- static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002,"
- "\002))";
- static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002"
- ",f4.1,\002), A,\002,i3,\002, (\002,f4.1,\002,\002,f4.1,\002), C"
- ",\002,i3,\002).\002)";
-
/* Local variables */
char ca[14], cu[14], crc[14];
- /* Fortran I/O blocks */
- static cilist io___313 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___314 = { 0, 0, 0, fmt_9994, 0 };
-
-
if (*(unsigned char *)uplo == 'U') {
s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14);
} else {
@@ -3116,23 +2576,8 @@ static logical c_false = FALSE_;
} else {
s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
}
- io___313.ciunit = *nout;
- s_wsfe(&io___313);
- do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, crc, (ftnlen)14);
- do_fio(&c__1, cu, (ftnlen)14);
- do_fio(&c__1, ca, (ftnlen)14);
- e_wsfe();
- io___314.ciunit = *nout;
- s_wsfe(&io___314);
- do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(real));
- do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(real));
- do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
- e_wsfe();
+ 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_ */
@@ -3142,20 +2587,9 @@ static logical c_false = FALSE_;
*iorder, char *uplo, char *transa, integer *n, integer *k, real *
alpha, integer *lda, real *beta, integer *ldc)
{
- /* Format strings */
- static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002,"
- "\002))";
- static char fmt_9994[] = "(10x,2(i3,\002,\002),f4.1,\002, A,\002,i3"
- ",\002,\002,f4.1,\002, C,\002,i3,\002).\002)";
-
/* Local variables */
char ca[14], cu[14], crc[14];
- /* Fortran I/O blocks */
- static cilist io___318 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___319 = { 0, 0, 0, fmt_9994, 0 };
-
-
if (*(unsigned char *)uplo == 'U') {
s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14);
} else {
@@ -3173,23 +2607,8 @@ static logical c_false = FALSE_;
} else {
s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
}
- io___318.ciunit = *nout;
- s_wsfe(&io___318);
- do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, crc, (ftnlen)14);
- do_fio(&c__1, cu, (ftnlen)14);
- do_fio(&c__1, ca, (ftnlen)14);
- e_wsfe();
- io___319.ciunit = *nout;
- s_wsfe(&io___319);
- do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(real));
- do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(real));
- do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
- e_wsfe();
+ 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_ */
@@ -3206,40 +2625,12 @@ static logical c_false = FALSE_;
static char icht[2] = "NC";
static char ichu[2] = "UL";
- /* Format strings */
- static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
- "TAKEN ON VALID CALL *******\002)";
- static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
- " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
- static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
- "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
- " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
- " \002,i3)";
- static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
- "BER:\002)";
/* 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;
- alist al__1;
/* Local variables */
- integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa,
- lbb, lda, lcc, ldb, ldc;
- extern logical lce_(complex *, complex *, integer *);
- complex als;
- integer ict, icu;
- real err;
integer jjab;
complex beta;
integer ldas, ldbs, ldcs;
@@ -3247,6 +2638,7 @@ static logical c_false = FALSE_;
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 *);
@@ -3268,27 +2660,22 @@ static logical c_false = FALSE_;
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 *), ccsyr2k_(integer *
- , char *, char *, integer *, integer *, complex *, complex *,
- integer *, complex *, integer *, complex *, complex *, integer *);
-
- /* Fortran I/O blocks */
- static cilist io___362 = { 0, 0, 0, fmt_9992, 0 };
- static cilist io___365 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___373 = { 0, 0, 0, fmt_10000, 0 };
- static cilist io___374 = { 0, 0, 0, fmt_10001, 0 };
- static cilist io___375 = { 0, 0, 0, fmt_10002, 0 };
- static cilist io___376 = { 0, 0, 0, fmt_10003, 0 };
- static cilist io___377 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___378 = { 0, 0, 0, fmt_9996, 0 };
-
-
+ 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. */
@@ -3412,8 +2799,8 @@ static logical c_false = FALSE_;
}
null = n <= 0;
if (conj) {
- null = null || (k <= 0 || alpha.r == 0.f &&
- alpha.i == 0.f) && rbeta == 1.f;
+ null = null || ((k <= 0 || (alpha.r == 0.f &&
+ alpha.i == 0.f)) && rbeta == 1.f);
}
/* Generate the matrix C. */
@@ -3474,9 +2861,9 @@ static logical c_false = FALSE_;
&rbeta, &ldc);
}
if (*rewi) {
- al__1.aerr = 0;
+/* al__1.aerr = 0;
al__1.aunit = *ntra;
- f_rew(&al__1);
+ f_rew(&al__1);*/
}
ccher2k_(iorder, uplo, trans, &n, &k, &alpha,
&aa[1], &lda, &bb[1], &ldb, &rbeta, &
@@ -3488,9 +2875,9 @@ static logical c_false = FALSE_;
&beta, &ldc);
}
if (*rewi) {
- al__1.aerr = 0;
+/* al__1.aerr = 0;
al__1.aunit = *ntra;
- f_rew(&al__1);
+ f_rew(&al__1);*/
}
ccsyr2k_(iorder, uplo, trans, &n, &k, &alpha,
&aa[1], &lda, &bb[1], &ldb, &beta, &
@@ -3500,9 +2887,7 @@ static logical c_false = FALSE_;
/* Check if error-exit was taken incorrectly. */
if (! infoc_1.ok) {
- io___362.ciunit = *nout;
- s_wsfe(&io___362);
- e_wsfe();
+ printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");
*fatal = TRUE_;
goto L150;
}
@@ -3542,11 +2927,7 @@ static logical c_false = FALSE_;
for (i__ = 1; i__ <= i__5; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
- io___365.ciunit = *nout;
- s_wsfe(&io___365);
- do_fio(&c__1, (char *)&i__, (ftnlen)
- sizeof(integer));
- e_wsfe();
+ printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
}
/* L40: */
}
@@ -3579,7 +2960,7 @@ static logical c_false = FALSE_;
i__6 = k;
for (i__ = 1; i__ <= i__6; ++i__) {
i__7 = i__;
- i__8 = (j - 1 << 1) * *nmax + k +
+ i__8 = ((j - 1) << 1) * *nmax + k +
i__;
q__1.r = alpha.r * ab[i__8].r -
alpha.i * ab[i__8].i,
@@ -3591,14 +2972,14 @@ static logical c_false = FALSE_;
if (conj) {
i__7 = k + i__;
r_cnjg(&q__2, &alpha);
- i__8 = (j - 1 << 1) * *nmax + i__;
+ 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__;
+ 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;
@@ -3699,52 +3080,30 @@ static logical c_false = FALSE_;
if (errmax < *thresh) {
if (*iorder == 0) {
- io___373.ciunit = *nout;
- s_wsfe(&io___373);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
if (*iorder == 1) {
- io___374.ciunit = *nout;
- s_wsfe(&io___374);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
} else {
if (*iorder == 0) {
- io___375.ciunit = *nout;
- s_wsfe(&io___375);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
- e_wsfe();
+ 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) {
- io___376.ciunit = *nout;
- s_wsfe(&io___376);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
- e_wsfe();
+ 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) {
- io___377.ciunit = *nout;
- s_wsfe(&io___377);
- do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j);
}
L150:
- io___378.ciunit = *nout;
- s_wsfe(&io___378);
- do_fio(&c__1, sname, (ftnlen)13);
- e_wsfe();
+ printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
if (conj) {
cprcn7_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &
ldb, &rbeta, &ldc);
@@ -3756,8 +3115,12 @@ static logical c_false = FALSE_;
L160:
return 0;
-/* L9994: */
-/* L9993: */
+/* 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. */
@@ -3768,21 +3131,10 @@ static logical c_false = FALSE_;
*iorder, char *uplo, char *transa, integer *n, integer *k, complex *
alpha, integer *lda, integer *ldb, complex *beta, integer *ldc)
{
- /* Format strings */
- static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002,"
- "\002))";
- static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002"
- ",f4.1,\002), A,\002,i3,\002, B\002,i3,\002, (\002,f4.1,\002,\002"
- ",f4.1,\002), C,\002,i3,\002).\002)";
/* Local variables */
char ca[14], cu[14], crc[14];
- /* Fortran I/O blocks */
- static cilist io___382 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___383 = { 0, 0, 0, fmt_9994, 0 };
-
-
if (*(unsigned char *)uplo == 'U') {
s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14);
} else {
@@ -3800,24 +3152,8 @@ static logical c_false = FALSE_;
} else {
s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
}
- io___382.ciunit = *nout;
- s_wsfe(&io___382);
- do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, crc, (ftnlen)14);
- do_fio(&c__1, cu, (ftnlen)14);
- do_fio(&c__1, ca, (ftnlen)14);
- e_wsfe();
- io___383.ciunit = *nout;
- s_wsfe(&io___383);
- do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(real));
- do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(real));
- do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
- e_wsfe();
+ 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_ */
@@ -3827,21 +3163,10 @@ static logical c_false = FALSE_;
*iorder, char *uplo, char *transa, integer *n, integer *k, complex *
alpha, integer *lda, integer *ldb, real *beta, integer *ldc)
{
- /* Format strings */
- static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002,"
- "\002))";
- static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002"
- ",f4.1,\002), A,\002,i3,\002, B\002,i3,\002,\002,f4.1,\002, C,"
- "\002,i3,\002).\002)";
/* Local variables */
char ca[14], cu[14], crc[14];
- /* Fortran I/O blocks */
- static cilist io___387 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___388 = { 0, 0, 0, fmt_9994, 0 };
-
-
if (*(unsigned char *)uplo == 'U') {
s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14);
} else {
@@ -3859,24 +3184,8 @@ static logical c_false = FALSE_;
} else {
s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
}
- io___387.ciunit = *nout;
- s_wsfe(&io___387);
- do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, crc, (ftnlen)14);
- do_fio(&c__1, cu, (ftnlen)14);
- do_fio(&c__1, ca, (ftnlen)14);
- e_wsfe();
- io___388.ciunit = *nout;
- s_wsfe(&io___388);
- do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(real));
- do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(real));
- do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
- e_wsfe();
+ 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_ */
@@ -3891,11 +3200,13 @@ static logical c_false = FALSE_;
complex q__1, q__2;
/* Local variables */
- integer i__, j, jj;
- logical gen, her, tri, sym;
extern /* Complex */ VOID cbeg_(complex *, logical *);
integer ibeg, iend;
- logical unit, lower, upper;
+ logical unit;
+ integer i__, j;
+ logical lower, upper;
+ integer jj;
+ logical gen, her, tri, sym;
/* Generates values for an M by N matrix A. */
@@ -3914,7 +3225,7 @@ static logical c_false = FALSE_;
/* Parameter adjustments */
a_dim1 = *nmax;
- a_offset = 1 + a_dim1;
+ a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--aa;
@@ -3933,7 +3244,7 @@ static logical c_false = FALSE_;
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 (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;
@@ -4062,15 +3373,6 @@ static logical c_false = FALSE_;
real *g, complex *cc, integer *ldcc, real *eps, real *err, logical *
fatal, integer *nout, logical *mv)
{
- /* Format strings */
- static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS"
- " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 "
- " EXPECTED RE\002,\002SULT COMPUTED R"
- "ESULT\002)";
- static char fmt_9998[] = "(1x,i7,2(\002 (\002,g15.6,\002,\002,g15.6,"
- "\002)\002))";
- static char fmt_9997[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
- " \002,i3)";
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, cc_dim1,
@@ -4079,18 +3381,10 @@ static logical c_false = FALSE_;
complex q__1, q__2, q__3, q__4;
/* Local variables */
- integer i__, j, k;
real erri;
+ integer i__, j, k;
logical trana, tranb, ctrana, ctranb;
- /* Fortran I/O blocks */
- static cilist io___409 = { 0, 0, 0, fmt_9999, 0 };
- static cilist io___410 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___411 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___412 = { 0, 0, 0, fmt_9997, 0 };
-
-
-
/* Checks the results of the computational tests. */
/* Auxiliary routine for test program for Level 3 Blas. */
@@ -4427,35 +3721,19 @@ static logical c_false = FALSE_;
L230:
*fatal = TRUE_;
- io___409.ciunit = *nout;
- s_wsfe(&io___409);
- e_wsfe();
+ 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) {
- io___410.ciunit = *nout;
- s_wsfe(&io___410);
- do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&ct[i__], (ftnlen)sizeof(real));
- do_fio(&c__2, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(real)
- );
- e_wsfe();
+ 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 {
- io___411.ciunit = *nout;
- s_wsfe(&io___411);
- do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(real)
- );
- do_fio(&c__2, (char *)&ct[i__], (ftnlen)sizeof(real));
- e_wsfe();
+ 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) {
- io___412.ciunit = *nout;
- s_wsfe(&io___412);
- do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf(" THESE ARE THE RESULTS FOR COLUMN %d\n",j);
}
L250:
@@ -4519,7 +3797,7 @@ logical lceres_(char *type__, char *uplo, integer *m, integer *n, complex *aa,
logical ret_val;
/* Local variables */
- integer i__, j, ibeg, iend;
+ integer ibeg, iend, i__, j;
logical upper;
@@ -4696,29 +3974,28 @@ real sdiff_(real *x, real *y)
static char ishape[2] = "UL";
/* Format strings */
- static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
- "TAKEN ON VALID CALL *******\002)";
- static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
- " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
- static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
- "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
- " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
- "BER:\002)";
+// static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
+// "TAKEN ON VALID CALL *******\002)";
+// static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+// " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+// static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
+// "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+// static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
+// "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
+// static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
+// "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+// "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+// "ECT *******\002)";
+// static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
+// " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
+// "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
+// "ECT *******\002)";
+// static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
+// "BER:\002)";
/* 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;
- alist al__1;
/* Local variables */
extern /* Subroutine */ int ccgemmtr_(integer *, char *, char *, char *,
@@ -4752,16 +4029,6 @@ real sdiff_(real *x, real *y)
char tranas[1], tranbs[1], transa[1], transb[1];
real errmax;
- /* Fortran I/O blocks */
- static cilist io___468 = { 0, 0, 0, fmt_9994, 0 };
- static cilist io___471 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___473 = { 0, 0, 0, fmt_10000, 0 };
- static cilist io___474 = { 0, 0, 0, fmt_10001, 0 };
- static cilist io___475 = { 0, 0, 0, fmt_10002, 0 };
- static cilist io___476 = { 0, 0, 0, fmt_10003, 0 };
- static cilist io___477 = { 0, 0, 0, fmt_9996, 0 };
-
-
/* Tests CGEMMTR. */
@@ -4943,11 +4210,6 @@ real sdiff_(real *x, real *y)
transa, transb, &n, &k, &alpha, &
lda, &ldb, &beta, &ldc);
}
- if (*rewi) {
- al__1.aerr = 0;
- al__1.aunit = *ntra;
- f_rew(&al__1);
- }
ccgemmtr_(iorder, uplo, transa, transb, &n, &
k, &alpha, &aa[1], &lda, &bb[1], &ldb,
&beta, &cc[1], &ldc);
@@ -4955,9 +4217,7 @@ real sdiff_(real *x, real *y)
/* Check if error-exit was taken incorrectly. */
if (! infoc_1.ok) {
- io___468.ciunit = *nout;
- s_wsfe(&io___468);
- e_wsfe();
+ printf(" *** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");
*fatal = TRUE_;
goto L120;
}
@@ -4996,11 +4256,7 @@ real sdiff_(real *x, real *y)
for (i__ = 1; i__ <= i__5; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
- io___471.ciunit = *nout;
- s_wsfe(&io___471);
- do_fio(&c__1, (char *)&i__, (ftnlen)
- sizeof(integer));
- e_wsfe();
+ printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
}
/* L40: */
}
@@ -5055,45 +4311,27 @@ real sdiff_(real *x, real *y)
/* Report result. */
if (errmax < *thresh) {
- if (*iorder == 0) {
- io___473.ciunit = *nout;
- s_wsfe(&io___473);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
- }
- if (*iorder == 1) {
- io___474.ciunit = *nout;
- s_wsfe(&io___474);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
- }
+ 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) {
- io___475.ciunit = *nout;
- s_wsfe(&io___475);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
- e_wsfe();
- }
- if (*iorder == 1) {
- io___476.ciunit = *nout;
- s_wsfe(&io___476);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
- e_wsfe();
- }
+ 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:
- io___477.ciunit = *nout;
- s_wsfe(&io___477);
- do_fio(&c__1, sname, (ftnlen)13);
- e_wsfe();
+ printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
cprcn8_(nout, &nc, sname, iorder, uplo, transa, transb, &n, &k, &alpha, &
lda, &ldb, &beta, &ldc);
@@ -5121,11 +4359,6 @@ real sdiff_(real *x, real *y)
/* Local variables */
char crc[14], cta[14], ctb[14], cuplo[14];
- /* Fortran I/O blocks */
- static cilist io___482 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___483 = { 0, 0, 0, fmt_9994, 0 };
-
-
if (*(unsigned char *)uplo == 'U') {
s_copy(cuplo, "CblasUpper", (ftnlen)14, (ftnlen)10);
} else {
@@ -5150,25 +4383,8 @@ real sdiff_(real *x, real *y)
} else {
s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
}
- io___482.ciunit = *nout;
- s_wsfe(&io___482);
- do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, crc, (ftnlen)14);
- do_fio(&c__1, cuplo, (ftnlen)14);
- do_fio(&c__1, cta, (ftnlen)14);
- do_fio(&c__1, ctb, (ftnlen)14);
- e_wsfe();
- io___483.ciunit = *nout;
- s_wsfe(&io___483);
- do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(real));
- do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(real));
- do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%6d: %s %s %s %s %s\n",*nc,sname,crc,cuplo,cta,ctb);
+ printf("%d %d (%4.1f,%4.1f) A, %d, B, %d, (%4.1f,%4.1f), C, %d.\n",*n,*k,*alpha,*lda,*ldb,*beta,*ldc);
return 0;
} /* cprcn8_ */
@@ -5202,14 +4418,6 @@ real sdiff_(real *x, real *y)
logical ctrana, ctranb;
integer istart;
- /* Fortran I/O blocks */
- static cilist io___495 = { 0, 0, 0, fmt_9999, 0 };
- static cilist io___496 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___497 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___498 = { 0, 0, 0, fmt_9997, 0 };
-
-
-
/* Checks the results of the computational tests for GEMMTR. */
/* Auxiliary routine for test program for Level 3 Blas. */
@@ -5553,35 +4761,21 @@ real sdiff_(real *x, real *y)
L230:
*fatal = TRUE_;
- io___495.ciunit = *nout;
- s_wsfe(&io___495);
- e_wsfe();
+ printf(" ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HALF ACCURATE *******\n");
+ printf(" EXPECTED RESULT COMPUTED RESULT\n");
+
i__1 = istop;
for (i__ = istart; i__ <= i__1; ++i__) {
if (*mv) {
- io___496.ciunit = *nout;
- s_wsfe(&io___496);
- do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&ct[i__], (ftnlen)sizeof(real));
- do_fio(&c__2, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(real)
- );
- e_wsfe();
+ 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 {
- io___497.ciunit = *nout;
- s_wsfe(&io___497);
- do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(real)
- );
- do_fio(&c__2, (char *)&ct[i__], (ftnlen)sizeof(real));
- e_wsfe();
+ 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) {
- io___498.ciunit = *nout;
- s_wsfe(&io___498);
- do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf(" THESE ARE THE RESULTS FOR COLUMN %d\n",j);
}
L250:
@@ -5592,4 +4786,3 @@ real sdiff_(real *x, real *y)
} /* cmmtch_ */
-/* Main program alias */ int cblat3_ () { MAIN__ (); return 0; }
diff --git a/ctest/c_dblat3c.c b/ctest/c_dblat3c.c
index 3bbdb2bbb7..97da67b3cb 100644
--- a/ctest/c_dblat3c.c
+++ b/ctest/c_dblat3c.c
@@ -240,125 +240,16 @@ typedef struct Namelist Namelist;
/* 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
-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;
-}
/* Common Block Declarations */
-union {
- struct {
- integer infot, noutc;
- logical ok;
- } _1;
- struct {
- integer infot, noutc;
- logical ok, lerr;
- } _2;
+struct {
+ integer infot, noutc;
+ logical ok;
} infoc_;
-#define infoc_1 (infoc_._1)
-#define infoc_2 (infoc_._2)
+#define infoc_1 infoc_
struct {
char srnamt[13];
@@ -368,13 +259,8 @@ struct {
/* Table of constant values */
-static integer c__9 = 9;
static integer c__1 = 1;
-static integer c__3 = 3;
-static integer c__8 = 8;
-static integer c__5 = 5;
static integer c__65 = 65;
-static integer c__7 = 7;
static doublereal c_b90 = 1.;
static doublereal c_b104 = 0.;
static integer c__6 = 6;
@@ -386,162 +272,50 @@ static logical c_false = FALSE_;
{
/* Initialized data */
- static char snames[13*7] = "cblas_dgemm " "cblas_dsymm " "cblas_dtrmm "
- "cblas_dtrsm " "cblas_dsyrk " "cblas_dsyr2k " "cblas_dgemmtr";
-
- /* Format strings */
- static char fmt_9997[] = "(\002 NUMBER OF VALUES OF \002,a,\002 IS LESS "
- "THAN 1 OR GREATER \002,\002THAN \002,i2)";
- static char fmt_9996[] = "(\002 VALUE OF N IS LESS THAN 0 OR GREATER THA"
- "N \002,i2)";
- static char fmt_9995[] = "(\002 TESTS OF THE DOUBLE PRECISION LEVEL 3 BL"
- "AS\002,//\002 THE F\002,\002OLLOWING PARAMETER VALUES WILL BE US"
- "ED:\002)";
- static char fmt_9994[] = "(\002 FOR N \002,9i6)";
- static char fmt_9993[] = "(\002 FOR ALPHA \002,7f6.1)";
- static char fmt_9992[] = "(\002 FOR BETA \002,7f6.1)";
- static char fmt_9984[] = "(\002 ERROR-CALL MYEXITS WILL NOT BE TESTED"
- "\002)";
- static char fmt_9999[] = "(\002 ROUTINES PASS COMPUTATIONAL TESTS IF TES"
- "T RATIO IS LES\002,\002S THAN\002,f8.2)";
- static char fmt_10002[] = "(\002 COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS"
- " ARE TESTED\002)";
- static char fmt_10001[] = "(\002 ROW-MAJOR DATA LAYOUT IS TESTED\002)";
- static char fmt_10000[] = "(\002 COLUMN-MAJOR DATA LAYOUT IS TESTED\002)";
- static char fmt_9988[] = "(a13,l2)";
- static char fmt_9990[] = "(\002 SUBPROGRAM NAME \002,a13,\002 NOT RECOGN"
- "IZED\002,/\002 ******* T\002,\002ESTS ABANDONED *******\002)";
- static char fmt_9998[] = "(\002 RELATIVE MACHINE PRECISION IS TAKEN TO"
- " BE\002,1p,d9.1)";
- static char fmt_9989[] = "(\002 ERROR IN DMMCH - IN-LINE DOT PRODUCTS A"
- "RE BEING EVALU\002,\002ATED WRONGLY.\002,/\002 DMMCH WAS CALLED "
- "WITH TRANSA = \002,a1,\002 AND TRANSB = \002,a1,/\002 AND RETURN"
- "ED SAME = \002,l1,\002 AND \002,\002ERR = \002,f12.3,\002.\002,"
- "/\002 THIS MAY BE DUE TO FAULTS IN THE \002,\002ARITHMETIC OR TH"
- "E COMPILER.\002,/\002 ******* TESTS ABANDONED \002,\002******"
- "*\002)";
- static char fmt_9987[] = "(1x,a13,\002 WAS NOT TESTED\002)";
- static char fmt_9986[] = "(/\002 END OF TESTS\002)";
- static char fmt_9985[] = "(/\002 ******* FATAL ERROR - TESTS ABANDONED *"
- "******\002)";
- static char fmt_9991[] = "(\002 AMEND DATA FILE OR INCREASE ARRAY SIZES "
- "IN PROGRAM\002,/\002 ******* TESTS ABANDONED *******\002)";
+ static char snames[7][14] = {"cblas_dgemm ", "cblas_dsymm ", "cblas_dtrmm ", "cblas_dtrsm ",
+ "cblas_dsyrk ", "cblas_dsyr2k ", "cblas_dgemmtr"};
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
- olist o__1;
- cllist cl__1;
-
- /* Local variables */
- doublereal c__[4225] /* was [65][65] */, g[65];
- integer i__, j, n;
- doublereal w[130], aa[4225], ab[8450] /* was [65][130] */, bb[4225],
- cc[4225], as[4225], bs[4225], cs[4225], ct[65], alf[7];
- extern logical lde_(doublereal *, doublereal *, integer *);
- doublereal bet[7], eps, err;
- integer nalf, idim[9];
- logical same;
- integer nbet, ntra;
- logical rewi;
- extern /* Subroutine */ int dchk1_(char *, doublereal *, doublereal *,
- integer *, integer *, logical *, logical *, logical *, integer *,
- integer *, integer *, doublereal *, integer *, doublereal *,
- integer *, doublereal *, doublereal *, doublereal *, doublereal *,
- doublereal *, doublereal *, doublereal *, doublereal *,
- doublereal *, doublereal *, doublereal *, integer *),
- dchk2_(char *, doublereal *, doublereal *, integer *, integer *,
- logical *, logical *, logical *, integer *, integer *, integer *,
- doublereal *, integer *, doublereal *, integer *, doublereal *,
- doublereal *, doublereal *, doublereal *, doublereal *,
- doublereal *, doublereal *, doublereal *, doublereal *,
- doublereal *, doublereal *, integer *), dchk3_(char *,
- doublereal *, doublereal *, integer *, integer *, logical *,
- logical *, logical *, integer *, integer *, integer *, doublereal
- *, integer *, doublereal *, doublereal *, doublereal *,
- doublereal *, doublereal *, doublereal *, doublereal *,
- doublereal *, doublereal *, integer *), dchk4_(char *,
- doublereal *, doublereal *, integer *, integer *, logical *,
- logical *, logical *, integer *, integer *, integer *, doublereal
- *, integer *, doublereal *, integer *, doublereal *, doublereal *,
- doublereal *, doublereal *, doublereal *, doublereal *,
- doublereal *, doublereal *, doublereal *, doublereal *,
- doublereal *, integer *), dchk5_(char *, doublereal *,
- doublereal *, integer *, integer *, logical *, logical *, logical
- *, integer *, integer *, integer *, doublereal *, integer *,
- doublereal *, integer *, doublereal *, doublereal *, doublereal *,
- doublereal *, doublereal *, doublereal *, doublereal *,
- doublereal *, doublereal *, doublereal *, doublereal *, integer *), dchk6_(char *, doublereal *, doublereal *, integer *,
- integer *, logical *, logical *, logical *, integer *, integer *,
- integer *, doublereal *, integer *, doublereal *, integer *,
- doublereal *, doublereal *, doublereal *, doublereal *,
- doublereal *, doublereal *, doublereal *, doublereal *,
- doublereal *, doublereal *, doublereal *, integer *);
- extern doublereal ddiff_(doublereal *, doublereal *);
- logical fatal;
- extern /* Subroutine */ int dmmch_(char *, char *, integer *, integer *,
- integer *, doublereal *, doublereal *, integer *, doublereal *,
- integer *, doublereal *, doublereal *, integer *, doublereal *,
- doublereal *, doublereal *, integer *, doublereal *, doublereal *,
- logical *, integer *, logical *);
- logical trace;
- integer nidim;
- char snaps[32];
- integer isnum;
- logical ltest[7], sfatal, corder;
- char snamet[13], transa[1], transb[1];
- doublereal thresh;
- logical rorder;
- extern /* Subroutine */ int cd3chke_(char *);
- integer layout;
- logical ltestt, tsterr;
-
- /* Fortran I/O blocks */
- static cilist io___2 = { 0, 5, 0, 0, 0 };
- static cilist io___4 = { 0, 5, 0, 0, 0 };
- static cilist io___7 = { 0, 5, 0, 0, 0 };
- static cilist io___9 = { 0, 5, 0, 0, 0 };
- static cilist io___11 = { 0, 5, 0, 0, 0 };
- static cilist io___13 = { 0, 5, 0, 0, 0 };
- static cilist io___15 = { 0, 5, 0, 0, 0 };
- static cilist io___17 = { 0, 5, 0, 0, 0 };
- static cilist io___19 = { 0, 6, 0, fmt_9997, 0 };
- static cilist io___20 = { 0, 5, 0, 0, 0 };
- static cilist io___23 = { 0, 6, 0, fmt_9996, 0 };
- static cilist io___24 = { 0, 5, 0, 0, 0 };
- static cilist io___26 = { 0, 6, 0, fmt_9997, 0 };
- static cilist io___27 = { 0, 5, 0, 0, 0 };
- static cilist io___29 = { 0, 5, 0, 0, 0 };
- static cilist io___31 = { 0, 6, 0, fmt_9997, 0 };
- static cilist io___32 = { 0, 5, 0, 0, 0 };
- static cilist io___34 = { 0, 6, 0, fmt_9995, 0 };
- static cilist io___35 = { 0, 6, 0, fmt_9994, 0 };
- static cilist io___36 = { 0, 6, 0, fmt_9993, 0 };
- static cilist io___37 = { 0, 6, 0, fmt_9992, 0 };
- static cilist io___38 = { 0, 6, 0, 0, 0 };
- static cilist io___39 = { 0, 6, 0, fmt_9984, 0 };
- static cilist io___40 = { 0, 6, 0, 0, 0 };
- static cilist io___41 = { 0, 6, 0, fmt_9999, 0 };
- static cilist io___42 = { 0, 6, 0, 0, 0 };
- static cilist io___45 = { 0, 6, 0, fmt_10002, 0 };
- static cilist io___46 = { 0, 6, 0, fmt_10001, 0 };
- static cilist io___47 = { 0, 6, 0, fmt_10000, 0 };
- static cilist io___48 = { 0, 6, 0, 0, 0 };
- static cilist io___50 = { 0, 5, 1, fmt_9988, 0 };
- static cilist io___53 = { 0, 6, 0, fmt_9990, 0 };
- static cilist io___55 = { 0, 6, 0, fmt_9998, 0 };
- static cilist io___68 = { 0, 6, 0, fmt_9989, 0 };
- static cilist io___69 = { 0, 6, 0, fmt_9989, 0 };
- static cilist io___70 = { 0, 6, 0, fmt_9989, 0 };
- static cilist io___71 = { 0, 6, 0, fmt_9989, 0 };
- static cilist io___73 = { 0, 6, 0, 0, 0 };
- static cilist io___74 = { 0, 6, 0, fmt_9987, 0 };
- static cilist io___75 = { 0, 6, 0, 0, 0 };
- static cilist io___82 = { 0, 6, 0, fmt_9986, 0 };
- static cilist io___83 = { 0, 6, 0, fmt_9985, 0 };
- static cilist io___84 = { 0, 6, 0, fmt_9991, 0 };
+ /* Local variables */
+ static integer nalf, idim[9];
+ static logical same;
+ static integer nbet, ntra;
+ static logical rewi;
+ extern /* Subroutine */ int dchk1_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, integer*);
+ extern /* Subroutine */ int dchk2_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, integer*);
+ extern /* Subroutine */ int dchk3_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, integer*);
+ extern /* Subroutine */ int dchk4_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, integer*);
+ extern /* Subroutine */ int dchk5_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublereal* alf, integer* nbet, doublereal* bet, integer* nmax, doublereal* ab, doublereal* aa, doublereal* as, doublereal* bb, doublereal* bs, doublereal* c__, doublereal* cc, doublereal* cs, doublereal* ct, doublereal* g, doublereal* w, integer*);
+ extern /* Subroutine */ int dchk6_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublereal* alf, integer* nbet, doublereal* bet, integer* nmax, doublereal* ab, doublereal* aa, doublereal* as, doublereal* bb, doublereal* bs, doublereal* c__, doublereal* cc, doublereal* cs, doublereal* ct, doublereal* g, doublereal* w, integer*);
+ static doublereal c__[4225] /* was [65][65] */, g[65];
+ static integer i__, j;
+ extern doublereal ddiff_(doublereal*, doublereal*);
+ static integer n;
+ static logical fatal;
+ static doublereal w[130];
+ extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*);
+ static logical trace;
+ static integer nidim;
+ static char snaps[32];
+ static integer isnum;
+ static logical ltest[6];
+ static doublereal aa[4225], ab[8450] /* was [65][130] */, bb[4225],
+ cc[4225], as[4225], bs[4225], cs[4225], ct[65];
+ static logical sfatal, corder;
+ static char snamet[12], transa[1], transb[1];
+ static doublereal thresh;
+ static logical rorder;
+ extern /* Subroutine */ void cd3chke_(char*);
+ static integer layout;
+ static logical ltestt, tsterr;
+ static doublereal alf[7];
+ extern logical lde_(doublereal*, doublereal*, integer*);
+ static doublereal bet[7], eps, err;
+ char tmpchar;
/* Test program for the DOUBLE PRECISION Level 3 Blas. */
@@ -592,15 +366,19 @@ static logical c_false = FALSE_;
infoc_1.noutc = 6;
/* Read name and unit number for snapshot output file and open file. */
- s_rsle(&io___2);
- do_lio(&c__9, &c__1, snaps, (ftnlen)32);
- e_rsle();
- s_rsle(&io___4);
- do_lio(&c__3, &c__1, (char *)&ntra, (ftnlen)sizeof(integer));
- e_rsle();
+ char line[80];
+
+ fgets(line,80,stdin);
+ sscanf(line,"'%s'",snaps);
+ fgets(line,80,stdin);
+#ifdef USE64BITINT
+ sscanf(line,"%ld",&ntra);
+#else
+ sscanf(line,"%d",&ntra);
+#endif
trace = ntra >= 0;
if (trace) {
- o__1.oerr = 0;
+/* o__1.oerr = 0;
o__1.ounit = ntra;
o__1.ofnmlen = 32;
o__1.ofnm = snaps;
@@ -609,149 +387,118 @@ static logical c_false = FALSE_;
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = 0;
- f_open(&o__1);
+ f_open(&o__1);*/
}
/* Read the flag that directs rewinding of the snapshot file. */
- s_rsle(&io___7);
- do_lio(&c__8, &c__1, (char *)&rewi, (ftnlen)sizeof(logical));
- e_rsle();
- rewi = rewi && trace;
+ fgets(line,80,stdin);
+ sscanf(line,"%d",&rewi);
+ rewi = rewi && trace;
/* Read the flag that directs stopping on any failure. */
- s_rsle(&io___9);
- do_lio(&c__8, &c__1, (char *)&sfatal, (ftnlen)sizeof(logical));
- e_rsle();
+ 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. */
- s_rsle(&io___11);
- do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
- e_rsle();
+ tsterr=FALSE_;
+ if (tmpchar=='T')tsterr=TRUE_;
/* Read the flag that indicates whether row-major data layout to be tested. */
- s_rsle(&io___13);
- do_lio(&c__3, &c__1, (char *)&layout, (ftnlen)sizeof(integer));
- e_rsle();
+ fgets(line,80,stdin);
+ sscanf(line,"%d",&layout);
/* Read the threshold value of the test ratio */
- s_rsle(&io___15);
- do_lio(&c__5, &c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
- e_rsle();
-
+ fgets(line,80,stdin);
+ sscanf(line,"%lf",&thresh);
/* Read and check the parameter values for the tests. */
/* Values of N */
- s_rsle(&io___17);
- do_lio(&c__3, &c__1, (char *)&nidim, (ftnlen)sizeof(integer));
- e_rsle();
+ fgets(line,80,stdin);
+#ifdef USE64BITINT
+ sscanf(line,"%ld",&nidim);
+#else
+ sscanf(line,"%d",&nidim);
+#endif
+
if (nidim < 1 || nidim > 9) {
- s_wsfe(&io___19);
- do_fio(&c__1, "N", (ftnlen)1);
- do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
- e_wsfe();
- goto L220;
+ fprintf(stderr,"NUMBER OF VALUES OF N IS LESS THAN 1 OR GREATER THAN 9");
+ goto L220;
}
- s_rsle(&io___20);
- i__1 = nidim;
- for (i__ = 1; i__ <= i__1; ++i__) {
- do_lio(&c__3, &c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
- }
- e_rsle();
+ fgets(line,80,stdin);
+#ifdef USE64BITINT
+ sscanf(line,"%ld %ld %ld %ld %ld %ld %ld %ld %ld",&idim[0],&idim[1],&idim[2],
+ &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]);
+#else
+ sscanf(line,"%d %d %d %d %d %d %d %d %d",&idim[0],&idim[1],&idim[2],
+ &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]);
+#endif
i__1 = nidim;
for (i__ = 1; i__ <= i__1; ++i__) {
- if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) {
- s_wsfe(&io___23);
- do_fio(&c__1, (char *)&c__65, (ftnlen)sizeof(integer));
- e_wsfe();
- goto L220;
- }
+ 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 */
- s_rsle(&io___24);
- do_lio(&c__3, &c__1, (char *)&nalf, (ftnlen)sizeof(integer));
- e_rsle();
+ fgets(line,80,stdin);
+#ifdef USE64BITINT
+ sscanf(line,"%ld",&nalf);
+#else
+ sscanf(line,"%d",&nalf);
+#endif
if (nalf < 1 || nalf > 7) {
- s_wsfe(&io___26);
- do_fio(&c__1, "ALPHA", (ftnlen)5);
- do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
- e_wsfe();
- goto L220;
+ fprintf(stderr,"VALUE OF ALPHA IS LESS THAN 0 OR GREATER THAN 7\n");
+ goto L220;
}
- s_rsle(&io___27);
- i__1 = nalf;
- for (i__ = 1; i__ <= i__1; ++i__) {
- do_lio(&c__5, &c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(doublereal)
- );
- }
- e_rsle();
+ 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 */
- s_rsle(&io___29);
- do_lio(&c__3, &c__1, (char *)&nbet, (ftnlen)sizeof(integer));
- e_rsle();
- if (nbet < 1 || nbet > 7) {
- s_wsfe(&io___31);
- do_fio(&c__1, "BETA", (ftnlen)4);
- do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
- e_wsfe();
- goto L220;
- }
- s_rsle(&io___32);
- i__1 = nbet;
- for (i__ = 1; i__ <= i__1; ++i__) {
- do_lio(&c__5, &c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(doublereal)
- );
+ fgets(line,80,stdin);
+#ifdef USE64BITINT
+ sscanf(line,"%ld",&nbet);
+#else
+ sscanf(line,"%d",&nbet);
+#endif
+ if (nalf < 1 || nbet > 7) {
+ fprintf(stderr,"VALUE OF BETA IS LESS THAN 0 OR GREATER THAN 7\n");
+ goto L220;
}
- e_rsle();
+ 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. */
- s_wsfe(&io___34);
- e_wsfe();
- s_wsfe(&io___35);
- i__1 = nidim;
- for (i__ = 1; i__ <= i__1; ++i__) {
- do_fio(&c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
- }
- e_wsfe();
- s_wsfe(&io___36);
- i__1 = nalf;
- for (i__ = 1; i__ <= i__1; ++i__) {
- do_fio(&c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(doublereal));
- }
- e_wsfe();
- s_wsfe(&io___37);
- i__1 = nbet;
- for (i__ = 1; i__ <= i__1; ++i__) {
- do_fio(&c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(doublereal));
- }
- e_wsfe();
+ 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) {
- s_wsle(&io___38);
- e_wsle();
- s_wsfe(&io___39);
- e_wsfe();
+ printf(" ERROR-EXITS WILL NOT BE TESTED\n");
}
- s_wsle(&io___40);
- e_wsle();
- s_wsfe(&io___41);
- do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
- e_wsfe();
- s_wsle(&io___42);
- e_wsle();
+ 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_;
- s_wsfe(&io___45);
- e_wsfe();
+ printf("COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED\n");
} else if (layout == 1) {
rorder = TRUE_;
- s_wsfe(&io___46);
- e_wsfe();
+ printf("ROW-MAJOR DATA LAYOUT IS TESTED\n");
} else if (layout == 0) {
corder = TRUE_;
- s_wsfe(&io___47);
- e_wsfe();
+ printf("COLUMN-MAJOR DATA LAYOUT IS TESTED\n");
}
- s_wsle(&io___48);
- e_wsle();
/* Read names of subroutines and flags which indicate */
/* whether they are to be tested. */
@@ -761,42 +508,35 @@ static logical c_false = FALSE_;
/* L20: */
}
L30:
- i__1 = s_rsfe(&io___50);
- if (i__1 != 0) {
- goto L60;
- }
- i__1 = do_fio(&c__1, snamet, (ftnlen)13);
- if (i__1 != 0) {
- goto L60;
+ if (! fgets(line,80,stdin)) {
+ goto L60;
}
- i__1 = do_fio(&c__1, (char *)<estt, (ftnlen)sizeof(logical));
- if (i__1 != 0) {
- goto L60;
- }
- i__1 = e_rsfe();
- if (i__1 != 0) {
- goto L60;
+ i__1 = sscanf(line,"%13c %c",snamet,&tmpchar);
+ ltestt=FALSE_;
+ if (tmpchar=='T')ltestt=TRUE_;
+ if (i__1 < 2) {
+ goto L60;
}
for (i__ = 1; i__ <= 7; ++i__) {
- if (s_cmp(snamet, snames + (i__ - 1) * 13, (ftnlen)13, (ftnlen)13) ==
- 0) {
- goto L50;
- }
+ if (s_cmp(snamet, snames[i__ - 1] , (ftnlen)13, (ftnlen)13) ==
+ 0) {
+ goto L50;
+ }
/* L40: */
}
- s_wsfe(&io___53);
- do_fio(&c__1, snamet, (ftnlen)13);
- e_wsfe();
- s_stop("", (ftnlen)0);
+ 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.cerr = 0;
cl__1.cunit = 5;
cl__1.csta = 0;
- f_clos(&cl__1);
+ f_clos(&cl__1);*/
/* Compute EPS (the machine precision). */
@@ -810,9 +550,7 @@ static logical c_false = FALSE_;
goto L70;
L80:
eps += eps;
- s_wsfe(&io___55);
- do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
- e_wsfe();
+ printf("RELATIVE MACHINE PRECISION IS TAKEN TO BE %9.1g\n",eps);
/* Check the reliability of DMMCH using exact data. */
@@ -846,13 +584,12 @@ static logical c_false = FALSE_;
fatal, &c__6, &c_true);
same = lde_(cc, ct, &n);
if (! same || err != 0.) {
- s_wsfe(&io___68);
- do_fio(&c__1, transa, (ftnlen)1);
- do_fio(&c__1, transb, (ftnlen)1);
- do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
- do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
- e_wsfe();
- s_stop("", (ftnlen)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], &
@@ -860,13 +597,12 @@ static logical c_false = FALSE_;
fatal, &c__6, &c_true);
same = lde_(cc, ct, &n);
if (! same || err != 0.) {
- s_wsfe(&io___69);
- do_fio(&c__1, transa, (ftnlen)1);
- do_fio(&c__1, transb, (ftnlen)1);
- do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
- do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
- e_wsfe();
- s_stop("", (ftnlen)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) {
@@ -887,13 +623,12 @@ static logical c_false = FALSE_;
fatal, &c__6, &c_true);
same = lde_(cc, ct, &n);
if (! same || err != 0.) {
- s_wsfe(&io___70);
- do_fio(&c__1, transa, (ftnlen)1);
- do_fio(&c__1, transb, (ftnlen)1);
- do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
- do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
- e_wsfe();
- s_stop("", (ftnlen)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], &
@@ -901,39 +636,32 @@ static logical c_false = FALSE_;
fatal, &c__6, &c_true);
same = lde_(cc, ct, &n);
if (! same || err != 0.) {
- s_wsfe(&io___71);
- do_fio(&c__1, transa, (ftnlen)1);
- do_fio(&c__1, transb, (ftnlen)1);
- do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
- do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
- e_wsfe();
- s_stop("", (ftnlen)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);
}
/* Test each subroutine in turn. */
for (isnum = 1; isnum <= 7; ++isnum) {
- s_wsle(&io___73);
- e_wsle();
if (! ltest[isnum - 1]) {
/* Subprogram is not to be tested. */
- s_wsfe(&io___74);
- do_fio(&c__1, snames + (isnum - 1) * 13, (ftnlen)13);
- e_wsfe();
+ printf("%13s WAS NOT TESTED\n",snames[isnum-1]);
} else {
- s_copy(srnamc_1.srnamt, snames + (isnum - 1) * 13, (ftnlen)13, (
+ s_copy(srnamc_1.srnamt, snames[isnum - 1], (ftnlen)13, (
ftnlen)13);
/* Test error exits. */
if (tsterr) {
- cd3chke_(snames + (isnum - 1) * 13);
- s_wsle(&io___75);
- e_wsle();
+ cd3chke_(snames[isnum - 1]);
}
/* Test computations. */
infoc_1.infot = 0;
infoc_1.ok = TRUE_;
fatal = FALSE_;
- switch (isnum) {
+ switch ((int)isnum) {
case 1: goto L140;
case 2: goto L150;
case 3: goto L160;
@@ -945,13 +673,13 @@ static logical c_false = FALSE_;
/* Test DGEMM, 01. */
L140:
if (corder) {
- dchk1_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
}
if (rorder) {
- dchk1_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
@@ -960,13 +688,13 @@ static logical c_false = FALSE_;
/* Test DSYMM, 02. */
L150:
if (corder) {
- dchk2_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
}
if (rorder) {
- dchk2_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
@@ -975,13 +703,13 @@ static logical c_false = FALSE_;
/* Test DTRMM, 03, DTRSM, 04. */
L160:
if (corder) {
- dchk3_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
}
if (rorder) {
- dchk3_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
@@ -990,13 +718,13 @@ static logical c_false = FALSE_;
/* Test DSYRK, 05. */
L170:
if (corder) {
- dchk4_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
}
if (rorder) {
- dchk4_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
@@ -1005,13 +733,13 @@ static logical c_false = FALSE_;
/* Test DSYR2K, 06. */
L180:
if (corder) {
- dchk5_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
}
if (rorder) {
- dchk5_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
@@ -1020,13 +748,13 @@ static logical c_false = FALSE_;
/* Test DGEMMTR, 07. */
L185:
if (corder) {
- dchk6_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ dchk6_(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) {
- dchk6_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ dchk6_(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);
@@ -1040,32 +768,29 @@ static logical c_false = FALSE_;
}
/* L200: */
}
- s_wsfe(&io___82);
- e_wsfe();
+ printf("\nEND OF TESTS\n");
goto L230;
L210:
- s_wsfe(&io___83);
- e_wsfe();
+ printf("\n****** FATAL ERROR - TESTS ABANDONED ******\n");
goto L230;
L220:
- s_wsfe(&io___84);
- e_wsfe();
+ printf("AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM\n");
+ printf("****** TESTS ABANDONED ******\n");
L230:
if (trace) {
- cl__1.cerr = 0;
+/* cl__1.cerr = 0;
cl__1.cunit = ntra;
cl__1.csta = 0;
- f_clos(&cl__1);
+ f_clos(&cl__1);*/
}
- cl__1.cerr = 0;
+/* cl__1.cerr = 0;
cl__1.cunit = 6;
cl__1.csta = 0;
- f_clos(&cl__1);
- s_stop("", (ftnlen)0);
-
+ f_clos(&cl__1);*/
+ exit(0);
/* End of DBLAT3. */
@@ -1082,72 +807,34 @@ static logical c_false = FALSE_;
{
/* Initialized data */
- static char ich[3] = "NTC";
-
- /* Format strings */
- static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
- "TAKEN ON VALID CALL *******\002)";
- static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
- " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
- static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
- "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
- " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
- "BER:\002)";
+ 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;
- alist al__1;
-
- /* Local variables */
- integer i__, k, m, n, ia, ib, ma, mb, na, nb, nc, ik, im, in, ks, ms, ns,
- ica, icb, laa, lbb, lda, lcc, ldb, ldc;
- extern logical lde_(doublereal *, doublereal *, integer *);
- doublereal als, bls, err, beta;
- integer ldas, ldbs, ldcs;
- logical same, null;
- extern /* Subroutine */ int dmake_(char *, char *, char *, integer *,
- integer *, doublereal *, integer *, doublereal *, integer *,
- logical *, doublereal *);
- doublereal alpha;
- extern /* Subroutine */ int dmmch_(char *, char *, integer *, integer *,
- integer *, doublereal *, doublereal *, integer *, doublereal *,
- integer *, doublereal *, doublereal *, integer *, doublereal *,
- doublereal *, doublereal *, integer *, doublereal *, doublereal *,
- logical *, integer *, logical *);
- logical isame[13], trana, tranb;
- integer nargs;
- logical reset;
- extern /* Subroutine */ int dprcn1_(integer *, integer *, char *, integer
- *, char *, char *, integer *, integer *, integer *, doublereal *,
- integer *, integer *, doublereal *, integer *), cdgemm_(integer *, char *, char *, integer *, integer *,
- integer *, doublereal *, doublereal *, integer *, doublereal *,
- integer *, doublereal *, doublereal *, integer *);
- extern logical lderes_(char *, char *, integer *, integer *, doublereal *,
- doublereal *, integer *);
- char tranas[1], tranbs[1], transa[1], transb[1];
- doublereal errmax;
-
- /* Fortran I/O blocks */
- static cilist io___128 = { 0, 0, 0, fmt_9994, 0 };
- static cilist io___131 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___133 = { 0, 0, 0, fmt_10000, 0 };
- static cilist io___134 = { 0, 0, 0, fmt_10001, 0 };
- static cilist io___135 = { 0, 0, 0, fmt_10002, 0 };
- static cilist io___136 = { 0, 0, 0, fmt_10003, 0 };
- static cilist io___137 = { 0, 0, 0, fmt_9996, 0 };
+ /* Local variables */
+ static doublereal beta;
+ static integer ldas, ldbs, ldcs;
+ static logical same, null;
+ static integer i__, k, m, n;
+ extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*);
+ static doublereal alpha;
+ extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*);
+ static logical isame[13], trana, tranb;
+ static integer nargs;
+ static logical reset;
+ extern /* Subroutine */ void dprcn1_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, integer*, doublereal*, integer*, integer*, doublereal*, integer*);
+ static integer ia, ib, ma, mb, na, nb, nc, ik, im, in;
+ extern /* Subroutine */ void cdgemm_(integer*, char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*);
+ static integer ks, ms, ns;
+ extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*);
+ static char tranas[1], tranbs[1], transa[1], transb[1];
+ static doublereal errmax;
+ static integer ica, icb, laa, lbb, lda, lcc, ldb, ldc;
+ extern logical lde_(doublereal*, doublereal*, integer*);
+ static doublereal als, bls, err;
/* Tests DGEMM. */
@@ -1323,9 +1010,9 @@ static logical c_false = FALSE_;
&ldb, &beta, &ldc);
}
if (*rewi) {
- al__1.aerr = 0;
+/* al__1.aerr = 0;
al__1.aunit = *ntra;
- f_rew(&al__1);
+ f_rew(&al__1);*/
}
cdgemm_(iorder, transa, transb, &m, &n, &k, &
alpha, &aa[1], &lda, &bb[1], &ldb, &
@@ -1334,9 +1021,7 @@ static logical c_false = FALSE_;
/* 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;
}
@@ -1372,11 +1057,7 @@ static logical c_false = FALSE_;
for (i__ = 1; i__ <= i__6; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
- io___131.ciunit = *nout;
- s_wsfe(&io___131);
- do_fio(&c__1, (char *)&i__, (ftnlen)
- sizeof(integer));
- e_wsfe();
+ printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
}
/* L40: */
}
@@ -1430,44 +1111,25 @@ static logical c_false = FALSE_;
if (errmax < *thresh) {
if (*iorder == 0) {
- io___133.ciunit = *nout;
- s_wsfe(&io___133);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
if (*iorder == 1) {
- io___134.ciunit = *nout;
- s_wsfe(&io___134);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
} else {
if (*iorder == 0) {
- io___135.ciunit = *nout;
- s_wsfe(&io___135);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
- e_wsfe();
+ 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) {
- io___136.ciunit = *nout;
- s_wsfe(&io___136);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
- e_wsfe();
+ 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:
- io___137.ciunit = *nout;
- s_wsfe(&io___137);
- do_fio(&c__1, sname, (ftnlen)13);
- e_wsfe();
+ printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
dprcn1_(nout, &nc, sname, iorder, transa, transb, &m, &n, &k, &alpha, &
lda, &ldb, &beta, &ldc);
@@ -1480,24 +1142,14 @@ static logical c_false = FALSE_;
} /* dchk1_ */
-/* Subroutine */ int dprcn1_(integer *nout, integer *nc, char *sname, integer
+/* Subroutine */ void dprcn1_(integer *nout, integer *nc, char *sname, integer
*iorder, char *transa, char *transb, integer *m, integer *n, integer *
k, doublereal *alpha, integer *lda, integer *ldb, doublereal *beta,
integer *ldc)
{
- /* Format strings */
- static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
- "a14,\002,\002,a14,\002,\002)";
- static char fmt_9994[] = "(20x,3(i3,\002,\002),f4.1,\002, A,\002,i3,\002"
- ", B,\002,i3,\002,\002,f4.1,\002, \002,\002C,\002,i3,\002).\002)";
/* Local variables */
- char crc[14], cta[14], ctb[14];
-
- /* Fortran I/O blocks */
- static cilist io___141 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___142 = { 0, 0, 0, fmt_9994, 0 };
-
+ static char crc[14], cta[14], ctb[14];
if (*(unsigned char *)transa == 'N') {
s_copy(cta, " CblasNoTrans", (ftnlen)14, (ftnlen)14);
@@ -1518,26 +1170,8 @@ static logical c_false = FALSE_;
} else {
s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
}
- io___141.ciunit = *nout;
- s_wsfe(&io___141);
- do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, crc, (ftnlen)14);
- do_fio(&c__1, cta, (ftnlen)14);
- do_fio(&c__1, ctb, (ftnlen)14);
- e_wsfe();
- io___142.ciunit = *nout;
- s_wsfe(&io___142);
- do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
- do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(doublereal));
- do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
- e_wsfe();
- return 0;
+ 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_ */
@@ -1551,81 +1185,41 @@ static logical c_false = FALSE_;
{
/* Initialized data */
- static char ichs[2] = "LR";
- static char ichu[2] = "UL";
-
- /* Format strings */
- static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
- "TAKEN ON VALID CALL *******\002)";
- static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
- " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
- static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
- "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
- " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
- "BER:\002)";
+ 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;
- alist al__1;
-
- /* Local variables */
- integer i__, m, n, ia, ib, na, nc, im, in, ms, ns, laa, lbb, lda, lcc,
- ldb, ldc;
- extern logical lde_(doublereal *, doublereal *, integer *);
- integer ics;
- doublereal als, bls;
- integer icu;
- doublereal err, beta;
- integer ldas, ldbs, ldcs;
- logical same;
- char side[1];
- logical left, null;
- char uplo[1];
- extern /* Subroutine */ int dmake_(char *, char *, char *, integer *,
- integer *, doublereal *, integer *, doublereal *, integer *,
- logical *, doublereal *);
- doublereal alpha;
- extern /* Subroutine */ int dmmch_(char *, char *, integer *, integer *,
- integer *, doublereal *, doublereal *, integer *, doublereal *,
- integer *, doublereal *, doublereal *, integer *, doublereal *,
- doublereal *, doublereal *, integer *, doublereal *, doublereal *,
- logical *, integer *, logical *);
- logical isame[13];
- char sides[1];
- integer nargs;
- logical reset;
- char uplos[1];
- extern /* Subroutine */ int dprcn2_(integer *, integer *, char *, integer
- *, char *, char *, integer *, integer *, doublereal *, integer *,
- integer *, doublereal *, integer *);
- extern logical lderes_(char *, char *, integer *, integer *, doublereal *,
- doublereal *, integer *);
- extern /* Subroutine */ int cdsymm_(integer *, char *, char *, integer *,
- integer *, doublereal *, doublereal *, integer *, doublereal *,
- integer *, doublereal *, doublereal *, integer *);
- doublereal errmax;
-
- /* Fortran I/O blocks */
- static cilist io___180 = { 0, 0, 0, fmt_9994, 0 };
- static cilist io___183 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___185 = { 0, 0, 0, fmt_10000, 0 };
- static cilist io___186 = { 0, 0, 0, fmt_10001, 0 };
- static cilist io___187 = { 0, 0, 0, fmt_10002, 0 };
- static cilist io___188 = { 0, 0, 0, fmt_10003, 0 };
- static cilist io___189 = { 0, 0, 0, fmt_9996, 0 };
+ /* Local variables */
+ static doublereal beta;
+ static integer ldas, ldbs, ldcs;
+ static logical same;
+ static char side[1];
+ static logical left, null;
+ static char uplo[1];
+ static integer i__, m, n;
+ extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*);
+ static doublereal alpha;
+ extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*);
+ static logical isame[13];
+ static char sides[1];
+ static integer nargs;
+ static logical reset;
+ static char uplos[1];
+ extern /* Subroutine */ void dprcn2_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublereal*, integer*, integer*, doublereal*, integer*);
+ static integer ia, ib, na, nc, im, in, ms, ns;
+ extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*);
+ extern /* Subroutine */ void cdsymm_(integer*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*);
+ static doublereal errmax;
+ static integer laa, lbb, lda, lcc, ldb, ldc;
+ extern logical lde_(doublereal*, doublereal*, integer*);
+ static integer ics;
+ static doublereal als, bls;
+ static integer icu;
+ static doublereal err;
/* Tests DSYMM. */
@@ -1781,9 +1375,9 @@ static logical c_false = FALSE_;
;
}
if (*rewi) {
- al__1.aerr = 0;
+/* al__1.aerr = 0;
al__1.aunit = *ntra;
- f_rew(&al__1);
+ f_rew(&al__1);*/
}
cdsymm_(iorder, side, uplo, &m, &n, &alpha, &aa[1]
, &lda, &bb[1], &ldb, &beta, &cc[1], &ldc);
@@ -1791,9 +1385,7 @@ static logical c_false = FALSE_;
/* Check if error-exit was taken incorrectly. */
if (! infoc_1.ok) {
- io___180.ciunit = *nout;
- s_wsfe(&io___180);
- e_wsfe();
+ printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");
*fatal = TRUE_;
goto L110;
}
@@ -1828,11 +1420,7 @@ static logical c_false = FALSE_;
for (i__ = 1; i__ <= i__5; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
- io___183.ciunit = *nout;
- s_wsfe(&io___183);
- do_fio(&c__1, (char *)&i__, (ftnlen)
- sizeof(integer));
- e_wsfe();
+ printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
}
/* L40: */
}
@@ -1890,44 +1478,25 @@ static logical c_false = FALSE_;
if (errmax < *thresh) {
if (*iorder == 0) {
- io___185.ciunit = *nout;
- s_wsfe(&io___185);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
if (*iorder == 1) {
- io___186.ciunit = *nout;
- s_wsfe(&io___186);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
} else {
if (*iorder == 0) {
- io___187.ciunit = *nout;
- s_wsfe(&io___187);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
- e_wsfe();
+ 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) {
- io___188.ciunit = *nout;
- s_wsfe(&io___188);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
- e_wsfe();
+ 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:
- io___189.ciunit = *nout;
- s_wsfe(&io___189);
- do_fio(&c__1, sname, (ftnlen)13);
- e_wsfe();
+ printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
dprcn2_(nout, &nc, sname, iorder, side, uplo, &m, &n, &alpha, &lda, &ldb,
&beta, &ldc);
@@ -1941,23 +1510,13 @@ static logical c_false = FALSE_;
} /* dchk2_ */
-/* Subroutine */ int dprcn2_(integer *nout, integer *nc, char *sname, integer
+/* Subroutine */ void dprcn2_(integer *nout, integer *nc, char *sname, integer
*iorder, char *side, char *uplo, integer *m, integer *n, doublereal *
alpha, integer *lda, integer *ldb, doublereal *beta, integer *ldc)
{
- /* Format strings */
- static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
- "a14,\002,\002,a14,\002,\002)";
- static char fmt_9994[] = "(20x,2(i3,\002,\002),f4.1,\002, A,\002,i3,\002"
- ", B,\002,i3,\002,\002,f4.1,\002, \002,\002C,\002,i3,\002).\002)";
/* Local variables */
- char cs[14], cu[14], crc[14];
-
- /* Fortran I/O blocks */
- static cilist io___193 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___194 = { 0, 0, 0, fmt_9994, 0 };
-
+ static char cs[14], cu[14], crc[14];
if (*(unsigned char *)side == 'L') {
s_copy(cs, " CblasLeft", (ftnlen)14, (ftnlen)14);
@@ -1974,25 +1533,8 @@ static logical c_false = FALSE_;
} else {
s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
}
- io___193.ciunit = *nout;
- s_wsfe(&io___193);
- do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, crc, (ftnlen)14);
- do_fio(&c__1, cs, (ftnlen)14);
- do_fio(&c__1, cu, (ftnlen)14);
- e_wsfe();
- io___194.ciunit = *nout;
- s_wsfe(&io___194);
- do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
- do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(doublereal));
- do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
- e_wsfe();
- return 0;
+ 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_ */
@@ -2005,88 +1547,45 @@ static logical c_false = FALSE_;
{
/* Initialized data */
- static char ichu[2] = "UL";
- static char icht[3] = "NTC";
- static char ichd[2] = "UN";
- static char ichs[2] = "LR";
-
- /* Format strings */
- static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
- "TAKEN ON VALID CALL *******\002)";
- static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
- " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
- static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
- "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
- " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
- "BER:\002)";
+ 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;
- alist al__1;
/* Local variables */
- integer i__, j, m, n, ia, na, nc, im, in, ms, ns, laa, icd, lbb, lda, ldb;
- extern logical lde_(doublereal *, doublereal *, integer *);
- integer ics;
- doublereal als;
- integer ict, icu;
- doublereal err;
- char diag[1];
- integer ldas, ldbs;
- logical same;
- char side[1];
- logical left, null;
- char uplo[1];
- extern /* Subroutine */ int dmake_(char *, char *, char *, integer *,
- integer *, doublereal *, integer *, doublereal *, integer *,
- logical *, doublereal *);
- doublereal alpha;
- char diags[1];
- extern /* Subroutine */ int dmmch_(char *, char *, integer *, integer *,
- integer *, doublereal *, doublereal *, integer *, doublereal *,
- integer *, doublereal *, doublereal *, integer *, doublereal *,
- doublereal *, doublereal *, integer *, doublereal *, doublereal *,
- logical *, integer *, logical *);
- logical isame[13];
- char sides[1];
- integer nargs;
- logical reset;
- char uplos[1];
- extern /* Subroutine */ int dprcn3_(integer *, integer *, char *, integer
- *, char *, char *, char *, char *, integer *, integer *,
- doublereal *, integer *, integer *);
- extern logical lderes_(char *, char *, integer *, integer *, doublereal *,
- doublereal *, integer *);
- extern /* Subroutine */ int cdtrmm_(integer *, char *, char *, char *,
- char *, integer *, integer *, doublereal *, doublereal *, integer
- *, doublereal *, integer *);
- char tranas[1], transa[1];
- extern /* Subroutine */ int cdtrsm_(integer *, char *, char *, char *,
- char *, integer *, integer *, doublereal *, doublereal *, integer
- *, doublereal *, integer *);
- doublereal errmax;
-
- /* Fortran I/O blocks */
- static cilist io___235 = { 0, 0, 0, fmt_9994, 0 };
- static cilist io___238 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___240 = { 0, 0, 0, fmt_10000, 0 };
- static cilist io___241 = { 0, 0, 0, fmt_10001, 0 };
- static cilist io___242 = { 0, 0, 0, fmt_10002, 0 };
- static cilist io___243 = { 0, 0, 0, fmt_10003, 0 };
- static cilist io___244 = { 0, 0, 0, fmt_9996, 0 };
-
-
+ static char diag[1];
+ static integer ldas, ldbs;
+ static logical same;
+ static char side[1];
+ static logical left, null;
+ static char uplo[1];
+ static integer i__, j, m, n;
+ extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*);
+ static doublereal alpha;
+ static char diags[1];
+ extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*);
+ static logical isame[13];
+ static char sides[1];
+ static integer nargs;
+ static logical reset;
+ static char uplos[1];
+ extern /* Subroutine */ void dprcn3_(integer*, integer*, char*, integer*, char*, char*, char*, char*, integer*, integer*, doublereal*, integer*, integer*);
+ static integer ia, na, nc, im, in, ms, ns;
+ extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*);
+ extern /* Subroutine */ void cdtrmm_(integer*, char*, char*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*);
+ static char tranas[1], transa[1];
+ extern /* Subroutine */ void cdtrsm_(integer*, char*, char*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*);
+ static doublereal errmax;
+ static integer laa, icd, lbb, lda, ldb;
+ extern logical lde_(doublereal*, doublereal*, integer*);
+ static integer ics;
+ static doublereal als;
+ static integer ict, icu;
+ static doublereal err;
/* Tests DTRMM and DTRSM. */
@@ -2237,9 +1736,9 @@ static logical c_false = FALSE_;
&n, &alpha, &lda, &ldb);
}
if (*rewi) {
- al__1.aerr = 0;
+/* al__1.aerr = 0;
al__1.aunit = *ntra;
- f_rew(&al__1);
+ f_rew(&al__1);*/
}
cdtrmm_(iorder, side, uplo, transa, diag,
&m, &n, &alpha, &aa[1], &lda, &bb[
@@ -2252,9 +1751,9 @@ static logical c_false = FALSE_;
&n, &alpha, &lda, &ldb);
}
if (*rewi) {
- al__1.aerr = 0;
+/* al__1.aerr = 0;
al__1.aunit = *ntra;
- f_rew(&al__1);
+ f_rew(&al__1);*/
}
cdtrsm_(iorder, side, uplo, transa, diag,
&m, &n, &alpha, &aa[1], &lda, &bb[
@@ -2264,9 +1763,7 @@ static logical c_false = FALSE_;
/* Check if error-exit was taken incorrectly. */
if (! infoc_1.ok) {
- io___235.ciunit = *nout;
- s_wsfe(&io___235);
- e_wsfe();
+ printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");
*fatal = TRUE_;
goto L150;
}
@@ -2302,11 +1799,7 @@ static logical c_false = FALSE_;
for (i__ = 1; i__ <= i__4; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
- io___238.ciunit = *nout;
- s_wsfe(&io___238);
- do_fio(&c__1, (char *)&i__, (ftnlen)
- sizeof(integer));
- e_wsfe();
+ printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
}
/* L50: */
}
@@ -2328,8 +1821,7 @@ static logical c_false = FALSE_;
c_b104, &c__[c_offset],
nmax, &ct[1], &g[1], &bb[
1], &ldb, eps, &err,
- fatal, nout, &c_true, (
- ftnlen)1, (ftnlen)1);
+ fatal, nout, &c_true);
} else {
dmmch_("N", transa, &m, &n, &n, &
alpha, &b[b_offset], nmax,
@@ -2410,44 +1902,25 @@ static logical c_false = FALSE_;
if (errmax < *thresh) {
if (*iorder == 0) {
- io___240.ciunit = *nout;
- s_wsfe(&io___240);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
if (*iorder == 1) {
- io___241.ciunit = *nout;
- s_wsfe(&io___241);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
} else {
if (*iorder == 0) {
- io___242.ciunit = *nout;
- s_wsfe(&io___242);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
- e_wsfe();
+ 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) {
- io___243.ciunit = *nout;
- s_wsfe(&io___243);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
- e_wsfe();
+ 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:
- io___244.ciunit = *nout;
- s_wsfe(&io___244);
- do_fio(&c__1, sname, (ftnlen)13);
- e_wsfe();
+ printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
if (*trace) {
dprcn3_(ntra, &nc, sname, iorder, side, uplo, transa, diag, &m, &n, &
alpha, &lda, &ldb);
@@ -2463,23 +1936,13 @@ static logical c_false = FALSE_;
} /* dchk3_ */
-/* Subroutine */ int dprcn3_(integer *nout, integer *nc, char *sname, integer
+/* Subroutine */ void dprcn3_(integer *nout, integer *nc, char *sname, integer
*iorder, char *side, char *uplo, char *transa, char *diag, integer *m,
integer *n, doublereal *alpha, integer *lda, integer *ldb)
{
- /* Format strings */
- static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
- "a14,\002,\002,a14,\002,\002)";
- static char fmt_9994[] = "(22x,2(a14,\002,\002),2(i3,\002,\002),f4.1,"
- "\002, A,\002,i3,\002, B,\002,i3,\002).\002)";
/* Local variables */
- char ca[14], cd[14], cs[14], cu[14], crc[14];
-
- /* Fortran I/O blocks */
- static cilist io___250 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___251 = { 0, 0, 0, fmt_9994, 0 };
-
+ 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);
@@ -2508,25 +1971,8 @@ static logical c_false = FALSE_;
} else {
s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
}
- io___250.ciunit = *nout;
- s_wsfe(&io___250);
- do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, crc, (ftnlen)14);
- do_fio(&c__1, cs, (ftnlen)14);
- do_fio(&c__1, cu, (ftnlen)14);
- e_wsfe();
- io___251.ciunit = *nout;
- s_wsfe(&io___251);
- do_fio(&c__1, ca, (ftnlen)14);
- do_fio(&c__1, cd, (ftnlen)14);
- do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
- do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
- e_wsfe();
- return 0;
+ 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_ */
@@ -2540,85 +1986,42 @@ static logical c_false = FALSE_;
{
/* Initialized data */
- static char icht[3] = "NTC";
- static char ichu[2] = "UL";
-
- /* Format strings */
- static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
- "TAKEN ON VALID CALL *******\002)";
- static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
- " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
- static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
- "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
- " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
- " \002,i3)";
- static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
- "BER:\002)";
+ 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;
- alist al__1;
-
- /* Local variables */
- integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa,
- lda, lcc, ldc;
- extern logical lde_(doublereal *, doublereal *, integer *);
- doublereal als;
- integer ict, icu;
- doublereal err, beta;
- integer ldas, ldcs;
- logical same;
- doublereal bets;
- logical tran, null;
- char uplo[1];
- extern /* Subroutine */ int dmake_(char *, char *, char *, integer *,
- integer *, doublereal *, integer *, doublereal *, integer *,
- logical *, doublereal *);
- doublereal alpha;
- extern /* Subroutine */ int dmmch_(char *, char *, integer *, integer *,
- integer *, doublereal *, doublereal *, integer *, doublereal *,
- integer *, doublereal *, doublereal *, integer *, doublereal *,
- doublereal *, doublereal *, integer *, doublereal *, doublereal *,
- logical *, integer *, logical *);
- logical isame[13];
- integer nargs;
- logical reset;
- char trans[1];
- logical upper;
- char uplos[1];
- extern /* Subroutine */ int dprcn4_(integer *, integer *, char *, integer
- *, char *, char *, integer *, integer *, doublereal *, integer *,
- doublereal *, integer *);
- extern logical lderes_(char *, char *, integer *, integer *, doublereal *,
- doublereal *, integer *);
- doublereal errmax;
- extern /* Subroutine */ int cdsyrk_(integer *, char *, char *, integer *,
- integer *, doublereal *, doublereal *, integer *, doublereal *,
- doublereal *, integer *);
- char transs[1];
-
- /* Fortran I/O blocks */
- static cilist io___288 = { 0, 0, 0, fmt_9993, 0 };
- static cilist io___291 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___297 = { 0, 0, 0, fmt_10000, 0 };
- static cilist io___298 = { 0, 0, 0, fmt_10001, 0 };
- static cilist io___299 = { 0, 0, 0, fmt_10002, 0 };
- static cilist io___300 = { 0, 0, 0, fmt_10003, 0 };
- static cilist io___301 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___302 = { 0, 0, 0, fmt_9996, 0 };
+ /* Local variables */
+ static doublereal beta;
+ static integer ldas, ldcs;
+ static logical same;
+ static doublereal bets;
+ static logical tran, null;
+ static char uplo[1];
+ static integer i__, j, k, n;
+ extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*);
+ static doublereal alpha;
+ extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*);
+ static logical isame[13];
+ static integer nargs;
+ static logical reset;
+ static char trans[1];
+ static logical upper;
+ static char uplos[1];
+ extern /* Subroutine */ void dprcn4_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*);
+ static integer ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns;
+ extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*);
+ static doublereal errmax;
+ extern /* Subroutine */ void cdsyrk_(integer*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, integer*);
+ static char transs[1];
+ static integer laa, lda, lcc, ldc;
+ extern logical lde_(doublereal*, doublereal*, integer*);
+ static doublereal als;
+ static integer ict, icu;
+ static doublereal err;
/* Tests DSYRK. */
@@ -2754,9 +2157,9 @@ static logical c_false = FALSE_;
&n, &k, &alpha, &lda, &beta, &ldc);
}
if (*rewi) {
- al__1.aerr = 0;
+/* al__1.aerr = 0;
al__1.aunit = *ntra;
- f_rew(&al__1);
+ f_rew(&al__1);*/
}
cdsyrk_(iorder, uplo, trans, &n, &k, &alpha, &aa[
1], &lda, &beta, &cc[1], &ldc);
@@ -2764,9 +2167,7 @@ static logical c_false = FALSE_;
/* Check if error-exit was taken incorrectly. */
if (! infoc_1.ok) {
- io___288.ciunit = *nout;
- s_wsfe(&io___288);
- e_wsfe();
+ printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");
*fatal = TRUE_;
goto L120;
}
@@ -2799,12 +2200,8 @@ static logical c_false = FALSE_;
for (i__ = 1; i__ <= i__5; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
- io___291.ciunit = *nout;
- s_wsfe(&io___291);
- do_fio(&c__1, (char *)&i__, (ftnlen)
- sizeof(integer));
- e_wsfe();
- }
+ printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
+ }
/* L30: */
}
if (! same) {
@@ -2882,52 +2279,30 @@ static logical c_false = FALSE_;
if (errmax < *thresh) {
if (*iorder == 0) {
- io___297.ciunit = *nout;
- s_wsfe(&io___297);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
if (*iorder == 1) {
- io___298.ciunit = *nout;
- s_wsfe(&io___298);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
} else {
if (*iorder == 0) {
- io___299.ciunit = *nout;
- s_wsfe(&io___299);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
- e_wsfe();
+ 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) {
- io___300.ciunit = *nout;
- s_wsfe(&io___300);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
- e_wsfe();
+ 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) {
- io___301.ciunit = *nout;
- s_wsfe(&io___301);
- do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j);
}
L120:
- io___302.ciunit = *nout;
- s_wsfe(&io___302);
- do_fio(&c__1, sname, (ftnlen)13);
- e_wsfe();
+ printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
dprcn4_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &
beta, &ldc);
@@ -2941,23 +2316,13 @@ static logical c_false = FALSE_;
} /* dchk4_ */
-/* Subroutine */ int dprcn4_(integer *nout, integer *nc, char *sname, integer
+/* Subroutine */ void dprcn4_(integer *nout, integer *nc, char *sname, integer
*iorder, char *uplo, char *transa, integer *n, integer *k, doublereal
*alpha, integer *lda, doublereal *beta, integer *ldc)
{
- /* Format strings */
- static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002,"
- "\002))";
- static char fmt_9994[] = "(20x,2(i3,\002,\002),f4.1,\002, A,\002,i3"
- ",\002,\002,f4.1,\002, C,\002,i3,\002).\002)";
/* Local variables */
- char ca[14], cu[14], crc[14];
-
- /* Fortran I/O blocks */
- static cilist io___306 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___307 = { 0, 0, 0, fmt_9994, 0 };
-
+ static char ca[14], cu[14], crc[14];
if (*(unsigned char *)uplo == 'U') {
s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14);
@@ -2976,24 +2341,8 @@ static logical c_false = FALSE_;
} else {
s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
}
- io___306.ciunit = *nout;
- s_wsfe(&io___306);
- do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, crc, (ftnlen)14);
- do_fio(&c__1, cu, (ftnlen)14);
- do_fio(&c__1, ca, (ftnlen)14);
- e_wsfe();
- io___307.ciunit = *nout;
- s_wsfe(&io___307);
- do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
- do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(doublereal));
- do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
- e_wsfe();
- return 0;
+ 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_ */
@@ -3007,86 +2356,42 @@ static logical c_false = FALSE_;
{
/* Initialized data */
- static char icht[3] = "NTC";
- static char ichu[2] = "UL";
-
- /* Format strings */
- static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
- "TAKEN ON VALID CALL *******\002)";
- static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
- " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
- static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
- "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
- " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
- " \002,i3)";
- static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
- "BER:\002)";
+ 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;
- alist al__1;
-
- /* Local variables */
- integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa,
- lbb, lda, lcc, ldb, ldc;
- extern logical lde_(doublereal *, doublereal *, integer *);
- doublereal als;
- integer ict, icu;
- doublereal err;
- integer jjab;
- doublereal beta;
- integer ldas, ldbs, ldcs;
- logical same;
- doublereal bets;
- logical tran, null;
- char uplo[1];
- extern /* Subroutine */ int dmake_(char *, char *, char *, integer *,
- integer *, doublereal *, integer *, doublereal *, integer *,
- logical *, doublereal *);
- doublereal alpha;
- extern /* Subroutine */ int dmmch_(char *, char *, integer *, integer *,
- integer *, doublereal *, doublereal *, integer *, doublereal *,
- integer *, doublereal *, doublereal *, integer *, doublereal *,
- doublereal *, doublereal *, integer *, doublereal *, doublereal *,
- logical *, integer *, logical *);
- logical isame[13];
- integer nargs;
- logical reset;
- char trans[1];
- logical upper;
- char uplos[1];
- extern /* Subroutine */ int dprcn5_(integer *, integer *, char *, integer
- *, char *, char *, integer *, integer *, doublereal *, integer *,
- integer *, doublereal *, integer *);
- extern logical lderes_(char *, char *, integer *, integer *, doublereal *,
- doublereal *, integer *);
- doublereal errmax;
- char transs[1];
- extern /* Subroutine */ int cdsyr2k_(integer *, char *, char *, integer *,
- integer *, doublereal *, doublereal *, integer *, doublereal *,
- integer *, doublereal *, doublereal *, integer *);
-
- /* Fortran I/O blocks */
- static cilist io___347 = { 0, 0, 0, fmt_9993, 0 };
- static cilist io___350 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___357 = { 0, 0, 0, fmt_10000, 0 };
- static cilist io___358 = { 0, 0, 0, fmt_10001, 0 };
- static cilist io___359 = { 0, 0, 0, fmt_10002, 0 };
- static cilist io___360 = { 0, 0, 0, fmt_10003, 0 };
- static cilist io___361 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___362 = { 0, 0, 0, fmt_9996, 0 };
+ /* Local variables */
+ static integer jjab;
+ static doublereal beta;
+ static integer ldas, ldbs, ldcs;
+ static logical same;
+ static doublereal bets;
+ static logical tran, null;
+ static char uplo[1];
+ static integer i__, j, k, n;
+ extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*);
+ static doublereal alpha;
+ extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*);
+ static logical isame[13];
+ static integer nargs;
+ static logical reset;
+ static char trans[1];
+ static logical upper;
+ static char uplos[1];
+ extern /* Subroutine */ void dprcn5_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublereal*, integer*, integer*, doublereal*, integer*);
+ static integer ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns;
+ extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*);
+ static doublereal errmax;
+ static char transs[1];
+ static integer laa, lbb, lda, lcc, ldb, ldc;
+ extern logical lde_(doublereal*, doublereal*, integer*);
+ extern /* Subroutine */ void cdsyr2k_(integer*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*);
+ static doublereal als;
+ static integer ict, icu;
+ static doublereal err;
/* Tests DSYR2K. */
@@ -3244,9 +2549,9 @@ static logical c_false = FALSE_;
;
}
if (*rewi) {
- al__1.aerr = 0;
+/* al__1.aerr = 0;
al__1.aunit = *ntra;
- f_rew(&al__1);
+ f_rew(&al__1);*/
}
cdsyr2k_(iorder, uplo, trans, &n, &k, &alpha, &aa[
1], &lda, &bb[1], &ldb, &beta, &cc[1], &
@@ -3255,9 +2560,7 @@ static logical c_false = FALSE_;
/* Check if error-exit was taken incorrectly. */
if (! infoc_1.ok) {
- io___347.ciunit = *nout;
- s_wsfe(&io___347);
- e_wsfe();
+ printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");
*fatal = TRUE_;
goto L150;
}
@@ -3292,11 +2595,7 @@ static logical c_false = FALSE_;
for (i__ = 1; i__ <= i__5; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
- io___350.ciunit = *nout;
- s_wsfe(&io___350);
- do_fio(&c__1, (char *)&i__, (ftnlen)
- sizeof(integer));
- e_wsfe();
+ printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
}
/* L40: */
}
@@ -3323,9 +2622,9 @@ static logical c_false = FALSE_;
if (tran) {
i__6 = k;
for (i__ = 1; i__ <= i__6; ++i__) {
- w[i__] = ab[(j - 1 << 1) * *nmax
+ w[i__] = ab[((j - 1) << 1) * *nmax
+ k + i__];
- w[k + i__] = ab[(j - 1 << 1) * *
+ w[k + i__] = ab[((j - 1) << 1) * *
nmax + i__];
/* L50: */
}
@@ -3398,52 +2697,30 @@ static logical c_false = FALSE_;
if (errmax < *thresh) {
if (*iorder == 0) {
- io___357.ciunit = *nout;
- s_wsfe(&io___357);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
if (*iorder == 1) {
- io___358.ciunit = *nout;
- s_wsfe(&io___358);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
} else {
if (*iorder == 0) {
- io___359.ciunit = *nout;
- s_wsfe(&io___359);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
- e_wsfe();
+ 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) {
- io___360.ciunit = *nout;
- s_wsfe(&io___360);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
- e_wsfe();
+ 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) {
- io___361.ciunit = *nout;
- s_wsfe(&io___361);
- do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j);
}
L150:
- io___362.ciunit = *nout;
- s_wsfe(&io___362);
- do_fio(&c__1, sname, (ftnlen)13);
- e_wsfe();
+ printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
dprcn5_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &ldb,
&beta, &ldc);
@@ -3457,23 +2734,13 @@ static logical c_false = FALSE_;
} /* dchk5_ */
-/* Subroutine */ int dprcn5_(integer *nout, integer *nc, char *sname, integer
+/* Subroutine */ void dprcn5_(integer *nout, integer *nc, char *sname, integer
*iorder, char *uplo, char *transa, integer *n, integer *k, doublereal
*alpha, integer *lda, integer *ldb, doublereal *beta, integer *ldc)
{
- /* Format strings */
- static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002,"
- "\002))";
- static char fmt_9994[] = "(20x,2(i3,\002,\002),f4.1,\002, A,\002,i3,\002"
- ", B\002,i3,\002,\002,f4.1,\002, C,\002,i3,\002).\002)";
/* Local variables */
- char ca[14], cu[14], crc[14];
-
- /* Fortran I/O blocks */
- static cilist io___366 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___367 = { 0, 0, 0, fmt_9994, 0 };
-
+ static char ca[14], cu[14], crc[14];
if (*(unsigned char *)uplo == 'U') {
s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14);
@@ -3492,25 +2759,8 @@ static logical c_false = FALSE_;
} else {
s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
}
- io___366.ciunit = *nout;
- s_wsfe(&io___366);
- do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, crc, (ftnlen)14);
- do_fio(&c__1, cu, (ftnlen)14);
- do_fio(&c__1, ca, (ftnlen)14);
- e_wsfe();
- io___367.ciunit = *nout;
- s_wsfe(&io___367);
- do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
- do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(doublereal));
- do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
- e_wsfe();
- return 0;
+ 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_ */
@@ -3522,11 +2772,11 @@ static logical c_false = FALSE_;
integer a_dim1, a_offset, i__1, i__2;
/* Local variables */
- integer i__, j;
- logical gen, tri, sym;
- extern doublereal dbeg_(logical *);
- integer ibeg, iend;
- logical unit, lower, upper;
+ extern doublereal dbeg_(logical*);
+ static integer ibeg, iend;
+ static logical unit;
+ static integer i__, j;
+ static logical lower, upper, gen, tri, sym;
/* Generates values for an M by N matrix A. */
@@ -3563,7 +2813,7 @@ static logical c_false = FALSE_;
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 (gen || (upper && i__ <= j) || (lower && i__ >= j)) {
a[i__ + j * a_dim1] = dbeg_(reset) + *transl;
if (i__ != j) {
/* Set some elements to zero */
@@ -3655,31 +2905,18 @@ static logical c_false = FALSE_;
ldcc, doublereal *eps, doublereal *err, logical *fatal, integer *nout,
logical *mv)
{
- /* Format strings */
- static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS"
- " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 EX"
- "PECTED RESULT COMPU\002,\002TED RESULT\002)";
- static char fmt_9998[] = "(1x,i7,2g18.6)";
- static char fmt_9997[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
- " \002,i3)";
-
/* 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;
- /* Local variables */
- integer i__, j, k;
- doublereal erri;
- logical trana, tranb;
-
- /* Fortran I/O blocks */
- static cilist io___384 = { 0, 0, 0, fmt_9999, 0 };
- static cilist io___385 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___386 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___387 = { 0, 0, 0, fmt_9997, 0 };
-
+ /* Builtin functions */
+ double sqrt(double);
+ /* Local variables */
+ static doublereal erri;
+ static integer i__, j, k;
+ static logical trana, tranb;
/* Checks the results of the computational tests. */
@@ -3809,35 +3046,19 @@ static logical c_false = FALSE_;
L130:
*fatal = TRUE_;
- io___384.ciunit = *nout;
- s_wsfe(&io___384);
- e_wsfe();
+ 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) {
- io___385.ciunit = *nout;
- s_wsfe(&io___385);
- do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&ct[i__], (ftnlen)sizeof(doublereal));
- do_fio(&c__1, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(
- doublereal));
- e_wsfe();
+ printf("%7d %15.6g %15.6g\n",i__,ct[i__],cc[i__+j*cc_dim1]);
} else {
- io___386.ciunit = *nout;
- s_wsfe(&io___386);
- do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(
- doublereal));
- do_fio(&c__1, (char *)&ct[i__], (ftnlen)sizeof(doublereal));
- e_wsfe();
+ printf("%7d %15.6g %15.6g\n",i__,cc[i__+j*cc_dim1],ct[i__]);
}
/* L140: */
}
if (*n > 1) {
- io___387.ciunit = *nout;
- s_wsfe(&io___387);
- do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf(" THESE ARE THE RESULTS FOR COLUMN %d\n",j);
}
L150:
@@ -3848,14 +3069,14 @@ static logical c_false = FALSE_;
} /* dmmch_ */
-logical lde_(doublereal *ri, doublereal *rj, integer *lr)
+logical lde_(doublereal* ri, doublereal* rj, integer* lr)
{
/* System generated locals */
integer i__1;
logical ret_val;
/* Local variables */
- integer i__;
+ static integer i__;
/* Tests if two arrays are identical. */
@@ -3899,8 +3120,8 @@ logical lderes_(char *type__, char *uplo, integer *m, integer *n, doublereal *
logical ret_val;
/* Local variables */
- integer i__, j, ibeg, iend;
- logical upper;
+ static integer ibeg, iend, i__, j;
+ static logical upper;
/* Tests if selected elements in two arrays are equal. */
@@ -3977,7 +3198,7 @@ logical lderes_(char *type__, char *uplo, integer *m, integer *n, doublereal *
} /* lderes_ */
-doublereal dbeg_(logical *reset)
+doublereal dbeg_(logical* reset)
{
/* System generated locals */
doublereal ret_val;
@@ -4025,7 +3246,7 @@ doublereal dbeg_(logical *reset)
} /* dbeg_ */
-doublereal ddiff_(doublereal *x, doublereal *y)
+doublereal ddiff_(doublereal* x, doublereal* y)
{
/* System generated locals */
doublereal ret_val;
@@ -4103,7 +3324,7 @@ doublereal ddiff_(doublereal *x, doublereal *y)
integer nargs;
logical reset;
char uplos[1];
- extern /* Subroutine */ int dprcn8_(integer *, integer *, char *, integer
+ extern /* Subroutine */ void dprcn8_(integer *, integer *, char *, integer
*, char *, char *, char *, integer *, integer *, doublereal *,
integer *, integer *, doublereal *, integer *), dmmtch_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
@@ -4115,17 +3336,6 @@ doublereal ddiff_(doublereal *x, doublereal *y)
char tranas[1], tranbs[1], transa[1], transb[1];
doublereal errmax;
- /* Fortran I/O blocks */
- static cilist io___441 = { 0, 0, 0, fmt_9994, 0 };
- static cilist io___444 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___446 = { 0, 0, 0, fmt_10000, 0 };
- static cilist io___447 = { 0, 0, 0, fmt_10001, 0 };
- static cilist io___448 = { 0, 0, 0, fmt_10002, 0 };
- static cilist io___449 = { 0, 0, 0, fmt_10003, 0 };
- static cilist io___450 = { 0, 0, 0, fmt_9996, 0 };
-
-
-
/* Tests DGEMMTR. */
/* Auxiliary routine for test program for Level 3 Blas. */
@@ -4296,23 +3506,16 @@ doublereal ddiff_(doublereal *x, doublereal *y)
transa, transb, &n, &k, &alpha, &
lda, &ldb, &beta, &ldc);
}
- if (*rewi) {
- al__1.aerr = 0;
- al__1.aunit = *ntra;
- f_rew(&al__1);
- }
cdgemmtr_(iorder, uplo, transa, transb, &n, &
k, &alpha, &aa[1], &lda, &bb[1], &ldb,
&beta, &cc[1], &ldc);
/* Check if error-exit was taken incorrectly. */
- if (! infoc_2.ok) {
- io___441.ciunit = *nout;
- s_wsfe(&io___441);
- e_wsfe();
- *fatal = TRUE_;
- goto L120;
+ 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. */
@@ -4347,11 +3550,7 @@ doublereal ddiff_(doublereal *x, doublereal *y)
for (i__ = 1; i__ <= i__5; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
- io___444.ciunit = *nout;
- s_wsfe(&io___444);
- do_fio(&c__1, (char *)&i__, (ftnlen)
- sizeof(integer));
- e_wsfe();
+ printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
}
/* L40: */
}
@@ -4406,45 +3605,26 @@ doublereal ddiff_(doublereal *x, doublereal *y)
/* Report result. */
if (errmax < *thresh) {
- if (*iorder == 0) {
- io___446.ciunit = *nout;
- s_wsfe(&io___446);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
- }
- if (*iorder == 1) {
- io___447.ciunit = *nout;
- s_wsfe(&io___447);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
- }
+ 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) {
- io___448.ciunit = *nout;
- s_wsfe(&io___448);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
- e_wsfe();
- }
- if (*iorder == 1) {
- io___449.ciunit = *nout;
- s_wsfe(&io___449);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
- e_wsfe();
- }
+ 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:
- io___450.ciunit = *nout;
- s_wsfe(&io___450);
- do_fio(&c__1, sname, (ftnlen)13);
- e_wsfe();
+ printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
dprcn8_(nout, &nc, sname, iorder, uplo, transa, transb, &n, &k, &alpha, &
lda, &ldb, &beta, &ldc);
@@ -4458,7 +3638,7 @@ doublereal ddiff_(doublereal *x, doublereal *y)
} /* dchk6_ */
-/* Subroutine */ int dprcn8_(integer *nout, integer *nc, char *sname, integer
+/* Subroutine */ void dprcn8_(integer *nout, integer *nc, char *sname, integer
*iorder, char *uplo, char *transa, char *transb, integer *n, integer *
k, doublereal *alpha, integer *lda, integer *ldb, doublereal *beta,
integer *ldc)
@@ -4502,43 +3682,17 @@ doublereal ddiff_(doublereal *x, doublereal *y)
} else {
s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
}
- io___455.ciunit = *nout;
- s_wsfe(&io___455);
- do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, crc, (ftnlen)14);
- do_fio(&c__1, cuplo, (ftnlen)14);
- do_fio(&c__1, cta, (ftnlen)14);
- do_fio(&c__1, ctb, (ftnlen)14);
- e_wsfe();
- io___456.ciunit = *nout;
- s_wsfe(&io___456);
- do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
- do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(doublereal));
- do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
- e_wsfe();
- return 0;
+ printf("%6d: %s %s %s %s %s\n",*nc,sname,crc,cuplo,cta,ctb);
+ printf("%d %d %4.1f A, %d, B, %d, %4.1f, C, %d.\n",*n,*k,*alpha,*lda,*ldb,*beta,*ldc);
} /* dprcn8_ */
-/* Subroutine */ int dmmtch_(char *uplo, char *transa, char *transb, integer *
+/* Subroutine */ void dmmtch_(char *uplo, char *transa, char *transb, integer *
n, integer *kk, doublereal *alpha, doublereal *a, integer *lda,
doublereal *b, integer *ldb, doublereal *beta, doublereal *c__,
integer *ldc, doublereal *ct, doublereal *g, doublereal *cc, integer *
ldcc, doublereal *eps, doublereal *err, logical *fatal, integer *nout,
logical *mv)
{
- /* Format strings */
- static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS"
- " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 EX"
- "PECTED RESULT COMPU\002,\002TED RESULT\002)";
- static char fmt_9998[] = "(1x,i7,2g18.6)";
- static char fmt_9997[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
- " \002,i3)";
-
/* 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;
@@ -4550,13 +3704,6 @@ doublereal ddiff_(doublereal *x, doublereal *y)
logical trana, tranb, upper;
integer istop, istart;
- /* Fortran I/O blocks */
- static cilist io___466 = { 0, 0, 0, fmt_9999, 0 };
- static cilist io___467 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___468 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___469 = { 0, 0, 0, fmt_9997, 0 };
-
-
/* Checks the results of the computational tests. */
@@ -4693,43 +3840,26 @@ doublereal ddiff_(doublereal *x, doublereal *y)
L130:
*fatal = TRUE_;
- io___466.ciunit = *nout;
- s_wsfe(&io___466);
- e_wsfe();
- i__1 = istop;
- for (i__ = istart; i__ <= i__1; ++i__) {
- if (*mv) {
- io___467.ciunit = *nout;
- s_wsfe(&io___467);
- do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&ct[i__], (ftnlen)sizeof(doublereal));
- do_fio(&c__1, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(
- doublereal));
- e_wsfe();
- } else {
- io___468.ciunit = *nout;
- s_wsfe(&io___468);
- do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(
- doublereal));
- do_fio(&c__1, (char *)&ct[i__], (ftnlen)sizeof(doublereal));
- e_wsfe();
- }
+ printf(" ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HALF ACCURATE *******\n");
+ printf(" EXPECTED RESULT COMPUTED RESULT\n");
+
+ 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) {
- io___469.ciunit = *nout;
- s_wsfe(&io___469);
- do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf(" THESE ARE THE RESULTS FOR COLUMN %d\n",j);
}
L150:
- return 0;
/* End of DMMTCH */
} /* dmmtch_ */
-/* Main program alias */ int dblat3_ () { MAIN__ (); return 0; }
diff --git a/ctest/c_sblat3c.c b/ctest/c_sblat3c.c
index bf2f871f2c..99fc4645b4 100644
--- a/ctest/c_sblat3c.c
+++ b/ctest/c_sblat3c.c
@@ -240,125 +240,16 @@ typedef struct Namelist Namelist;
/* 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
-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;
-}
/* Common Block Declarations */
-union {
- struct {
- integer infot, noutc;
- logical ok;
- } _1;
- struct {
- integer infot, noutc;
- logical ok, lerr;
- } _2;
+struct {
+ integer infot, noutc;
+ logical ok;
} infoc_;
-#define infoc_1 (infoc_._1)
-#define infoc_2 (infoc_._2)
+#define infoc_1 infoc_
struct {
char srnamt[13];
@@ -368,15 +259,10 @@ struct {
/* Table of constant values */
-static integer c__9 = 9;
static integer c__1 = 1;
-static integer c__3 = 3;
-static integer c__8 = 8;
-static integer c__4 = 4;
static integer c__65 = 65;
-static integer c__7 = 7;
-static real c_b89 = 1.f;
-static real c_b103 = 0.f;
+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;
@@ -386,152 +272,47 @@ static logical c_false = FALSE_;
{
/* Initialized data */
- static char snames[13*7] = "cblas_sgemm " "cblas_ssymm " "cblas_strmm "
- "cblas_strsm " "cblas_ssyrk " "cblas_ssyr2k " "cblas_sgemmtr";
-
- /* Format strings */
- static char fmt_9997[] = "(\002 NUMBER OF VALUES OF \002,a,\002 IS LESS "
- "THAN 1 OR GREATER \002,\002THAN \002,i2)";
- static char fmt_9996[] = "(\002 VALUE OF N IS LESS THAN 0 OR GREATER THA"
- "N \002,i2)";
- static char fmt_9995[] = "(\002 TESTS OF THE REAL LEVEL 3 BL"
- "AS\002,//\002 THE F\002,\002OLLOWING PARAMETER VALUES WILL BE US"
- "ED:\002)";
- static char fmt_9994[] = "(\002 FOR N \002,9i6)";
- static char fmt_9993[] = "(\002 FOR ALPHA \002,7f6.1)";
- static char fmt_9992[] = "(\002 FOR BETA \002,7f6.1)";
- static char fmt_9984[] = "(\002 ERROR-CALL MYEXITS WILL NOT BE TESTED"
- "\002)";
- static char fmt_9999[] = "(\002 ROUTINES PASS COMPUTATIONAL TESTS IF TES"
- "T RATIO IS LES\002,\002S THAN\002,f8.2)";
- static char fmt_10002[] = "(\002 COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS"
- " ARE TESTED\002)";
- static char fmt_10001[] = "(\002 ROW-MAJOR DATA LAYOUT IS TESTED\002)";
- static char fmt_10000[] = "(\002 COLUMN-MAJOR DATA LAYOUT IS TESTED\002)";
- static char fmt_9988[] = "(a13,l2)";
- static char fmt_9990[] = "(\002 SUBPROGRAM NAME \002,a13,\002 NOT RECOGN"
- "IZED\002,/\002 ******* \002,\002TESTS ABANDONED *******\002)";
- static char fmt_9998[] = "(\002 RELATIVE MACHINE PRECISION IS TAKEN TO"
- " BE\002,1p,e9.1)";
- static char fmt_9989[] = "(\002 ERROR IN SMMCH - IN-LINE DOT PRODUCTS A"
- "RE BEING EVALU\002,\002ATED WRONGLY.\002,/\002 SMMCH WAS CALLED "
- "WITH TRANSA = \002,a1,\002 AND TRANSB = \002,a1,/\002 AND RETURN"
- "ED SAME = \002,l1,\002 AND \002,\002ERR = \002,f12.3,\002.\002,"
- "/\002 THIS MAY BE DUE TO FAULTS IN THE \002,\002ARITHMETIC OR TH"
- "E COMPILER.\002,/\002 ******* TESTS ABANDONED \002,\002******"
- "*\002)";
- static char fmt_9987[] = "(1x,a13,\002 WAS NOT TESTED\002)";
- static char fmt_9986[] = "(/\002 END OF TESTS\002)";
- static char fmt_9985[] = "(/\002 ******* FATAL ERROR - TESTS ABANDONED *"
- "******\002)";
- static char fmt_9991[] = "(\002 AMEND DATA FILE OR INCREASE ARRAY SIZES "
- "IN PROGRAM\002,/\002 ******* TESTS ABANDONED *******\002)";
+ static char snames[7][14] = {"cblas_sgemm ", "cblas_ssymm ", "cblas_strmm ", "cblas_strsm ", "cblas_ssyrk ", "cblas_ssyr2k ", "cblas_sgemmtr"};
/* System generated locals */
integer i__1, i__2, i__3;
real r__1;
- olist o__1;
- cllist cl__1;
/* Local variables */
- real c__[4225] /* was [65][65] */, g[65];
- integer i__, j, n;
- real w[130], aa[4225], ab[8450] /* was [65][130] */, bb[4225], cc[
- 4225], as[4225], bs[4225], cs[4225], ct[65], alf[7], bet[7];
- extern logical lse_(real *, real *, integer *);
- real eps, err;
- integer nalf, idim[9];
- logical same;
- integer nbet, ntra;
- logical rewi;
- extern /* Subroutine */ int schk1_(char *, real *, real *, integer *,
- integer *, logical *, logical *, logical *, integer *, integer *,
- integer *, real *, integer *, real *, integer *, real *, real *,
- real *, real *, real *, real *, real *, real *, real *, real *,
- real *, integer *), schk2_(char *, real *, real *,
- integer *, integer *, logical *, logical *, logical *, integer *,
- integer *, integer *, real *, integer *, real *, integer *, real *
- , real *, real *, real *, real *, real *, real *, real *, real *,
- real *, real *, integer *), schk3_(char *, real *, real *,
- integer *, integer *, logical *, logical *, logical *, integer *,
- integer *, integer *, real *, integer *, real *, real *, real *,
- real *, real *, real *, real *, real *, real *, integer *)
- , schk4_(char *, real *, real *, integer *, integer *, logical *,
- logical *, logical *, integer *, integer *, integer *, real *,
- integer *, real *, integer *, real *, real *, real *, real *,
- real *, real *, real *, real *, real *, real *, real *, integer *), schk5_(char *, real *, real *, integer *, integer *,
- logical *, logical *, logical *, integer *, integer *, integer *,
- real *, integer *, real *, integer *, real *, real *, real *,
- real *, real *, real *, real *, real *, real *, real *, real *,
- integer *), schk6_(char *, real *, real *, integer *,
- integer *, logical *, logical *, logical *, integer *, integer *,
- integer *, real *, integer *, real *, integer *, real *, real *,
- real *, real *, real *, real *, real *, real *, real *, real *,
- real *, integer *);
- logical fatal;
- extern real sdiff_(real *, real *);
- logical trace;
- integer nidim;
- extern /* Subroutine */ int smmch_(char *, char *, integer *, integer *,
- integer *, real *, real *, integer *, real *, integer *, real *,
- real *, integer *, real *, real *, real *, integer *, real *,
- real *, logical *, integer *, logical *);
- char snaps[32];
- integer isnum;
- logical ltest[7], sfatal, corder;
- char snamet[13], transa[1], transb[1];
- real thresh;
- logical rorder;
- integer layout;
- logical ltestt, tsterr;
- extern /* Subroutine */ int cs3chke_(char *);
-
- /* Fortran I/O blocks */
- static cilist io___2 = { 0, 5, 0, 0, 0 };
- static cilist io___4 = { 0, 5, 0, 0, 0 };
- static cilist io___7 = { 0, 5, 0, 0, 0 };
- static cilist io___9 = { 0, 5, 0, 0, 0 };
- static cilist io___11 = { 0, 5, 0, 0, 0 };
- static cilist io___13 = { 0, 5, 0, 0, 0 };
- static cilist io___15 = { 0, 5, 0, 0, 0 };
- static cilist io___17 = { 0, 5, 0, 0, 0 };
- static cilist io___19 = { 0, 6, 0, fmt_9997, 0 };
- static cilist io___20 = { 0, 5, 0, 0, 0 };
- static cilist io___23 = { 0, 6, 0, fmt_9996, 0 };
- static cilist io___24 = { 0, 5, 0, 0, 0 };
- static cilist io___26 = { 0, 6, 0, fmt_9997, 0 };
- static cilist io___27 = { 0, 5, 0, 0, 0 };
- static cilist io___29 = { 0, 5, 0, 0, 0 };
- static cilist io___31 = { 0, 6, 0, fmt_9997, 0 };
- static cilist io___32 = { 0, 5, 0, 0, 0 };
- static cilist io___34 = { 0, 6, 0, fmt_9995, 0 };
- static cilist io___35 = { 0, 6, 0, fmt_9994, 0 };
- static cilist io___36 = { 0, 6, 0, fmt_9993, 0 };
- static cilist io___37 = { 0, 6, 0, fmt_9992, 0 };
- static cilist io___38 = { 0, 6, 0, 0, 0 };
- static cilist io___39 = { 0, 6, 0, fmt_9984, 0 };
- static cilist io___40 = { 0, 6, 0, 0, 0 };
- static cilist io___41 = { 0, 6, 0, fmt_9999, 0 };
- static cilist io___42 = { 0, 6, 0, 0, 0 };
- static cilist io___45 = { 0, 6, 0, fmt_10002, 0 };
- static cilist io___46 = { 0, 6, 0, fmt_10001, 0 };
- static cilist io___47 = { 0, 6, 0, fmt_10000, 0 };
- static cilist io___48 = { 0, 6, 0, 0, 0 };
- static cilist io___50 = { 0, 5, 1, fmt_9988, 0 };
- static cilist io___53 = { 0, 6, 0, fmt_9990, 0 };
- static cilist io___55 = { 0, 6, 0, fmt_9998, 0 };
- static cilist io___68 = { 0, 6, 0, fmt_9989, 0 };
- static cilist io___69 = { 0, 6, 0, fmt_9989, 0 };
- static cilist io___70 = { 0, 6, 0, fmt_9989, 0 };
- static cilist io___71 = { 0, 6, 0, fmt_9989, 0 };
- static cilist io___73 = { 0, 6, 0, 0, 0 };
- static cilist io___74 = { 0, 6, 0, fmt_9987, 0 };
- static cilist io___75 = { 0, 6, 0, 0, 0 };
- static cilist io___82 = { 0, 6, 0, fmt_9986, 0 };
- static cilist io___83 = { 0, 6, 0, fmt_9985, 0 };
- static cilist io___84 = { 0, 6, 0, fmt_9991, 0 };
-
-
+ static integer nalf, idim[9];
+ static logical same;
+ static integer nbet, ntra;
+ static logical rewi;
+ extern /* Subroutine */ int schk1_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, real*, integer*, real*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*);
+ extern /* Subroutine */ int schk2_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, real*, integer*, real*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*);
+ extern /* Subroutine */ int schk3_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, real*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*);
+ extern /* Subroutine */ int schk4_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, real*, integer*, real*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*);
+ extern /* Subroutine */ int schk5_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, real*, integer*, real*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*);
+ extern /* Subroutine */ int schk6_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, real*, integer*, real*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*);
+ static real c__[4225] /* was [65][65] */, g[65];
+ static integer i__, j, n;
+ static logical fatal;
+ static real w[130];
+ extern real sdiff_(real*, real*);
+ static logical trace;
+ static integer nidim;
+ extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*);
+ static char snaps[32];
+ static integer isnum;
+ static logical ltest[6];
+ static real aa[4225], ab[8450] /* was [65][130] */, bb[4225], cc[
+ 4225], as[4225], bs[4225], cs[4225], ct[65];
+ static logical sfatal, corder;
+ static char snamet[12], transa[1], transb[1];
+ static real thresh;
+ static logical rorder;
+ static integer layout;
+ static logical ltestt, tsterr;
+ extern /* Subroutine */ void cs3chke_(char*);
+ static real alf[7], bet[7];
+ extern logical lse_(real*, real*, integer*);
+ static real eps, err;
+ char tmpchar;
/* Test program for the REAL Level 3 Blas. */
@@ -580,17 +361,20 @@ static logical c_false = FALSE_;
infoc_1.noutc = 6;
/* Read name and unit number for summary output file and open file. */
- s_rsle(&io___2);
- do_lio(&c__9, &c__1, snaps, (ftnlen)32);
- e_rsle();
- s_rsle(&io___4);
- do_lio(&c__3, &c__1, (char *)&ntra, (ftnlen)sizeof(integer));
- e_rsle();
+ char line[80];
+
+ fgets(line,80,stdin);
+ sscanf(line,"'%s'",snaps);
+ fgets(line,80,stdin);
+#ifdef USE64BITINT
+ sscanf(line,"%ld",&ntra);
+#else
+ sscanf(line,"%d",&ntra);
+#endif
trace = ntra >= 0;
if (trace) {
/* OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' ) */
- o__1.oerr = 0;
- o__1.ounit = ntra;
+/* o__1.ounit = ntra;
o__1.ofnmlen = 32;
o__1.ofnm = snaps;
o__1.orl = 0;
@@ -598,147 +382,118 @@ static logical c_false = FALSE_;
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = 0;
- f_open(&o__1);
+ f_open(&o__1);*/
}
/* Read the flag that directs rewinding of the snapshot file. */
- s_rsle(&io___7);
- do_lio(&c__8, &c__1, (char *)&rewi, (ftnlen)sizeof(logical));
- e_rsle();
- rewi = rewi && trace;
+ fgets(line,80,stdin);
+ sscanf(line,"%d",&rewi);
+ rewi = rewi && trace;
/* Read the flag that directs stopping on any failure. */
- s_rsle(&io___9);
- do_lio(&c__8, &c__1, (char *)&sfatal, (ftnlen)sizeof(logical));
- e_rsle();
+ 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. */
- s_rsle(&io___11);
- do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
- e_rsle();
+ tsterr=FALSE_;
+ if (tmpchar=='T')tsterr=TRUE_;
/* Read the flag that indicates whether row-major data layout to be tested. */
- s_rsle(&io___13);
- do_lio(&c__3, &c__1, (char *)&layout, (ftnlen)sizeof(integer));
- e_rsle();
+ fgets(line,80,stdin);
+ sscanf(line,"%d",&layout);
/* Read the threshold value of the test ratio */
- s_rsle(&io___15);
- do_lio(&c__4, &c__1, (char *)&thresh, (ftnlen)sizeof(real));
- e_rsle();
+ fgets(line,80,stdin);
+ sscanf(line,"%f",&thresh);
/* Read and check the parameter values for the tests. */
/* Values of N */
- s_rsle(&io___17);
- do_lio(&c__3, &c__1, (char *)&nidim, (ftnlen)sizeof(integer));
- e_rsle();
+ fgets(line,80,stdin);
+#ifdef USE64BITINT
+ sscanf(line,"%ld",&nidim);
+#else
+ sscanf(line,"%d",&nidim);
+#endif
+
if (nidim < 1 || nidim > 9) {
- s_wsfe(&io___19);
- do_fio(&c__1, "N", (ftnlen)1);
- do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
- e_wsfe();
- goto L220;
- }
- s_rsle(&io___20);
- i__1 = nidim;
- for (i__ = 1; i__ <= i__1; ++i__) {
- do_lio(&c__3, &c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
+ fprintf(stderr,"NUMBER OF VALUES OF N IS LESS THAN 1 OR GREATER THAN 9");
+ goto L220;
}
- e_rsle();
+ fgets(line,80,stdin);
+#ifdef USE64BITINT
+ sscanf(line,"%ld %ld %ld %ld %ld %ld %ld %ld %ld",&idim[0],&idim[1],&idim[2],
+ &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]);
+#else
+ sscanf(line,"%d %d %d %d %d %d %d %d %d",&idim[0],&idim[1],&idim[2],
+ &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]);
+#endif
i__1 = nidim;
for (i__ = 1; i__ <= i__1; ++i__) {
- if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) {
- s_wsfe(&io___23);
- do_fio(&c__1, (char *)&c__65, (ftnlen)sizeof(integer));
- e_wsfe();
- goto L220;
- }
-/* L10: */
+ 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 */
- s_rsle(&io___24);
- do_lio(&c__3, &c__1, (char *)&nalf, (ftnlen)sizeof(integer));
- e_rsle();
+ fgets(line,80,stdin);
+#ifdef USE64BITINT
+ sscanf(line,"%ld",&nalf);
+#else
+ sscanf(line,"%d",&nalf);
+#endif
if (nalf < 1 || nalf > 7) {
- s_wsfe(&io___26);
- do_fio(&c__1, "ALPHA", (ftnlen)5);
- do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
- e_wsfe();
- goto L220;
- }
- s_rsle(&io___27);
- i__1 = nalf;
- for (i__ = 1; i__ <= i__1; ++i__) {
- do_lio(&c__4, &c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(real));
+ fprintf(stderr,"VALUE OF ALPHA IS LESS THAN 0 OR GREATER THAN 7\n");
+ goto L220;
}
- e_rsle();
+ 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 */
- s_rsle(&io___29);
- do_lio(&c__3, &c__1, (char *)&nbet, (ftnlen)sizeof(integer));
- e_rsle();
- if (nbet < 1 || nbet > 7) {
- s_wsfe(&io___31);
- do_fio(&c__1, "BETA", (ftnlen)4);
- do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
- e_wsfe();
- goto L220;
- }
- s_rsle(&io___32);
- i__1 = nbet;
- for (i__ = 1; i__ <= i__1; ++i__) {
- do_lio(&c__4, &c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(real));
+ fgets(line,80,stdin);
+#ifdef USE64BITINT
+ sscanf(line,"%ld",&nbet);
+#else
+ sscanf(line,"%d",&nbet);
+#endif
+ if (nalf < 1 || nbet > 7) {
+ fprintf(stderr,"VALUE OF BETA IS LESS THAN 0 OR GREATER THAN 7\n");
+ goto L220;
}
- e_rsle();
+ 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");
- s_wsfe(&io___34);
- e_wsfe();
- s_wsfe(&io___35);
- i__1 = nidim;
- for (i__ = 1; i__ <= i__1; ++i__) {
- do_fio(&c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
- }
- e_wsfe();
- s_wsfe(&io___36);
- i__1 = nalf;
- for (i__ = 1; i__ <= i__1; ++i__) {
- do_fio(&c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(real));
- }
- e_wsfe();
- s_wsfe(&io___37);
- i__1 = nbet;
- for (i__ = 1; i__ <= i__1; ++i__) {
- do_fio(&c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(real));
- }
- e_wsfe();
if (! tsterr) {
- s_wsle(&io___38);
- e_wsle();
- s_wsfe(&io___39);
- e_wsfe();
+ printf(" ERROR-EXITS WILL NOT BE TESTED\n");
}
- s_wsle(&io___40);
- e_wsle();
- s_wsfe(&io___41);
- do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(real));
- e_wsfe();
- s_wsle(&io___42);
- e_wsle();
+ 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_;
- s_wsfe(&io___45);
- e_wsfe();
+ rorder = TRUE_;
+ corder = TRUE_;
+ printf("COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED\n");
} else if (layout == 1) {
- rorder = TRUE_;
- s_wsfe(&io___46);
- e_wsfe();
+ rorder = TRUE_;
+ printf("ROW-MAJOR DATA LAYOUT IS TESTED\n");
} else if (layout == 0) {
- corder = TRUE_;
- s_wsfe(&io___47);
- e_wsfe();
+ corder = TRUE_;
+ printf("COLUMN-MAJOR DATA LAYOUT IS TESTED\n");
}
- s_wsle(&io___48);
- e_wsle();
+
/* Read names of subroutines and flags which indicate */
/* whether they are to be tested. */
@@ -748,58 +503,45 @@ static logical c_false = FALSE_;
/* L20: */
}
L30:
- i__1 = s_rsfe(&io___50);
- if (i__1 != 0) {
- goto L60;
- }
- i__1 = do_fio(&c__1, snamet, (ftnlen)13);
- if (i__1 != 0) {
- goto L60;
- }
- i__1 = do_fio(&c__1, (char *)<estt, (ftnlen)sizeof(logical));
- if (i__1 != 0) {
- goto L60;
- }
- i__1 = e_rsfe();
- if (i__1 != 0) {
- goto L60;
- }
- for (i__ = 1; i__ <= 7; ++i__) {
- if (s_cmp(snamet, snames + (i__ - 1) * 13, (ftnlen)13, (ftnlen)13) ==
- 0) {
- goto L50;
- }
+ if (! fgets(line,80,stdin)) {
+ goto L60;
+ }
+ i__1 = sscanf(line,"%13c %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: */
}
- s_wsfe(&io___53);
- do_fio(&c__1, snamet, (ftnlen)13);
- e_wsfe();
- s_stop("", (ftnlen)0);
+ 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);
+// f_clos(&cl__1);
/* Compute EPS (the machine precision). */
- eps = 1.f;
+ eps = (float)1.;
L70:
- r__1 = eps + 1.f;
- if (sdiff_(&r__1, &c_b89) == 0.f) {
+ r__1 = eps + (float)1.;
+ if (sdiff_(&r__1, &c_b89) == (float)0.) {
goto L80;
}
- eps *= .5f;
+ eps *= (float).5;
goto L70;
L80:
eps += eps;
- s_wsfe(&io___55);
- do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real));
- e_wsfe();
+ printf("RELATIVE MACHINE PRECISION IS TAKEN TO BE %9.1g\n",eps);
/* Check the reliability of SMMCH using exact data. */
@@ -815,7 +557,7 @@ static logical c_false = FALSE_;
}
ab[j + 4224] = (real) j;
ab[(j + 65) * 65 - 65] = (real) j;
- c__[j - 1] = 0.f;
+ c__[j - 1] = (float)0.;
/* L100: */
}
i__1 = n;
@@ -832,28 +574,26 @@ static logical c_false = FALSE_;
c__65, &c_b103, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &
fatal, &c__6, &c_true);
same = lse_(cc, ct, &n);
- if (! same || err != 0.f) {
- s_wsfe(&io___68);
- do_fio(&c__1, transa, (ftnlen)1);
- do_fio(&c__1, transb, (ftnlen)1);
- do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
- do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
- e_wsfe();
- s_stop("", (ftnlen)0);
+ 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);
same = lse_(cc, ct, &n);
- if (! same || err != 0.f) {
- s_wsfe(&io___69);
- do_fio(&c__1, transa, (ftnlen)1);
- do_fio(&c__1, transb, (ftnlen)1);
- do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
- do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
- e_wsfe();
- s_stop("", (ftnlen)0);
+ 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) {
@@ -873,54 +613,46 @@ static logical c_false = FALSE_;
c__65, &c_b103, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &
fatal, &c__6, &c_true);
same = lse_(cc, ct, &n);
- if (! same || err != 0.f) {
- s_wsfe(&io___70);
- do_fio(&c__1, transa, (ftnlen)1);
- do_fio(&c__1, transb, (ftnlen)1);
- do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
- do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
- e_wsfe();
- s_stop("", (ftnlen)0);
+ 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);
same = lse_(cc, ct, &n);
- if (! same || err != 0.f) {
- s_wsfe(&io___71);
- do_fio(&c__1, transa, (ftnlen)1);
- do_fio(&c__1, transb, (ftnlen)1);
- do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
- do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
- e_wsfe();
- s_stop("", (ftnlen)0);
+ 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 <= 7; ++isnum) {
- s_wsle(&io___73);
- e_wsle();
if (! ltest[isnum - 1]) {
/* Subprogram is not to be tested. */
- s_wsfe(&io___74);
- do_fio(&c__1, snames + (isnum - 1) * 13, (ftnlen)13);
- e_wsfe();
+ printf("%13s WAS NOT TESTED\n",snames[isnum-1]);
} else {
- s_copy(srnamc_1.srnamt, snames + (isnum - 1) * 13, (ftnlen)13, (
+ s_copy(srnamc_1.srnamt, snames[isnum - 1], (ftnlen)13, (
ftnlen)13);
/* Test error exits. */
if (tsterr) {
- cs3chke_(snames + (isnum - 1) * 13);
- s_wsle(&io___75);
- e_wsle();
+ cs3chke_(snames[isnum - 1]);
}
/* Test computations. */
infoc_1.infot = 0;
infoc_1.ok = TRUE_;
fatal = FALSE_;
- switch (isnum) {
+ switch ((int)isnum) {
case 1: goto L140;
case 2: goto L150;
case 3: goto L160;
@@ -932,13 +664,13 @@ static logical c_false = FALSE_;
/* Test SGEMM, 01. */
L140:
if (corder) {
- schk1_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
}
if (rorder) {
- schk1_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
@@ -947,13 +679,13 @@ static logical c_false = FALSE_;
/* Test SSYMM, 02. */
L150:
if (corder) {
- schk2_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
}
if (rorder) {
- schk2_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
@@ -962,13 +694,13 @@ static logical c_false = FALSE_;
/* Test STRMM, 03, STRSM, 04. */
L160:
if (corder) {
- schk3_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
}
if (rorder) {
- schk3_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
@@ -977,13 +709,13 @@ static logical c_false = FALSE_;
/* Test SSYRK, 05. */
L170:
if (corder) {
- schk4_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
}
if (rorder) {
- schk4_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
@@ -992,13 +724,13 @@ static logical c_false = FALSE_;
/* Test SSYR2K, 06. */
L180:
if (corder) {
- schk5_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
}
if (rorder) {
- schk5_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
@@ -1007,13 +739,13 @@ static logical c_false = FALSE_;
/* Test SGEMMTR, 07. */
L185:
if (corder) {
- schk6_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ schk6_(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) {
- schk6_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ schk6_(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);
@@ -1027,36 +759,26 @@ static logical c_false = FALSE_;
}
/* L200: */
}
- s_wsfe(&io___82);
- e_wsfe();
+ printf("\nEND OF TESTS\n");
goto L230;
L210:
- s_wsfe(&io___83);
- e_wsfe();
+ printf("\n****** FATAL ERROR - TESTS ABANDONED ******\n");
goto L230;
L220:
- s_wsfe(&io___84);
- e_wsfe();
+ 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);
+// f_clos(&cl__1);
}
- cl__1.cerr = 0;
- cl__1.cunit = 6;
- cl__1.csta = 0;
- f_clos(&cl__1);
- s_stop("", (ftnlen)0);
-
+// f_clos(&cl__1);
+ exit(0);
/* End of SBLAT3. */
- return 0;
} /* MAIN__ */
/* Subroutine */ int schk1_(char *sname, real *eps, real *thresh, integer *
@@ -1068,74 +790,35 @@ static logical c_false = FALSE_;
{
/* Initialized data */
- static char ich[3] = "NTC";
-
- /* Format strings */
- static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
- "TAKEN ON VALID CALL *******\002)";
- static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
- " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
- static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
- "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
- " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
- "BER:\002)";
+ 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;
- alist al__1;
-
- /* Local variables */
- integer i__, k, m, n, ia, ib, ma, mb, na, nb, nc, ik, im, in, ks, ms, ns,
- ica, icb, laa, lbb, lda, lcc, ldb, ldc;
- real als, bls;
- extern logical lse_(real *, real *, integer *);
- real err, beta;
- integer ldas, ldbs, ldcs;
- logical same, null;
- real alpha;
- logical isame[13];
- extern /* Subroutine */ int smake_(char *, char *, char *, integer *,
- integer *, real *, integer *, real *, integer *, logical *, real *
- );
- logical trana, tranb;
- extern /* Subroutine */ int smmch_(char *, char *, integer *, integer *,
- integer *, real *, real *, integer *, real *, integer *, real *,
- real *, integer *, real *, real *, real *, integer *, real *,
- real *, logical *, integer *, logical *);
- integer nargs;
- logical reset;
- extern /* Subroutine */ int sprcn1_(integer *, integer *, char *, integer
- *, char *, char *, integer *, integer *, integer *, real *,
- integer *, integer *, real *, integer *),
- csgemm_(integer *, char *, char *, integer *, integer *, integer *
- , real *, real *, integer *, real *, integer *, real *, real *,
- integer *);
- char tranas[1], tranbs[1], transa[1], transb[1];
- real errmax;
- extern logical lseres_(char *, char *, integer *, integer *, real *, real
- *, integer *);
-
- /* Fortran I/O blocks */
- static cilist io___128 = { 0, 0, 0, fmt_9994, 0 };
- static cilist io___131 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___133 = { 0, 0, 0, fmt_10000, 0 };
- static cilist io___134 = { 0, 0, 0, fmt_10001, 0 };
- static cilist io___135 = { 0, 0, 0, fmt_10002, 0 };
- static cilist io___136 = { 0, 0, 0, fmt_10003, 0 };
- static cilist io___137 = { 0, 0, 0, fmt_9996, 0 };
+ /* Local variables */
+ static real beta;
+ static integer ldas, ldbs, ldcs;
+ static logical same, null;
+ static integer i__, k, m, n;
+ static real alpha;
+ static logical isame[13];
+ static logical trana, tranb;
+ static integer nargs;
+ static logical reset;
+ extern /* Subroutine */ void sprcn1_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, integer*, real*, integer*, integer*, real*, integer*);
+ extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, logical*, real*);
+ extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*);
+ static integer ia, ib, ma, mb, na, nb, nc, ik, im, in, ks, ms, ns;
+ extern /* Subroutine */ void csgemm_(integer*, char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*);
+ static char tranas[1], tranbs[1], transa[1], transb[1];
+ static real errmax;
+ extern logical lseres_(char*, char*, integer*, integer*, real*, real*, integer*);
+ extern logical lse_(real*, real*, integer*);
+ static integer ica, icb, laa, lbb, lda, lcc, ldb, ldc;
+ static real als, bls;
+ static real err;
/* Tests SGEMM. */
@@ -1311,9 +994,7 @@ static logical c_false = FALSE_;
&ldb, &beta, &ldc);
}
if (*rewi) {
- al__1.aerr = 0;
- al__1.aunit = *ntra;
- f_rew(&al__1);
+// f_rew(&al__1);
}
csgemm_(iorder, transa, transb, &m, &n, &k, &
alpha, &aa[1], &lda, &bb[1], &ldb, &
@@ -1322,9 +1003,7 @@ static logical c_false = FALSE_;
/* 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;
}
@@ -1360,12 +1039,7 @@ static logical c_false = FALSE_;
for (i__ = 1; i__ <= i__6; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
- io___131.ciunit = *nout;
- s_wsfe(&io___131);
- i__7 = i__ + 1;
- do_fio(&c__1, (char *)&i__7, (ftnlen)
- sizeof(integer));
- e_wsfe();
+ printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
}
/* L40: */
}
@@ -1383,7 +1057,7 @@ static logical c_false = FALSE_;
nmax, &beta, &c__[c_offset],
nmax, &ct[1], &g[1], &cc[1], &ldc,
eps, &err, fatal, nout, &c_true);
- errmax = f2cmax(errmax,err);
+ errmax = dmax(errmax,err);
/* If got really bad answer, report and */
/* return. */
if (*fatal) {
@@ -1419,44 +1093,25 @@ static logical c_false = FALSE_;
if (errmax < *thresh) {
if (*iorder == 0) {
- io___133.ciunit = *nout;
- s_wsfe(&io___133);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
if (*iorder == 1) {
- io___134.ciunit = *nout;
- s_wsfe(&io___134);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
} else {
if (*iorder == 0) {
- io___135.ciunit = *nout;
- s_wsfe(&io___135);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
- e_wsfe();
+ 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) {
- io___136.ciunit = *nout;
- s_wsfe(&io___136);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
- e_wsfe();
+ 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:
- io___137.ciunit = *nout;
- s_wsfe(&io___137);
- do_fio(&c__1, sname, (ftnlen)13);
- e_wsfe();
+ printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
sprcn1_(nout, &nc, sname, iorder, transa, transb, &m, &n, &k, &alpha, &
lda, &ldb, &beta, &ldc);
@@ -1472,23 +1127,13 @@ static logical c_false = FALSE_;
-/* Subroutine */ int sprcn1_(integer *nout, integer *nc, char *sname, integer
+/* Subroutine */ void sprcn1_(integer *nout, integer *nc, char *sname, integer
*iorder, char *transa, char *transb, integer *m, integer *n, integer *
k, real *alpha, integer *lda, integer *ldb, real *beta, integer *ldc)
{
- /* Format strings */
- static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
- "a14,\002,\002,a14,\002,\002)";
- static char fmt_9994[] = "(20x,3(i3,\002,\002),f4.1,\002, A,\002,i3,\002"
- ", B,\002,i3,\002,\002,f4.1,\002, \002,\002C,\002,i3,\002).\002)";
/* Local variables */
- char crc[14], cta[14], ctb[14];
-
- /* Fortran I/O blocks */
- static cilist io___141 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___142 = { 0, 0, 0, fmt_9994, 0 };
-
+ static char crc[14], cta[14], ctb[14];
if (*(unsigned char *)transa == 'N') {
s_copy(cta, " CblasNoTrans", (ftnlen)14, (ftnlen)14);
@@ -1509,26 +1154,9 @@ static logical c_false = FALSE_;
} else {
s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
}
- io___141.ciunit = *nout;
- s_wsfe(&io___141);
- do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, crc, (ftnlen)14);
- do_fio(&c__1, cta, (ftnlen)14);
- do_fio(&c__1, ctb, (ftnlen)14);
- e_wsfe();
- io___142.ciunit = *nout;
- s_wsfe(&io___142);
- do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(real));
- do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(real));
- do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
- e_wsfe();
- return 0;
+ 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_ */
@@ -1541,79 +1169,40 @@ static logical c_false = FALSE_;
{
/* Initialized data */
- static char ichs[2] = "LR";
- static char ichu[2] = "UL";
-
- /* Format strings */
- static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
- "TAKEN ON VALID CALL *******\002)";
- static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
- " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
- static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
- "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
- " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
- "BER:\002)";
+ 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;
- alist al__1;
-
- /* Local variables */
- integer i__, m, n, ia, ib, na, nc, im, in, ms, ns, laa, lbb, lda, lcc,
- ldb, ldc, ics;
- real als, bls;
- integer icu;
- extern logical lse_(real *, real *, integer *);
- real err, beta;
- integer ldas, ldbs, ldcs;
- logical same;
- char side[1];
- logical left, null;
- char uplo[1];
- real alpha;
- logical isame[13];
- extern /* Subroutine */ int smake_(char *, char *, char *, integer *,
- integer *, real *, integer *, real *, integer *, logical *, real *
- );
- char sides[1];
- extern /* Subroutine */ int smmch_(char *, char *, integer *, integer *,
- integer *, real *, real *, integer *, real *, integer *, real *,
- real *, integer *, real *, real *, real *, integer *, real *,
- real *, logical *, integer *, logical *);
- integer nargs;
- logical reset;
- char uplos[1];
- extern /* Subroutine */ int sprcn2_(integer *, integer *, char *, integer
- *, char *, char *, integer *, integer *, real *, integer *,
- integer *, real *, integer *);
- real errmax;
- extern logical lseres_(char *, char *, integer *, integer *, real *, real
- *, integer *);
- extern /* Subroutine */ int cssymm_(integer *, char *, char *, integer *,
- integer *, real *, real *, integer *, real *, integer *, real *,
- real *, integer *);
-
- /* Fortran I/O blocks */
- static cilist io___180 = { 0, 0, 0, fmt_9994, 0 };
- static cilist io___183 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___185 = { 0, 0, 0, fmt_10000, 0 };
- static cilist io___186 = { 0, 0, 0, fmt_10001, 0 };
- static cilist io___187 = { 0, 0, 0, fmt_10002, 0 };
- static cilist io___188 = { 0, 0, 0, fmt_10003, 0 };
- static cilist io___189 = { 0, 0, 0, fmt_9996, 0 };
+ /* Local variables */
+ static real beta;
+ static integer ldas, ldbs, ldcs;
+ static logical same;
+ static char side[1];
+ static logical left, null;
+ static char uplo[1];
+ static integer i__, m, n;
+ static real alpha;
+ static logical isame[13];
+ static char sides[1];
+ static integer nargs;
+ static logical reset;
+ static char uplos[1];
+ static integer ia, ib, na, nc, im, in, ms, ns;
+ static real errmax;
+ extern logical lseres_(char*, char*, integer*, integer*, real*, real*, integer*);
+ extern /* Subroutine */ void cssymm_(integer*, char*, char*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*);
+ extern void sprcn2_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, real*, integer*, integer*, real*, integer*);
+ extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, logical*, real*);
+ extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*);
+ static integer laa, lbb, lda, lcc, ldb, ldc, ics;
+ static real als, bls;
+ static integer icu;
+ extern logical lse_(real*, real*, integer*);
+ static real err;
/* Tests SSYMM. */
@@ -1765,13 +1354,10 @@ static logical c_false = FALSE_;
if (*trace) {
sprcn2_(ntra, &nc, sname, iorder, side, uplo,
&m, &n, &alpha, &lda, &ldb, &beta, &
- ldc)
- ;
+ ldc);
}
if (*rewi) {
- al__1.aerr = 0;
- al__1.aunit = *ntra;
- f_rew(&al__1);
+// f_rew(&al__1);
}
cssymm_(iorder, side, uplo, &m, &n, &alpha, &aa[1]
, &lda, &bb[1], &ldb, &beta, &cc[1], &ldc);
@@ -1779,9 +1365,7 @@ static logical c_false = FALSE_;
/* Check if error-exit was taken incorrectly. */
if (! infoc_1.ok) {
- io___180.ciunit = *nout;
- s_wsfe(&io___180);
- e_wsfe();
+ printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");
*fatal = TRUE_;
goto L110;
}
@@ -1816,12 +1400,7 @@ static logical c_false = FALSE_;
for (i__ = 1; i__ <= i__5; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
- io___183.ciunit = *nout;
- s_wsfe(&io___183);
- i__6 = i__ + 1;
- do_fio(&c__1, (char *)&i__6, (ftnlen)
- sizeof(integer));
- e_wsfe();
+ printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
}
/* L40: */
}
@@ -1847,7 +1426,7 @@ static logical c_false = FALSE_;
&ct[1], &g[1], &cc[1], &ldc, eps,
&err, fatal, nout, &c_true);
}
- errmax = f2cmax(errmax,err);
+ errmax = dmax(errmax,err);
/* If got really bad answer, report and */
/* return. */
if (*fatal) {
@@ -1879,44 +1458,25 @@ static logical c_false = FALSE_;
if (errmax < *thresh) {
if (*iorder == 0) {
- io___185.ciunit = *nout;
- s_wsfe(&io___185);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
if (*iorder == 1) {
- io___186.ciunit = *nout;
- s_wsfe(&io___186);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
} else {
if (*iorder == 0) {
- io___187.ciunit = *nout;
- s_wsfe(&io___187);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
- e_wsfe();
+ 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) {
- io___188.ciunit = *nout;
- s_wsfe(&io___188);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
- e_wsfe();
- }
+ 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:
- io___189.ciunit = *nout;
- s_wsfe(&io___189);
- do_fio(&c__1, sname, (ftnlen)13);
- e_wsfe();
+ printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
sprcn2_(nout, &nc, sname, iorder, side, uplo, &m, &n, &alpha, &lda, &ldb,
&beta, &ldc);
@@ -1930,23 +1490,13 @@ static logical c_false = FALSE_;
} /* schk2_ */
-/* Subroutine */ int sprcn2_(integer *nout, integer *nc, char *sname, integer
+/* Subroutine */ void sprcn2_(integer *nout, integer *nc, char *sname, integer
*iorder, char *side, char *uplo, integer *m, integer *n, real *alpha,
integer *lda, integer *ldb, real *beta, integer *ldc)
{
- /* Format strings */
- static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
- "a14,\002,\002,a14,\002,\002)";
- static char fmt_9994[] = "(20x,2(i3,\002,\002),f4.1,\002, A,\002,i3,\002"
- ", B,\002,i3,\002,\002,f4.1,\002, \002,\002C,\002,i3,\002).\002)";
/* Local variables */
- char cs[14], cu[14], crc[14];
-
- /* Fortran I/O blocks */
- static cilist io___193 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___194 = { 0, 0, 0, fmt_9994, 0 };
-
+ static char cs[14], cu[14], crc[14];
if (*(unsigned char *)side == 'L') {
s_copy(cs, " CblasLeft", (ftnlen)14, (ftnlen)14);
@@ -1963,25 +1513,8 @@ static logical c_false = FALSE_;
} else {
s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
}
- io___193.ciunit = *nout;
- s_wsfe(&io___193);
- do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, crc, (ftnlen)14);
- do_fio(&c__1, cs, (ftnlen)14);
- do_fio(&c__1, cu, (ftnlen)14);
- e_wsfe();
- io___194.ciunit = *nout;
- s_wsfe(&io___194);
- do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(real));
- do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(real));
- do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
- e_wsfe();
- return 0;
+ 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_ */
@@ -1993,86 +1526,45 @@ static logical c_false = FALSE_;
{
/* Initialized data */
- static char ichu[2] = "UL";
- static char icht[3] = "NTC";
- static char ichd[2] = "UN";
- static char ichs[2] = "LR";
-
- /* Format strings */
- static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
- "TAKEN ON VALID CALL *******\002)";
- static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
- " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
- static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
- "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
- " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
- "BER:\002)";
+ 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;
- alist al__1;
-
- /* Local variables */
- integer i__, j, m, n, ia, na, nc, im, in, ms, ns, laa, icd, lbb, lda, ldb,
- ics;
- real als;
- integer ict, icu;
- extern logical lse_(real *, real *, integer *);
- real err;
- char diag[1];
- integer ldas, ldbs;
- logical same;
- char side[1];
- logical left, null;
- char uplo[1];
- real alpha;
- char diags[1];
- logical isame[13];
- extern /* Subroutine */ int smake_(char *, char *, char *, integer *,
- integer *, real *, integer *, real *, integer *, logical *, real *
- );
- char sides[1];
- extern /* Subroutine */ int smmch_(char *, char *, integer *, integer *,
- integer *, real *, real *, integer *, real *, integer *, real *,
- real *, integer *, real *, real *, real *, integer *, real *,
- real *, logical *, integer *, logical *);
- integer nargs;
- logical reset;
- char uplos[1];
- extern /* Subroutine */ int sprcn3_(integer *, integer *, char *, integer
- *, char *, char *, char *, char *, integer *, integer *, real *,
- integer *, integer *);
- char tranas[1], transa[1];
- real errmax;
- extern logical lseres_(char *, char *, integer *, integer *, real *, real
- *, integer *);
- extern /* Subroutine */ int cstrmm_(integer *, char *, char *, char *,
- char *, integer *, integer *, real *, real *, integer *, real *,
- integer *), cstrsm_(integer *,
- char *, char *, char *, char *, integer *, integer *, real *,
- real *, integer *, real *, integer *);
-
- /* Fortran I/O blocks */
- static cilist io___235 = { 0, 0, 0, fmt_9994, 0 };
- static cilist io___238 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___240 = { 0, 0, 0, fmt_10000, 0 };
- static cilist io___241 = { 0, 0, 0, fmt_10001, 0 };
- static cilist io___242 = { 0, 0, 0, fmt_10002, 0 };
- static cilist io___243 = { 0, 0, 0, fmt_10003, 0 };
- static cilist io___244 = { 0, 0, 0, fmt_9996, 0 };
+ /* 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_(integer*, integer*, char*, integer*, char*, char*, char*, char*, integer*, integer*, real*, integer*, integer*);
+ static integer ia, na, nc, im, in, ms, ns;
+ static char tranas[1], transa[1];
+ static real errmax;
+ extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, logical*, real*);
+ extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*);
+ extern logical lseres_(char*, char*, integer*, integer*, real*, real*, integer*);
+ extern /* Subroutine */ void cstrmm_(integer*, char*, char*, char*, char*, integer*, integer*, real*, real*, integer*, real*, integer*);
+ extern /* Subroutine */ void cstrsm_(integer*, char*, char*, char*, char*, integer*, integer*, real*, real*, integer*, real*, integer*);
+ static integer laa, icd, lbb, lda, ldb, ics;
+ static real als;
+ static integer ict, icu;
+ extern logical lse_(real*, real*, integer*);
+ static real err;
/* Tests STRMM and STRSM. */
@@ -2223,9 +1715,7 @@ static logical c_false = FALSE_;
&n, &alpha, &lda, &ldb);
}
if (*rewi) {
- al__1.aerr = 0;
- al__1.aunit = *ntra;
- f_rew(&al__1);
+// f_rew(&al__1);
}
cstrmm_(iorder, side, uplo, transa, diag,
&m, &n, &alpha, &aa[1], &lda, &bb[
@@ -2238,9 +1728,7 @@ static logical c_false = FALSE_;
&n, &alpha, &lda, &ldb);
}
if (*rewi) {
- al__1.aerr = 0;
- al__1.aunit = *ntra;
- f_rew(&al__1);
+// f_rew(&al__1);
}
cstrsm_(iorder, side, uplo, transa, diag,
&m, &n, &alpha, &aa[1], &lda, &bb[
@@ -2250,9 +1738,7 @@ static logical c_false = FALSE_;
/* Check if error-exit was taken incorrectly. */
if (! infoc_1.ok) {
- io___235.ciunit = *nout;
- s_wsfe(&io___235);
- e_wsfe();
+ printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");
*fatal = TRUE_;
goto L150;
}
@@ -2288,12 +1774,7 @@ static logical c_false = FALSE_;
for (i__ = 1; i__ <= i__4; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
- io___238.ciunit = *nout;
- s_wsfe(&io___238);
- i__5 = i__ + 1;
- do_fio(&c__1, (char *)&i__5, (ftnlen)
- sizeof(integer));
- e_wsfe();
+ printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
}
/* L50: */
}
@@ -2315,8 +1796,7 @@ static logical c_false = FALSE_;
c_b103, &c__[c_offset],
nmax, &ct[1], &g[1], &bb[
1], &ldb, eps, &err,
- fatal, nout, &c_true, (
- ftnlen)1, (ftnlen)1);
+ fatal, nout, &c_true);
} else {
smmch_("N", transa, &m, &n, &n, &
alpha, &b[b_offset], nmax,
@@ -2363,7 +1843,7 @@ static logical c_false = FALSE_;
fatal, nout, &c_false);
}
}
- errmax = f2cmax(errmax,err);
+ errmax = dmax(errmax,err);
/* If got really bad answer, report and */
/* return. */
if (*fatal) {
@@ -2397,44 +1877,25 @@ static logical c_false = FALSE_;
if (errmax < *thresh) {
if (*iorder == 0) {
- io___240.ciunit = *nout;
- s_wsfe(&io___240);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
if (*iorder == 1) {
- io___241.ciunit = *nout;
- s_wsfe(&io___241);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
} else {
if (*iorder == 0) {
- io___242.ciunit = *nout;
- s_wsfe(&io___242);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
- e_wsfe();
+ 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) {
- io___243.ciunit = *nout;
- s_wsfe(&io___243);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
- e_wsfe();
+ 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:
- io___244.ciunit = *nout;
- s_wsfe(&io___244);
- do_fio(&c__1, sname, (ftnlen)13);
- e_wsfe();
+ printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
if (*trace) {
sprcn3_(ntra, &nc, sname, iorder, side, uplo, transa, diag, &m, &n, &
alpha, &lda, &ldb);
@@ -2450,23 +1911,13 @@ static logical c_false = FALSE_;
} /* schk3_ */
-/* Subroutine */ int sprcn3_(integer *nout, integer *nc, char *sname, integer
+/* Subroutine */ void sprcn3_(integer *nout, integer *nc, char *sname, integer
*iorder, char *side, char *uplo, char *transa, char *diag, integer *m,
integer *n, real *alpha, integer *lda, integer *ldb)
{
- /* Format strings */
- static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
- "a14,\002,\002,a14,\002,\002)";
- static char fmt_9994[] = "(22x,2(a14,\002,\002),2(i3,\002,\002),f4.1,"
- "\002, A,\002,i3,\002, B,\002,i3,\002).\002)";
/* Local variables */
- char ca[14], cd[14], cs[14], cu[14], crc[14];
-
- /* Fortran I/O blocks */
- static cilist io___250 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___251 = { 0, 0, 0, fmt_9994, 0 };
-
+ 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);
@@ -2495,25 +1946,9 @@ static logical c_false = FALSE_;
} else {
s_copy(crc, "CblasColMajor", (ftnlen)14, (ftnlen)13);
}
- io___250.ciunit = *nout;
- s_wsfe(&io___250);
- do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, crc, (ftnlen)14);
- do_fio(&c__1, cs, (ftnlen)14);
- do_fio(&c__1, cu, (ftnlen)14);
- e_wsfe();
- io___251.ciunit = *nout;
- s_wsfe(&io___251);
- do_fio(&c__1, ca, (ftnlen)14);
- do_fio(&c__1, cd, (ftnlen)14);
- do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(real));
- do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
- e_wsfe();
- return 0;
+ 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_ */
@@ -2526,82 +1961,42 @@ static logical c_false = FALSE_;
{
/* Initialized data */
- static char icht[3] = "NTC";
- static char ichu[2] = "UL";
-
- /* Format strings */
- static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
- "TAKEN ON VALID CALL *******\002)";
- static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
- " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
- static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
- "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
- " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
- " \002,i3)";
- static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
- "BER:\002)";
+ 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, i__6;
- alist al__1;
-
- /* Local variables */
- integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa,
- lda, lcc, ldc;
- real als;
- integer ict, icu;
- extern logical lse_(real *, real *, integer *);
- real err, beta;
- integer ldas, ldcs;
- logical same;
- real bets;
- logical tran, null;
- char uplo[1];
- real alpha;
- logical isame[13];
- extern /* Subroutine */ int smake_(char *, char *, char *, integer *,
- integer *, real *, integer *, real *, integer *, logical *, real *
- ), smmch_(char *, char *, integer *,
- integer *, integer *, real *, real *, integer *, real *, integer *
- , real *, real *, integer *, real *, real *, real *, integer *,
- real *, real *, logical *, integer *, logical *);
- integer nargs;
- logical reset;
- char trans[1];
- logical upper;
- char uplos[1];
- extern /* Subroutine */ int sprcn4_(integer *, integer *, char *, integer
- *, char *, char *, integer *, integer *, real *, integer *, real *
- , integer *);
- real errmax;
- extern logical lseres_(char *, char *, integer *, integer *, real *, real
- *, integer *);
- char transs[1];
- extern /* Subroutine */ int cssyrk_(integer *, char *, char *, integer *,
- integer *, real *, real *, integer *, real *, real *, integer *);
-
- /* Fortran I/O blocks */
- static cilist io___288 = { 0, 0, 0, fmt_9993, 0 };
- static cilist io___291 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___297 = { 0, 0, 0, fmt_10000, 0 };
- static cilist io___298 = { 0, 0, 0, fmt_10001, 0 };
- static cilist io___299 = { 0, 0, 0, fmt_10002, 0 };
- static cilist io___300 = { 0, 0, 0, fmt_10003, 0 };
- static cilist io___301 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___302 = { 0, 0, 0, fmt_9996, 0 };
+ i__3, i__4, i__5;
+ /* 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_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, real*, integer*, real*, integer*);
+ extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, logical*, real*);
+ extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*);
+ static integer ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns;
+ static real errmax;
+ extern logical lseres_(char*, char*, integer*, integer*, real*, real*, integer*);
+ static char transs[1];
+ extern /* Subroutine */ void cssyrk_(integer*, char*, char*, integer*, integer*, real*, real*, integer*, real*, real*, integer*);
+ static integer laa, lda, lcc, ldc;
+ static real als;
+ static integer ict, icu;
+ extern logical lse_(real*, real*, integer*);
+ static real err;
/* Tests SSYRK. */
@@ -2737,9 +2132,7 @@ static logical c_false = FALSE_;
&n, &k, &alpha, &lda, &beta, &ldc);
}
if (*rewi) {
- al__1.aerr = 0;
- al__1.aunit = *ntra;
- f_rew(&al__1);
+// f_rew(&al__1);
}
cssyrk_(iorder, uplo, trans, &n, &k, &alpha, &aa[
1], &lda, &beta, &cc[1], &ldc);
@@ -2747,9 +2140,7 @@ static logical c_false = FALSE_;
/* Check if error-exit was taken incorrectly. */
if (! infoc_1.ok) {
- io___288.ciunit = *nout;
- s_wsfe(&io___288);
- e_wsfe();
+ printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");
*fatal = TRUE_;
goto L120;
}
@@ -2782,12 +2173,7 @@ static logical c_false = FALSE_;
for (i__ = 1; i__ <= i__5; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
- io___291.ciunit = *nout;
- s_wsfe(&io___291);
- i__6 = i__ + 1;
- do_fio(&c__1, (char *)&i__6, (ftnlen)
- sizeof(integer));
- e_wsfe();
+ printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
}
/* L30: */
}
@@ -2832,7 +2218,7 @@ static logical c_false = FALSE_;
} else {
jc = jc + ldc + 1;
}
- errmax = f2cmax(errmax,err);
+ errmax = dmax(errmax,err);
/* If got really bad answer, report and */
/* return. */
if (*fatal) {
@@ -2866,52 +2252,30 @@ static logical c_false = FALSE_;
if (errmax < *thresh) {
if (*iorder == 0) {
- io___297.ciunit = *nout;
- s_wsfe(&io___297);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
if (*iorder == 1) {
- io___298.ciunit = *nout;
- s_wsfe(&io___298);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
} else {
if (*iorder == 0) {
- io___299.ciunit = *nout;
- s_wsfe(&io___299);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
- e_wsfe();
+ 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) {
- io___300.ciunit = *nout;
- s_wsfe(&io___300);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
- e_wsfe();
+ 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) {
- io___301.ciunit = *nout;
- s_wsfe(&io___301);
- do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j);
}
L120:
- io___302.ciunit = *nout;
- s_wsfe(&io___302);
- do_fio(&c__1, sname, (ftnlen)13);
- e_wsfe();
+ printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
sprcn4_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &
beta, &ldc);
@@ -2925,23 +2289,13 @@ static logical c_false = FALSE_;
} /* schk4_ */
-/* Subroutine */ int sprcn4_(integer *nout, integer *nc, char *sname, integer
+/* Subroutine */ void sprcn4_(integer *nout, integer *nc, char *sname, integer
*iorder, char *uplo, char *transa, integer *n, integer *k, real *
alpha, integer *lda, real *beta, integer *ldc)
{
- /* Format strings */
- static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002,"
- "\002))";
- static char fmt_9994[] = "(20x,2(i3,\002,\002),f4.1,\002, A,\002,i3"
- ",\002,\002,f4.1,\002, C,\002,i3,\002).\002)";
/* Local variables */
- char ca[14], cu[14], crc[14];
-
- /* Fortran I/O blocks */
- static cilist io___306 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___307 = { 0, 0, 0, fmt_9994, 0 };
-
+ static char ca[14], cu[14], crc[14];
if (*(unsigned char *)uplo == 'U') {
s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14);
@@ -2960,24 +2314,9 @@ static logical c_false = FALSE_;
} else {
s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
}
- io___306.ciunit = *nout;
- s_wsfe(&io___306);
- do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, crc, (ftnlen)14);
- do_fio(&c__1, cu, (ftnlen)14);
- do_fio(&c__1, ca, (ftnlen)14);
- e_wsfe();
- io___307.ciunit = *nout;
- s_wsfe(&io___307);
- do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(real));
- do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(real));
- do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
- e_wsfe();
- return 0;
+ 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_ */
@@ -2990,84 +2329,43 @@ static logical c_false = FALSE_;
{
/* Initialized data */
- static char icht[3] = "NTC";
- static char ichu[2] = "UL";
-
- /* Format strings */
- static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
- "TAKEN ON VALID CALL *******\002)";
- static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
- " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
- static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
- "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
- " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
- " \002,i3)";
- static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
- "BER:\002)";
+ 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;
- alist al__1;
-
- /* Local variables */
- integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa,
- lbb, lda, lcc, ldb, ldc;
- real als;
- integer ict, icu;
- extern logical lse_(real *, real *, integer *);
- real err;
- integer jjab;
- real beta;
- integer ldas, ldbs, ldcs;
- logical same;
- real bets;
- logical tran, null;
- char uplo[1];
- real alpha;
- logical isame[13];
- extern /* Subroutine */ int smake_(char *, char *, char *, integer *,
- integer *, real *, integer *, real *, integer *, logical *, real *
- ), smmch_(char *, char *, integer *,
- integer *, integer *, real *, real *, integer *, real *, integer *
- , real *, real *, integer *, real *, real *, real *, integer *,
- real *, real *, logical *, integer *, logical *);
- integer nargs;
- logical reset;
- char trans[1];
- logical upper;
- char uplos[1];
- extern /* Subroutine */ int sprcn5_(integer *, integer *, char *, integer
- *, char *, char *, integer *, integer *, real *, integer *,
- integer *, real *, integer *);
- real errmax;
- extern logical lseres_(char *, char *, integer *, integer *, real *, real
- *, integer *);
- char transs[1];
- extern /* Subroutine */ int cssyr2k_(integer *, char *, char *, integer *,
- integer *, real *, real *, integer *, real *, integer *, real *,
- real *, integer *);
-
- /* Fortran I/O blocks */
- static cilist io___347 = { 0, 0, 0, fmt_9993, 0 };
- static cilist io___350 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___357 = { 0, 0, 0, fmt_10000, 0 };
- static cilist io___358 = { 0, 0, 0, fmt_10001, 0 };
- static cilist io___359 = { 0, 0, 0, fmt_10002, 0 };
- static cilist io___360 = { 0, 0, 0, fmt_10003, 0 };
- static cilist io___361 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___362 = { 0, 0, 0, fmt_9996, 0 };
+ /* Local variables */
+ static integer jjab;
+ static real beta;
+ static integer ldas, ldbs, ldcs;
+ static logical same;
+ static real bets;
+ static logical tran, null;
+ static char uplo[1];
+ static integer i__, j, k, n;
+ static real alpha;
+ static logical isame[13];
+ static integer nargs;
+ static logical reset;
+ static char trans[1];
+ static logical upper;
+ static char uplos[1];
+ static integer ia, ib;
+ extern /* Subroutine */ void sprcn5_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, real*, integer*, integer*, real*, integer*);
+ static integer jc, ma, na, nc, ik, in, jj, lj, ks, ns;
+ static real errmax;
+ extern logical lseres_(char*, char*, integer*, integer*, real*, real*, integer*);
+ extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, logical*, real*);
+ static char transs[1];
+ static integer laa, lbb, lda, lcc, ldb, ldc;
+ static real als;
+ static integer ict, icu;
+ extern /* Subroutine */ void cssyr2k_(integer*, char*, char*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*);
+ extern logical lse_(real*, real*, integer*);
+ extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*);
+ static real err;
/* Tests SSYR2K. */
@@ -3225,9 +2523,7 @@ static logical c_false = FALSE_;
;
}
if (*rewi) {
- al__1.aerr = 0;
- al__1.aunit = *ntra;
- f_rew(&al__1);
+// f_rew(&al__1);
}
cssyr2k_(iorder, uplo, trans, &n, &k, &alpha, &aa[
1], &lda, &bb[1], &ldb, &beta, &cc[1], &
@@ -3236,9 +2532,7 @@ static logical c_false = FALSE_;
/* Check if error-exit was taken incorrectly. */
if (! infoc_1.ok) {
- io___347.ciunit = *nout;
- s_wsfe(&io___347);
- e_wsfe();
+ printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");
*fatal = TRUE_;
goto L150;
}
@@ -3273,12 +2567,7 @@ static logical c_false = FALSE_;
for (i__ = 1; i__ <= i__5; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
- io___350.ciunit = *nout;
- s_wsfe(&io___350);
- i__6 = i__ + 1;
- do_fio(&c__1, (char *)&i__6, (ftnlen)
- sizeof(integer));
- e_wsfe();
+ printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
}
/* L40: */
}
@@ -3305,9 +2594,9 @@ static logical c_false = FALSE_;
if (tran) {
i__6 = k;
for (i__ = 1; i__ <= i__6; ++i__) {
- w[i__] = ab[(j - 1 << 1) * *nmax
+ w[i__] = ab[((j - 1) << 1) * *nmax
+ k + i__];
- w[k + i__] = ab[(j - 1 << 1) * *
+ w[k + i__] = ab[((j - 1) << 1) * *
nmax + i__];
/* L50: */
}
@@ -3346,7 +2635,7 @@ static logical c_false = FALSE_;
jjab += *nmax << 1;
}
}
- errmax = f2cmax(errmax,err);
+ errmax = dmax(errmax,err);
/* If got really bad answer, report and */
/* return. */
if (*fatal) {
@@ -3380,52 +2669,30 @@ static logical c_false = FALSE_;
if (errmax < *thresh) {
if (*iorder == 0) {
- io___357.ciunit = *nout;
- s_wsfe(&io___357);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
if (*iorder == 1) {
- io___358.ciunit = *nout;
- s_wsfe(&io___358);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
} else {
if (*iorder == 0) {
- io___359.ciunit = *nout;
- s_wsfe(&io___359);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
- e_wsfe();
+ 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) {
- io___360.ciunit = *nout;
- s_wsfe(&io___360);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
- e_wsfe();
+ 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) {
- io___361.ciunit = *nout;
- s_wsfe(&io___361);
- do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j);
}
L150:
- io___362.ciunit = *nout;
- s_wsfe(&io___362);
- do_fio(&c__1, sname, (ftnlen)13);
- e_wsfe();
+ printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
sprcn5_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &ldb,
&beta, &ldc);
@@ -3439,23 +2706,13 @@ static logical c_false = FALSE_;
} /* schk5_ */
-/* Subroutine */ int sprcn5_(integer *nout, integer *nc, char *sname, integer
+/* Subroutine */ void sprcn5_(integer *nout, integer *nc, char *sname, integer
*iorder, char *uplo, char *transa, integer *n, integer *k, real *
alpha, integer *lda, integer *ldb, real *beta, integer *ldc)
{
- /* Format strings */
- static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002,"
- "\002))";
- static char fmt_9994[] = "(20x,2(i3,\002,\002),f4.1,\002, A,\002,i3,\002"
- ", B\002,i3,\002,\002,f4.1,\002, C,\002,i3,\002).\002)";
/* Local variables */
- char ca[14], cu[14], crc[14];
-
- /* Fortran I/O blocks */
- static cilist io___366 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___367 = { 0, 0, 0, fmt_9994, 0 };
-
+ static char ca[14], cu[14], crc[14];
if (*(unsigned char *)uplo == 'U') {
s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14);
@@ -3474,25 +2731,9 @@ static logical c_false = FALSE_;
} else {
s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
}
- io___366.ciunit = *nout;
- s_wsfe(&io___366);
- do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, crc, (ftnlen)14);
- do_fio(&c__1, cu, (ftnlen)14);
- do_fio(&c__1, ca, (ftnlen)14);
- e_wsfe();
- io___367.ciunit = *nout;
- s_wsfe(&io___367);
- do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(real));
- do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(real));
- do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
- e_wsfe();
- return 0;
+ 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_ */
@@ -3504,11 +2745,11 @@ static logical c_false = FALSE_;
integer a_dim1, a_offset, i__1, i__2;
/* Local variables */
- integer i__, j;
- logical gen, tri, sym;
- integer ibeg, iend;
- extern real sbeg_(logical *);
- logical unit, lower, upper;
+ static integer ibeg, iend;
+ extern real sbeg_(logical*);
+ static logical unit;
+ static integer i__, j;
+ static logical lower, upper, gen, tri, sym;
/* Generates values for an M by N matrix A. */
@@ -3545,7 +2786,7 @@ static logical c_false = FALSE_;
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 (gen || (upper && i__ <= j) || (lower && i__ >= j)) {
a[i__ + j * a_dim1] = sbeg_(reset) + *transl;
if (i__ != j) {
/* Set some elements to zero */
@@ -3636,31 +2877,19 @@ static logical c_false = FALSE_;
integer *ldcc, real *eps, real *err, logical *fatal, integer *nout,
logical *mv)
{
- /* Format strings */
- static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS"
- " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 EX"
- "PECTED RESULT COMPU\002,\002TED RESULT\002)";
- static char fmt_9998[] = "(1x,i7,2g18.6)";
- static char fmt_9997[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
- " \002,i3)";
/* 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;
- /* Local variables */
- integer i__, j, k;
- real erri;
- logical trana, tranb;
-
- /* Fortran I/O blocks */
- static cilist io___384 = { 0, 0, 0, fmt_9999, 0 };
- static cilist io___385 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___386 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___387 = { 0, 0, 0, fmt_9997, 0 };
-
+ /* Builtin functions */
+ double sqrt(double);
+ /* Local variables */
+ static real erri;
+ static integer i__, j, k;
+ static logical trana, tranb;
/* Checks the results of the computational tests. */
@@ -3713,8 +2942,8 @@ static logical c_false = FALSE_;
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], abs(r__1)) * (r__2
- = b[k + j * b_dim1], abs(r__2));
+ g[i__] += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) * (
+ r__2 = b[k + j * b_dim1], dabs(r__2));
/* L20: */
}
/* L30: */
@@ -3725,8 +2954,8 @@ static logical c_false = FALSE_;
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], abs(r__1)) * (r__2
- = b[k + j * b_dim1], abs(r__2));
+ g[i__] += (r__1 = a[k + i__ * a_dim1], dabs(r__1)) * (
+ r__2 = b[k + j * b_dim1], dabs(r__2));
/* L40: */
}
/* L50: */
@@ -3737,8 +2966,8 @@ static logical c_false = FALSE_;
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], abs(r__1)) * (r__2
- = b[j + k * b_dim1], abs(r__2));
+ g[i__] += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) * (
+ r__2 = b[j + k * b_dim1], dabs(r__2));
/* L60: */
}
/* L70: */
@@ -3749,8 +2978,8 @@ static logical c_false = FALSE_;
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], abs(r__1)) * (r__2
- = b[j + k * b_dim1], abs(r__2));
+ g[i__] += (r__1 = a[k + i__ * a_dim1], dabs(r__1)) * (
+ r__2 = b[j + k * b_dim1], dabs(r__2));
/* L80: */
}
/* L90: */
@@ -3759,8 +2988,8 @@ static logical c_false = FALSE_;
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) * (r__1 = c__[i__ + j *
- c_dim1], abs(r__1));
+ g[i__] = dabs(*alpha) * g[i__] + dabs(*beta) * (r__1 = c__[i__ +
+ j * c_dim1], dabs(r__1));
/* L100: */
}
@@ -3769,12 +2998,13 @@ static logical c_false = FALSE_;
*err = 0.f;
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
- erri = (r__1 = ct[i__] - cc[i__ + j * cc_dim1], abs(r__1)) / *eps;
- if (g[i__] != 0.f) {
+ erri = (r__1 = ct[i__] - cc[i__ + j * cc_dim1], dabs(r__1)) / *
+ eps;
+ if (g[i__] != (float)0.) {
erri /= g[i__];
}
- *err = f2cmax(*err,erri);
- if (*err * sqrt(*eps) >= 1.f) {
+ *err = dmax(*err,erri);
+ if (*err * sqrt(*eps) >= (float)1.) {
goto L130;
}
/* L110: */
@@ -3790,35 +3020,19 @@ static logical c_false = FALSE_;
L130:
*fatal = TRUE_;
- io___384.ciunit = *nout;
- s_wsfe(&io___384);
- e_wsfe();
+ 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) {
- io___385.ciunit = *nout;
- s_wsfe(&io___385);
- do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&ct[i__], (ftnlen)sizeof(real));
- do_fio(&c__1, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(real)
- );
- e_wsfe();
+ printf("%7d %15.6g %15.6g\n",i__,ct[i__],cc[i__+j*cc_dim1]);
} else {
- io___386.ciunit = *nout;
- s_wsfe(&io___386);
- do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(real)
- );
- do_fio(&c__1, (char *)&ct[i__], (ftnlen)sizeof(real));
- e_wsfe();
+ printf("%7d %15.6g %15.6g\n",i__,cc[i__+j*cc_dim1],ct[i__]);
}
/* L140: */
}
if (*n > 1) {
- io___387.ciunit = *nout;
- s_wsfe(&io___387);
- do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf(" THESE ARE THE RESULTS FOR COLUMN %d\n",j);
}
L150:
@@ -3829,14 +3043,14 @@ static logical c_false = FALSE_;
} /* smmch_ */
-logical lse_(real *ri, real *rj, integer *lr)
+logical lse_(real* ri, real* rj, integer* lr)
{
/* System generated locals */
integer i__1;
logical ret_val;
/* Local variables */
- integer i__;
+ static integer i__;
/* Tests if two arrays are identical. */
@@ -3872,16 +3086,15 @@ logical lse_(real *ri, real *rj, integer *lr)
} /* lse_ */
-logical lseres_(char *type__, char *uplo, integer *m, integer *n, real *aa,
- real *as, integer *lda)
+logical lseres_(char* type__, char* uplo, integer* m, integer* n, real* aa, real* as, integer* lda)
{
/* System generated locals */
integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2;
logical ret_val;
/* Local variables */
- integer i__, j, ibeg, iend;
- logical upper;
+ static integer ibeg, iend, i__, j;
+ static logical upper;
/* Tests if selected elements in two arrays are equal. */
@@ -4085,7 +3298,7 @@ real sdiff_(real *x, real *y)
integer nargs;
logical reset;
char uplos[1];
- extern /* Subroutine */ int sprcn8_(integer *, integer *, char *, integer
+ extern /* Subroutine */ void sprcn8_(integer *, integer *, char *, integer
*, char *, char *, char *, integer *, integer *, real *, integer *
, integer *, real *, integer *);
char tranas[1], tranbs[1], transa[1], transb[1];
@@ -4097,17 +3310,6 @@ real sdiff_(real *x, real *y)
extern logical lseres_(char *, char *, integer *, integer *, real *, real
*, integer *);
- /* Fortran I/O blocks */
- static cilist io___441 = { 0, 0, 0, fmt_9994, 0 };
- static cilist io___444 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___446 = { 0, 0, 0, fmt_10000, 0 };
- static cilist io___447 = { 0, 0, 0, fmt_10001, 0 };
- static cilist io___448 = { 0, 0, 0, fmt_10002, 0 };
- static cilist io___449 = { 0, 0, 0, fmt_10003, 0 };
- static cilist io___450 = { 0, 0, 0, fmt_9996, 0 };
-
-
-
/* Tests SGEMMTR. */
/* Auxiliary routine for test program for Level 3 Blas. */
@@ -4279,9 +3481,6 @@ real sdiff_(real *x, real *y)
lda, &ldb, &beta, &ldc);
}
if (*rewi) {
- al__1.aerr = 0;
- al__1.aunit = *ntra;
- f_rew(&al__1);
}
csgemmtr_(iorder, uplo, transa, transb, &n, &
k, &alpha, &aa[1], &lda, &bb[1], &ldb,
@@ -4289,11 +3488,9 @@ real sdiff_(real *x, real *y)
/* Check if error-exit was taken incorrectly. */
- if (! infoc_2.ok) {
- io___441.ciunit = *nout;
- s_wsfe(&io___441);
- e_wsfe();
- *fatal = TRUE_;
+ if (! infoc_.ok) {
+ printf(" *** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");
+ *fatal = TRUE_;
goto L120;
}
@@ -4329,12 +3526,8 @@ real sdiff_(real *x, real *y)
for (i__ = 1; i__ <= i__5; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
- io___444.ciunit = *nout;
- s_wsfe(&io___444);
- do_fio(&c__1, (char *)&i__, (ftnlen)
- sizeof(integer));
- e_wsfe();
- }
+ printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
+ }
/* L40: */
}
if (! same) {
@@ -4388,45 +3581,26 @@ real sdiff_(real *x, real *y)
/* Report result. */
if (errmax < *thresh) {
- if (*iorder == 0) {
- io___446.ciunit = *nout;
- s_wsfe(&io___446);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
- }
- if (*iorder == 1) {
- io___447.ciunit = *nout;
- s_wsfe(&io___447);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
- }
+ 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) {
- io___448.ciunit = *nout;
- s_wsfe(&io___448);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
- e_wsfe();
- }
- if (*iorder == 1) {
- io___449.ciunit = *nout;
- s_wsfe(&io___449);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
- e_wsfe();
- }
+ 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:
- io___450.ciunit = *nout;
- s_wsfe(&io___450);
- do_fio(&c__1, sname, (ftnlen)13);
- e_wsfe();
+ printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
sprcn8_(nout, &nc, sname, iorder, uplo, transa, transb, &n, &k, &alpha, &
lda, &ldb, &beta, &ldc);
@@ -4440,7 +3614,7 @@ real sdiff_(real *x, real *y)
} /* schk6_ */
-/* Subroutine */ int sprcn8_(integer *nout, integer *nc, char *sname, integer
+/* Subroutine */ void sprcn8_(integer *nout, integer *nc, char *sname, integer
*iorder, char *uplo, char *transa, char *transb, integer *n, integer *
k, real *alpha, integer *lda, integer *ldb, real *beta, integer *ldc)
{
@@ -4454,11 +3628,6 @@ real sdiff_(real *x, real *y)
/* Local variables */
char crc[14], cta[14], ctb[14], cuplo[14];
- /* Fortran I/O blocks */
- static cilist io___455 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___456 = { 0, 0, 0, fmt_9994, 0 };
-
-
if (*(unsigned char *)uplo == 'U') {
s_copy(cuplo, "CblasUpper", (ftnlen)14, (ftnlen)10);
} else {
@@ -4483,26 +3652,8 @@ real sdiff_(real *x, real *y)
} else {
s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
}
- io___455.ciunit = *nout;
- s_wsfe(&io___455);
- do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, crc, (ftnlen)14);
- do_fio(&c__1, cuplo, (ftnlen)14);
- do_fio(&c__1, cta, (ftnlen)14);
- do_fio(&c__1, ctb, (ftnlen)14);
- e_wsfe();
- io___456.ciunit = *nout;
- s_wsfe(&io___456);
- do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(real));
- do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(real));
- do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
- e_wsfe();
- return 0;
+ printf("%6d: %s %s %s %s %s\n",*nc,sname,crc,cuplo,cta,ctb);
+ printf("%d %d %4.1f A, %d, B, %d, %4.1f, C, %d.\n",*n,*k,*alpha,*lda,*ldb,*beta,*ldc);
} /* sprcn8_ */
/* Subroutine */ int smmtch_(char *uplo, char *transa, char *transb, integer *
@@ -4512,9 +3663,6 @@ real sdiff_(real *x, real *y)
logical *mv)
{
/* Format strings */
- static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS"
- " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 EX"
- "PECTED RESULT COMPU\002,\002TED RESULT\002)";
static char fmt_9998[] = "(1x,i7,2g18.6)";
static char fmt_9997[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
" \002,i3)";
@@ -4530,14 +3678,6 @@ real sdiff_(real *x, real *y)
logical trana, tranb, upper;
integer istop, istart;
- /* Fortran I/O blocks */
- static cilist io___466 = { 0, 0, 0, fmt_9999, 0 };
- static cilist io___467 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___468 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___469 = { 0, 0, 0, fmt_9997, 0 };
-
-
-
/* Checks the results of the computational tests. */
/* Auxiliary routine for test program for Level 3 Blas. (DGEMMTR) */
@@ -4673,35 +3813,21 @@ real sdiff_(real *x, real *y)
L130:
*fatal = TRUE_;
- io___466.ciunit = *nout;
- s_wsfe(&io___466);
- e_wsfe();
+ printf(" ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HALF ACCURATE *******\n");
+ printf(" EXPECTED RESULT COMPUTED RESULT\n");
+
i__1 = istop;
- for (i__ = istart; i__ <= i__1; ++i__) {
- if (*mv) {
- io___467.ciunit = *nout;
- s_wsfe(&io___467);
- do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&ct[i__], (ftnlen)sizeof(real));
- do_fio(&c__1, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(real)
- );
- e_wsfe();
- } else {
- io___468.ciunit = *nout;
- s_wsfe(&io___468);
- do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(real)
- );
- do_fio(&c__1, (char *)&ct[i__], (ftnlen)sizeof(real));
- e_wsfe();
- }
+ for (i__ = istart; 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) {
- io___469.ciunit = *nout;
- s_wsfe(&io___469);
- do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf(" THESE ARE THE RESULTS FOR COLUMN %d\n",j);
}
L150:
@@ -4712,4 +3838,3 @@ real sdiff_(real *x, real *y)
} /* smmtch_ */
-/* Main program alias */ int sblat3_ () { MAIN__ (); return 0; }
diff --git a/ctest/c_zblat3c.c b/ctest/c_zblat3c.c
index cee0ed1671..d46030b722 100644
--- a/ctest/c_zblat3c.c
+++ b/ctest/c_zblat3c.c
@@ -22,14 +22,11 @@ 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))
@@ -240,109 +237,6 @@ typedef struct Namelist Namelist;
/* 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
-
-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;
-}
/* Common Block Declarations */
@@ -363,14 +257,8 @@ struct {
static doublecomplex c_b1 = {0.,0.};
static doublecomplex c_b2 = {1.,0.};
-static integer c__9 = 9;
static integer c__1 = 1;
-static integer c__3 = 3;
-static integer c__8 = 8;
-static integer c__5 = 5;
static integer c__65 = 65;
-static integer c__7 = 7;
-static integer c__2 = 2;
static doublereal c_b92 = 1.;
static integer c__6 = 6;
static logical c_true = TRUE_;
@@ -381,55 +269,13 @@ static logical c_false = FALSE_;
{
/* Initialized data */
- static char snames[13*10] = "cblas_zgemm " "cblas_zhemm " "cblas_zsymm"
- " " "cblas_ztrmm " "cblas_ztrsm " "cblas_zherk " "cblas_zsyrk"
- " " "cblas_zher2k " "cblas_zsyr2k " "cblas_zgemmtr";
-
- /* Format strings */
- static char fmt_9997[] = "(\002 NUMBER OF VALUES OF \002,a,\002 IS LESS "
- "THAN 1 OR GREATER \002,\002THAN \002,i2)";
- static char fmt_9996[] = "(\002 VALUE OF N IS LESS THAN 0 OR GREATER THA"
- "N \002,i2)";
- static char fmt_9995[] = "(\002TESTS OF THE COMPLEX*16 LEVEL 3 BL"
- "AS\002,//\002 THE F\002,\002OLLOWING PARAMETER VALUES WILL BE US"
- "ED:\002)";
- static char fmt_9994[] = "(\002 FOR N \002,9i6)";
- static char fmt_9993[] = "(\002 FOR ALPHA \002,7(\002(\002,f4"
- ".1,\002,\002,f4.1,\002) \002,:))";
- static char fmt_9992[] = "(\002 FOR BETA \002,7(\002(\002,f4"
- ".1,\002,\002,f4.1,\002) \002,:))";
- static char fmt_9984[] = "(\002 ERROR-CALL MYEXITS WILL NOT BE TESTED"
- "\002)";
- static char fmt_9999[] = "(\002 ROUTINES PASS COMPUTATIONAL TESTS IF TES"
- "T RATIO IS LES\002,\002S THAN\002,f8.2)";
- static char fmt_10002[] = "(\002 COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS"
- " ARE TESTED\002)";
- static char fmt_10001[] = "(\002 ROW-MAJOR DATA LAYOUT IS TESTED\002)";
- static char fmt_10000[] = "(\002 COLUMN-MAJOR DATA LAYOUT IS TESTED\002)";
- static char fmt_9988[] = "(a13,l2)";
- static char fmt_9990[] = "(\002 SUBPROGRAM NAME \002,a13,\002 NOT RECOGN"
- "IZED\002,/\002 ******* T\002,\002ESTS ABANDONED *******\002)";
- static char fmt_9998[] = "(\002 RELATIVE MACHINE PRECISION IS TAKEN TO"
- " BE\002,1p,e9.1)";
- static char fmt_9989[] = "(\002 ERROR IN ZMMCH - IN-LINE DOT PRODUCTS A"
- "RE BEING EVALU\002,\002ATED WRONGLY.\002,/\002 ZMMCH WAS CALLED "
- "WITH TRANSA = \002,a1,\002AND TRANSB = \002,a1,/\002 AND RETURNE"
- "D SAME = \002,l1,\002 AND \002,\002 ERR = \002,f12.3,\002.\002,"
- "/\002 THIS MAY BE DUE TO FAULTS IN THE \002,\002ARITHMETIC OR TH"
- "E COMPILER.\002,/\002 ******* TESTS ABANDONED \002,\002******"
- "*\002)";
- static char fmt_9987[] = "(1x,a13,\002 WAS NOT TESTED\002)";
- static char fmt_9986[] = "(/\002 END OF TESTS\002)";
- static char fmt_9985[] = "(/\002 ******* FATAL ERROR - TESTS ABANDONED *"
- "******\002)";
- static char fmt_9991[] = "(\002 AMEND DATA FILE OR INCREASE ARRAY SIZES "
- "IN PROGRAM\002,/\002 ******* TESTS ABANDONED *******\002)";
+ static char snames[10][14] = {"cblas_zgemm ","cblas_zhemm ","cblas_zsymm ",
+ "cblas_ztrmm ","cblas_ztrsm ","cblas_zherk ","cblas_zsyrk ",
+ "cblas_zher2k ","cblas_zsyr2k ","cblas_zgemmtr"};
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
doublereal d__1;
- olist o__1;
- cllist cl__1;
/* Local variables */
doublecomplex c__[4225] /* was [65][65] */;
@@ -495,55 +341,9 @@ static logical c_false = FALSE_;
doublereal thresh;
logical rorder;
integer layout;
- logical ltestt, tsterr;
+ logical ltestt, tsterr;
extern /* Subroutine */ int cz3chke_(char *);
- /* Fortran I/O blocks */
- static cilist io___2 = { 0, 5, 0, 0, 0 };
- static cilist io___4 = { 0, 5, 0, 0, 0 };
- static cilist io___7 = { 0, 5, 0, 0, 0 };
- static cilist io___9 = { 0, 5, 0, 0, 0 };
- static cilist io___11 = { 0, 5, 0, 0, 0 };
- static cilist io___13 = { 0, 5, 0, 0, 0 };
- static cilist io___15 = { 0, 5, 0, 0, 0 };
- static cilist io___17 = { 0, 5, 0, 0, 0 };
- static cilist io___19 = { 0, 6, 0, fmt_9997, 0 };
- static cilist io___20 = { 0, 5, 0, 0, 0 };
- static cilist io___23 = { 0, 6, 0, fmt_9996, 0 };
- static cilist io___24 = { 0, 5, 0, 0, 0 };
- static cilist io___26 = { 0, 6, 0, fmt_9997, 0 };
- static cilist io___27 = { 0, 5, 0, 0, 0 };
- static cilist io___29 = { 0, 5, 0, 0, 0 };
- static cilist io___31 = { 0, 6, 0, fmt_9997, 0 };
- static cilist io___32 = { 0, 5, 0, 0, 0 };
- static cilist io___34 = { 0, 6, 0, fmt_9995, 0 };
- static cilist io___35 = { 0, 6, 0, fmt_9994, 0 };
- static cilist io___36 = { 0, 6, 0, fmt_9993, 0 };
- static cilist io___37 = { 0, 6, 0, fmt_9992, 0 };
- static cilist io___38 = { 0, 6, 0, 0, 0 };
- static cilist io___39 = { 0, 6, 0, fmt_9984, 0 };
- static cilist io___40 = { 0, 6, 0, 0, 0 };
- static cilist io___41 = { 0, 6, 0, fmt_9999, 0 };
- static cilist io___42 = { 0, 6, 0, 0, 0 };
- static cilist io___45 = { 0, 6, 0, fmt_10002, 0 };
- static cilist io___46 = { 0, 6, 0, fmt_10001, 0 };
- static cilist io___47 = { 0, 6, 0, fmt_10000, 0 };
- static cilist io___48 = { 0, 6, 0, 0, 0 };
- static cilist io___50 = { 0, 5, 1, fmt_9988, 0 };
- static cilist io___53 = { 0, 6, 0, fmt_9990, 0 };
- static cilist io___55 = { 0, 6, 0, fmt_9998, 0 };
- static cilist io___68 = { 0, 6, 0, fmt_9989, 0 };
- static cilist io___69 = { 0, 6, 0, fmt_9989, 0 };
- static cilist io___70 = { 0, 6, 0, fmt_9989, 0 };
- static cilist io___71 = { 0, 6, 0, fmt_9989, 0 };
- static cilist io___73 = { 0, 6, 0, 0, 0 };
- static cilist io___74 = { 0, 6, 0, fmt_9987, 0 };
- static cilist io___75 = { 0, 6, 0, 0, 0 };
- static cilist io___82 = { 0, 6, 0, fmt_9986, 0 };
- static cilist io___83 = { 0, 6, 0, fmt_9985, 0 };
- static cilist io___84 = { 0, 6, 0, fmt_9991, 0 };
-
-
/* Test program for the COMPLEX*16 Level 3 Blas. */
@@ -594,16 +394,20 @@ static logical c_false = FALSE_;
infoc_1.noutc = 6;
/* Read name and unit number for snapshot output file and open file. */
-
- s_rsle(&io___2);
- do_lio(&c__9, &c__1, snaps, (ftnlen)32);
- e_rsle();
- s_rsle(&io___4);
- do_lio(&c__3, &c__1, (char *)&ntra, (ftnlen)sizeof(integer));
- e_rsle();
+ char tmpchar;
+ char line[80];
+
+ fgets(line,80,stdin);
+ sscanf(line,"'%s'",snaps);
+ fgets(line,80,stdin);
+#ifdef USE64BITINT
+ sscanf(line,"%ld",&ntra);
+#else
+ sscanf(line,"%d",&ntra);
+#endif
trace = ntra >= 0;
if (trace) {
- o__1.oerr = 0;
+/* o__1.oerr = 0;
o__1.ounit = ntra;
o__1.ofnmlen = 32;
o__1.ofnm = snaps;
@@ -612,149 +416,119 @@ static logical c_false = FALSE_;
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = 0;
- f_open(&o__1);
+ f_open(&o__1);*/
}
/* Read the flag that directs rewinding of the snapshot file. */
- s_rsle(&io___7);
- do_lio(&c__8, &c__1, (char *)&rewi, (ftnlen)sizeof(logical));
- e_rsle();
- rewi = rewi && trace;
+ fgets(line,80,stdin);
+ sscanf(line,"%d",&rewi);
+ rewi = rewi && trace;
/* Read the flag that directs stopping on any failure. */
- s_rsle(&io___9);
- do_lio(&c__8, &c__1, (char *)&sfatal, (ftnlen)sizeof(logical));
- e_rsle();
+ 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. */
- s_rsle(&io___11);
- do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
- e_rsle();
+ 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. */
- s_rsle(&io___13);
- do_lio(&c__3, &c__1, (char *)&layout, (ftnlen)sizeof(integer));
- e_rsle();
+ fgets(line,80,stdin);
+ sscanf(line,"%d",&layout);
/* Read the threshold value of the test ratio */
- s_rsle(&io___15);
- do_lio(&c__5, &c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
- e_rsle();
+ fgets(line,80,stdin);
+ sscanf(line,"%lf",&thresh);
/* Read and check the parameter values for the tests. */
/* Values of N */
- s_rsle(&io___17);
- do_lio(&c__3, &c__1, (char *)&nidim, (ftnlen)sizeof(integer));
- e_rsle();
+ fgets(line,80,stdin);
+#ifdef USE64BITINT
+ sscanf(line,"%d",&nidim);
+#else
+ sscanf(line,"%d",&nidim);
+#endif
if (nidim < 1 || nidim > 9) {
- s_wsfe(&io___19);
- do_fio(&c__1, "N", (ftnlen)1);
- do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
- e_wsfe();
- goto L220;
+ fprintf(stderr,"NUMBER OF VALUES OF N IS LESS THAN 1 OR GREATER THAN 9");
+ goto L220;
}
- s_rsle(&io___20);
- i__1 = nidim;
- for (i__ = 1; i__ <= i__1; ++i__) {
- do_lio(&c__3, &c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
- }
- e_rsle();
+ fgets(line,80,stdin);
+#ifdef USE64BITINT
+ sscanf(line,"%ld %ld %ld %ld %ld %ld %ld %ld %ld",&idim[0],&idim[1],&idim[2],
+ &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]);
+#else
+ sscanf(line,"%d %d %d %d %d %d %d %d %d",&idim[0],&idim[1],&idim[2],
+ &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]);
+#endif
i__1 = nidim;
for (i__ = 1; i__ <= i__1; ++i__) {
- if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) {
- s_wsfe(&io___23);
- do_fio(&c__1, (char *)&c__65, (ftnlen)sizeof(integer));
- e_wsfe();
- goto L220;
- }
+ 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 */
- s_rsle(&io___24);
- do_lio(&c__3, &c__1, (char *)&nalf, (ftnlen)sizeof(integer));
- e_rsle();
+ fgets(line,80,stdin);
+#ifdef USE64BITINT
+ sscanf(line,"%ld",&nalf);
+#else
+ sscanf(line,"%d",&nalf);
+#endif
if (nalf < 1 || nalf > 7) {
- s_wsfe(&io___26);
- do_fio(&c__1, "ALPHA", (ftnlen)5);
- do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
- e_wsfe();
- goto L220;
- }
- s_rsle(&io___27);
- i__1 = nalf;
- for (i__ = 1; i__ <= i__1; ++i__) {
- do_lio(&c__7, &c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(
- doublecomplex));
+ fprintf(stderr,"VALUE OF ALPHA IS LESS THAN 0 OR GREATER THAN 7\n");
+ goto L220;
}
- e_rsle();
+ 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 */
- s_rsle(&io___29);
- do_lio(&c__3, &c__1, (char *)&nbet, (ftnlen)sizeof(integer));
- e_rsle();
- if (nbet < 1 || nbet > 7) {
- s_wsfe(&io___31);
- do_fio(&c__1, "BETA", (ftnlen)4);
- do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
- e_wsfe();
- goto L220;
- }
- s_rsle(&io___32);
- i__1 = nbet;
- for (i__ = 1; i__ <= i__1; ++i__) {
- do_lio(&c__7, &c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(
- doublecomplex));
+ fgets(line,80,stdin);
+#ifdef USE64BITINT
+ sscanf(line,"%ld",&nbet);
+#else
+ sscanf(line,"%d",&nbet);
+#endif
+ if (nalf < 1 || nbet > 7) {
+ fprintf(stderr,"VALUE OF BETA IS LESS THAN 0 OR GREATER THAN 7\n");
+ goto L220;
}
- e_rsle();
+ 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. */
- s_wsfe(&io___34);
- e_wsfe();
- s_wsfe(&io___35);
- i__1 = nidim;
- for (i__ = 1; i__ <= i__1; ++i__) {
- do_fio(&c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
- }
- e_wsfe();
- s_wsfe(&io___36);
- i__1 = nalf;
- for (i__ = 1; i__ <= i__1; ++i__) {
- do_fio(&c__2, (char *)&alf[i__ - 1], (ftnlen)sizeof(doublereal));
- }
- e_wsfe();
- s_wsfe(&io___37);
- i__1 = nbet;
- for (i__ = 1; i__ <= i__1; ++i__) {
- do_fio(&c__2, (char *)&bet[i__ - 1], (ftnlen)sizeof(doublereal));
- }
- e_wsfe();
+ 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) {
- s_wsle(&io___38);
- e_wsle();
- s_wsfe(&io___39);
- e_wsfe();
+ printf(" ERROR-EXITS WILL NOT BE TESTED\n");
}
- s_wsle(&io___40);
- e_wsle();
- s_wsfe(&io___41);
- do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
- e_wsfe();
- s_wsle(&io___42);
- e_wsle();
+
+ 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_;
- s_wsfe(&io___45);
- e_wsfe();
+ printf("COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED\n");
} else if (layout == 1) {
rorder = TRUE_;
- s_wsfe(&io___46);
- e_wsfe();
+ printf("ROW-MAJOR DATA LAYOUT IS TESTED\n");
} else if (layout == 0) {
corder = TRUE_;
- s_wsfe(&io___47);
- e_wsfe();
+ printf("COLUMN-MAJOR DATA LAYOUT IS TESTED\n");
}
- s_wsle(&io___48);
- e_wsle();
/* Read names of subroutines and flags which indicate */
/* whether they are to be tested. */
@@ -764,42 +538,33 @@ static logical c_false = FALSE_;
/* L20: */
}
L30:
- i__1 = s_rsfe(&io___50);
- if (i__1 != 0) {
- goto L60;
+ if (! fgets(line,80,stdin)) {
+ goto L60;
}
- i__1 = do_fio(&c__1, snamet, (ftnlen)13);
- if (i__1 != 0) {
- goto L60;
- }
- i__1 = do_fio(&c__1, (char *)<estt, (ftnlen)sizeof(logical));
- if (i__1 != 0) {
- goto L60;
- }
- i__1 = e_rsfe();
- if (i__1 != 0) {
- goto L60;
+ i__1 = sscanf(line,"%13c %c",snamet,&tmpchar);
+ ltestt=FALSE_;
+ if (tmpchar=='T')ltestt=TRUE_;
+ if (i__1 < 2) {
+ goto L60;
}
for (i__ = 1; i__ <= 10; ++i__) {
- if (s_cmp(snamet, snames + (i__ - 1) * 13, (ftnlen)13, (ftnlen)13) ==
- 0) {
- goto L50;
- }
+ if (s_cmp(snamet, snames[i__ - 1] , (ftnlen)13, (ftnlen)13) ==
+ 0) {
+ goto L50;
+ }
/* L40: */
}
- s_wsfe(&io___53);
- do_fio(&c__1, snamet, (ftnlen)13);
- e_wsfe();
- s_stop("", (ftnlen)0);
+ 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.cerr = 0;
cl__1.cunit = 5;
cl__1.csta = 0;
- f_clos(&cl__1);
+ f_clos(&cl__1);*/
/* Compute EPS (the machine precision). */
@@ -813,9 +578,7 @@ static logical c_false = FALSE_;
goto L70;
L80:
eps += eps;
- s_wsfe(&io___55);
- do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
- e_wsfe();
+ printf("RELATIVE MACHINE PRECISION IS TAKEN TO BE %9.1g\n",eps);
/* Check the reliability of ZMMCH using exact data. */
@@ -855,13 +618,12 @@ static logical c_false = FALSE_;
&c__6, &c_true);
same = lze_(cc, ct, &n);
if (! same || err != 0.) {
- s_wsfe(&io___68);
- do_fio(&c__1, transa, (ftnlen)1);
- do_fio(&c__1, transb, (ftnlen)1);
- do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
- do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
- e_wsfe();
- s_stop("", (ftnlen)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], &
@@ -869,13 +631,12 @@ static logical c_false = FALSE_;
&c__6, &c_true);
same = lze_(cc, ct, &n);
if (! same || err != 0.) {
- s_wsfe(&io___69);
- do_fio(&c__1, transa, (ftnlen)1);
- do_fio(&c__1, transb, (ftnlen)1);
- do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
- do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
- e_wsfe();
- s_stop("", (ftnlen)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) {
@@ -901,13 +662,12 @@ static logical c_false = FALSE_;
&c__6, &c_true);
same = lze_(cc, ct, &n);
if (! same || err != 0.) {
- s_wsfe(&io___70);
- do_fio(&c__1, transa, (ftnlen)1);
- do_fio(&c__1, transb, (ftnlen)1);
- do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
- do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
- e_wsfe();
- s_stop("", (ftnlen)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], &
@@ -915,39 +675,32 @@ static logical c_false = FALSE_;
&c__6, &c_true);
same = lze_(cc, ct, &n);
if (! same || err != 0.) {
- s_wsfe(&io___71);
- do_fio(&c__1, transa, (ftnlen)1);
- do_fio(&c__1, transb, (ftnlen)1);
- do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
- do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
- e_wsfe();
- s_stop("", (ftnlen)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 <= 10; ++isnum) {
- s_wsle(&io___73);
- e_wsle();
if (! ltest[isnum - 1]) {
/* Subprogram is not to be tested. */
- s_wsfe(&io___74);
- do_fio(&c__1, snames + (isnum - 1) * 13, (ftnlen)13);
- e_wsfe();
+ printf("%12s WAS NOT TESTED\n",snames[isnum-1]);
} else {
- s_copy(srnamc_1.srnamt, snames + (isnum - 1) * 13, (ftnlen)13, (
- ftnlen)13);
+ s_copy(srnamc_1.srnamt, snames[isnum - 1], (ftnlen)12, (
+ ftnlen)12);
/* Test error exits. */
if (tsterr) {
- cz3chke_(snames + (isnum - 1) * 13);
- s_wsle(&io___75);
- e_wsle();
+ cz3chke_(snames[isnum - 1]);
}
/* Test computations. */
infoc_1.infot = 0;
infoc_1.ok = TRUE_;
fatal = FALSE_;
- switch (isnum) {
+ switch ((int)isnum) {
case 1: goto L140;
case 2: goto L150;
case 3: goto L150;
@@ -962,13 +715,13 @@ static logical c_false = FALSE_;
/* Test ZGEMM, 01. */
L140:
if (corder) {
- zchk1_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
}
if (rorder) {
- zchk1_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
@@ -977,13 +730,13 @@ static logical c_false = FALSE_;
/* Test ZHEMM, 02, ZSYMM, 03. */
L150:
if (corder) {
- zchk2_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
}
if (rorder) {
- zchk2_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
@@ -992,13 +745,13 @@ static logical c_false = FALSE_;
/* Test ZTRMM, 04, ZTRSM, 05. */
L160:
if (corder) {
- zchk3_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
}
if (rorder) {
- zchk3_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
@@ -1007,13 +760,13 @@ static logical c_false = FALSE_;
/* Test ZHERK, 06, ZSYRK, 07. */
L170:
if (corder) {
- zchk4_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
}
if (rorder) {
- zchk4_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
@@ -1022,13 +775,13 @@ static logical c_false = FALSE_;
/* Test ZHER2K, 08, ZSYR2K, 09. */
L180:
if (corder) {
- zchk5_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
}
if (rorder) {
- zchk5_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ 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);
@@ -1037,13 +790,13 @@ static logical c_false = FALSE_;
/* Test ZGEMMTR, 10 */
L185:
if (corder) {
- zchk6_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ zchk6_(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) {
- zchk6_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra,
+ zchk6_(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);
@@ -1057,119 +810,66 @@ static logical c_false = FALSE_;
}
/* L200: */
}
- s_wsfe(&io___82);
- e_wsfe();
+ printf("\nEND OF TESTS\n");
goto L230;
L210:
- s_wsfe(&io___83);
- e_wsfe();
+ printf("\n****** FATAL ERROR - TESTS ABANDONED ******\n");
goto L230;
L220:
- s_wsfe(&io___84);
- e_wsfe();
+ printf("AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM\n");
+ printf("****** TESTS ABANDONED ******\n");
L230:
if (trace) {
- cl__1.cerr = 0;
+/* cl__1.cerr = 0;
cl__1.cunit = ntra;
cl__1.csta = 0;
- f_clos(&cl__1);
+ f_clos(&cl__1);*/
}
- cl__1.cerr = 0;
+/* cl__1.cerr = 0;
cl__1.cunit = 6;
cl__1.csta = 0;
- f_clos(&cl__1);
- s_stop("", (ftnlen)0);
-
+ f_clos(&cl__1);*/
+ exit(0);
/* End of ZBLAT3. */
- return 0;
} /* MAIN__ */
-/* Subroutine */ int zchk1_(char *sname, doublereal *eps, doublereal *thresh,
- integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
- fatal, integer *nidim, integer *idim, integer *nalf, doublecomplex *
- alf, integer *nbet, doublecomplex *bet, integer *nmax, doublecomplex *
- a, doublecomplex *aa, doublecomplex *as, doublecomplex *b,
- doublecomplex *bb, doublecomplex *bs, doublecomplex *c__,
- doublecomplex *cc, doublecomplex *cs, doublecomplex *ct, doublereal *
- g, integer *iorder)
+/* Subroutine */ int zchk1_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublecomplex* alf, integer* nbet, doublecomplex* bet, integer* nmax, doublecomplex* a, doublecomplex* aa, doublecomplex* as, doublecomplex* b, doublecomplex* bb, doublecomplex* bs, doublecomplex* c__, doublecomplex* cc, doublecomplex* cs, doublecomplex* ct, doublereal* g, integer* iorder)
{
/* Initialized data */
- static char ich[3] = "NTC";
-
- /* Format strings */
- static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
- "TAKEN ON VALID CALL *******\002)";
- static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
- " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
- static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
- "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
- " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
- "BER:\002)";
+ 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;
- alist al__1;
/* Local variables */
- integer i__, k, m, n, ia, ib, ma, mb, na, nb, nc, ik, im, in, ks, ms, ns,
- ica, icb, laa, lbb, lda, lcc, ldb, ldc;
- doublecomplex als, bls;
- doublereal err;
- extern logical lze_(doublecomplex *, doublecomplex *, integer *);
- doublecomplex beta;
- integer ldas, ldbs, ldcs;
- logical same, null;
- doublecomplex alpha;
- logical isame[13], trana, tranb;
- extern /* Subroutine */ int zmake_(char *, char *, char *, integer *,
- integer *, doublecomplex *, integer *, doublecomplex *, integer *,
- logical *, doublecomplex *);
- integer nargs;
- extern /* Subroutine */ int zmmch_(char *, char *, integer *, integer *,
- integer *, doublecomplex *, doublecomplex *, integer *,
- doublecomplex *, integer *, doublecomplex *, doublecomplex *,
- integer *, doublecomplex *, doublereal *, doublecomplex *,
- integer *, doublereal *, doublereal *, logical *, integer *,
- logical *);
- logical reset;
- extern /* Subroutine */ int zprcn1_(integer *, integer *, char *, integer
- *, char *, char *, integer *, integer *, integer *, doublecomplex
- *, integer *, integer *, doublecomplex *, integer *), czgemm_(integer *, char *, char *, integer *,
- integer *, integer *, doublecomplex *, doublecomplex *, integer *,
- doublecomplex *, integer *, doublecomplex *, doublecomplex *,
- integer *);
- char tranas[1], tranbs[1], transa[1], transb[1];
- doublereal errmax;
- extern logical lzeres_(char *, char *, integer *, integer *,
- doublecomplex *, doublecomplex *, integer *);
-
- /* Fortran I/O blocks */
- static cilist io___128 = { 0, 0, 0, fmt_9994, 0 };
- static cilist io___131 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___133 = { 0, 0, 0, fmt_10000, 0 };
- static cilist io___134 = { 0, 0, 0, fmt_10001, 0 };
- static cilist io___135 = { 0, 0, 0, fmt_10002, 0 };
- static cilist io___136 = { 0, 0, 0, fmt_10003, 0 };
- static cilist io___137 = { 0, 0, 0, fmt_9996, 0 };
-
-
+ static doublecomplex beta;
+ static integer ldas, ldbs, ldcs;
+ static logical same, null;
+ static integer i__, k, m, n;
+ static doublecomplex alpha;
+ static logical isame[13], trana, tranb;
+ extern /* Subroutine */ int zmake_(char*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, logical*, doublecomplex*);
+ static integer nargs;
+ extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*);
+ static logical reset;
+ static integer ia, ib;
+ extern /* Subroutine */ int zprcn1_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, integer*, doublecomplex*, integer*, integer*, doublecomplex*, integer*);
+ static integer ma, mb, na, nb, nc, ik, im, in, ks, ms, ns;
+ extern /* Subroutine */ void czgemm_(integer*, char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*);
+ static char tranas[1], tranbs[1], transa[1], transb[1];
+ static doublereal errmax;
+ extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*);
+ static integer ica, icb, laa, lbb, lda, lcc, ldb, ldc;
+ static doublecomplex als, bls;
+ static doublereal err;
+ extern logical lze_(doublecomplex*, doublecomplex*, integer*);
/* Tests ZGEMM. */
@@ -1356,9 +1056,9 @@ static logical c_false = FALSE_;
&ldb, &beta, &ldc);
}
if (*rewi) {
- al__1.aerr = 0;
+/* al__1.aerr = 0;
al__1.aunit = *ntra;
- f_rew(&al__1);
+ f_rew(&al__1);*/
}
czgemm_(iorder, transa, transb, &m, &n, &k, &
alpha, &aa[1], &lda, &bb[1], &ldb, &
@@ -1367,9 +1067,7 @@ static logical c_false = FALSE_;
/* 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;
}
@@ -1407,11 +1105,7 @@ static logical c_false = FALSE_;
for (i__ = 1; i__ <= i__6; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
- io___131.ciunit = *nout;
- s_wsfe(&io___131);
- do_fio(&c__1, (char *)&i__, (ftnlen)
- sizeof(integer));
- e_wsfe();
+ printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
}
/* L40: */
}
@@ -1465,44 +1159,25 @@ static logical c_false = FALSE_;
if (errmax < *thresh) {
if (*iorder == 0) {
- io___133.ciunit = *nout;
- s_wsfe(&io___133);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf(" %s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
if (*iorder == 1) {
- io___134.ciunit = *nout;
- s_wsfe(&io___134);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf(" %s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
} else {
if (*iorder == 0) {
- io___135.ciunit = *nout;
- s_wsfe(&io___135);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
- e_wsfe();
+ 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) {
- io___136.ciunit = *nout;
- s_wsfe(&io___136);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
- e_wsfe();
+ 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:
- io___137.ciunit = *nout;
- s_wsfe(&io___137);
- do_fio(&c__1, sname, (ftnlen)13);
- e_wsfe();
+ printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
zprcn1_(nout, &nc, sname, iorder, transa, transb, &m, &n, &k, &alpha, &
lda, &ldb, &beta, &ldc);
@@ -1516,25 +1191,10 @@ static logical c_false = FALSE_;
} /* zchk1_ */
-/* Subroutine */ int zprcn1_(integer *nout, integer *nc, char *sname, integer
- *iorder, char *transa, char *transb, integer *m, integer *n, integer *
- k, doublecomplex *alpha, integer *lda, integer *ldb, doublecomplex *
- beta, integer *ldc)
+/* Subroutine */ int zprcn1_(integer* nout, integer* nc, char* sname, integer* iorder, char* transa, char* transb, integer* m, integer* n, integer* k, doublecomplex* alpha, integer* lda, integer* ldb, doublecomplex* beta, integer* ldc)
{
- /* Format strings */
- static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
- "a14,\002,\002,a14,\002,\002)";
- static char fmt_9994[] = "(10x,3(i3,\002,\002),\002 (\002,f4.1,\002,\002"
- ",f4.1,\002) , A,\002,i3,\002, B,\002,i3,\002, (\002,f4.1,\002"
- ",\002,f4.1,\002) , C,\002,i3,\002).\002)";
-
/* Local variables */
- char crc[14], cta[14], ctb[14];
-
- /* Fortran I/O blocks */
- static cilist io___141 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___142 = { 0, 0, 0, fmt_9994, 0 };
-
+ static char crc[14], cta[14], ctb[14];
if (*(unsigned char *)transa == 'N') {
s_copy(cta, " CblasNoTrans", (ftnlen)14, (ftnlen)14);
@@ -1555,120 +1215,52 @@ static logical c_false = FALSE_;
} else {
s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
}
- io___141.ciunit = *nout;
- s_wsfe(&io___141);
- do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, crc, (ftnlen)14);
- do_fio(&c__1, cta, (ftnlen)14);
- do_fio(&c__1, ctb, (ftnlen)14);
- e_wsfe();
- io___142.ciunit = *nout;
- s_wsfe(&io___142);
- do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
- do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(doublereal));
- do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
- e_wsfe();
- return 0;
+ printf("%6d: %s %s %s %s\n",*nc,sname,crc,cta,ctb);
+ printf("%d %d %d (%4.1lf,%4.1lf) , A, %d, B, %d, (%4.1lf,%4.1lf) , C, %d.\n",*m,*n,*k,alpha->r,alpha->i,*lda,*ldb,beta->r,beta->i,*ldc);
+
+return 0;
} /* zprcn1_ */
-/* Subroutine */ int zchk2_(char *sname, doublereal *eps, doublereal *thresh,
- integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
- fatal, integer *nidim, integer *idim, integer *nalf, doublecomplex *
- alf, integer *nbet, doublecomplex *bet, integer *nmax, doublecomplex *
- a, doublecomplex *aa, doublecomplex *as, doublecomplex *b,
- doublecomplex *bb, doublecomplex *bs, doublecomplex *c__,
- doublecomplex *cc, doublecomplex *cs, doublecomplex *ct, doublereal *
- g, integer *iorder)
+/* Subroutine */ int zchk2_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublecomplex* alf, integer* nbet, doublecomplex* bet, integer* nmax, doublecomplex* a, doublecomplex* aa, doublecomplex* as, doublecomplex* b, doublecomplex* bb, doublecomplex* bs, doublecomplex* c__, doublecomplex* cc, doublecomplex* cs, doublecomplex* ct, doublereal* g, integer* iorder)
{
/* Initialized data */
- static char ichs[2] = "LR";
- static char ichu[2] = "UL";
-
- /* Format strings */
- static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
- "TAKEN ON VALID CALL *******\002)";
- static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
- " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
- static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
- "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
- " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
- "BER:\002)";
+ 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;
- alist al__1;
/* Local variables */
- integer i__, m, n, ia, ib, na, nc, im, in, ms, ns, laa, lbb, lda, lcc,
- ldb, ldc, ics;
- doublecomplex als, bls;
- integer icu;
- doublereal err;
- extern logical lze_(doublecomplex *, doublecomplex *, integer *);
- doublecomplex beta;
- integer ldas, ldbs, ldcs;
- logical same;
- char side[1];
- logical conj, left, null;
- char uplo[1];
- doublecomplex alpha;
- logical isame[13];
- char sides[1];
- extern /* Subroutine */ int zmake_(char *, char *, char *, integer *,
- integer *, doublecomplex *, integer *, doublecomplex *, integer *,
- logical *, doublecomplex *);
- integer nargs;
- extern /* Subroutine */ int zmmch_(char *, char *, integer *, integer *,
- integer *, doublecomplex *, doublecomplex *, integer *,
- doublecomplex *, integer *, doublecomplex *, doublecomplex *,
- integer *, doublecomplex *, doublereal *, doublecomplex *,
- integer *, doublereal *, doublereal *, logical *, integer *,
- logical *);
- logical reset;
- char uplos[1];
- extern /* Subroutine */ int zprcn2_(integer *, integer *, char *, integer
- *, char *, char *, integer *, integer *, doublecomplex *, integer
- *, integer *, doublecomplex *, integer *),
- czhemm_(integer *, char *, char *, integer *, integer *,
- doublecomplex *, doublecomplex *, integer *, doublecomplex *,
- integer *, doublecomplex *, doublecomplex *, integer *);
- doublereal errmax;
- extern logical lzeres_(char *, char *, integer *, integer *,
- doublecomplex *, doublecomplex *, integer *);
- extern /* Subroutine */ int czsymm_(integer *, char *, char *, integer *,
- integer *, doublecomplex *, doublecomplex *, integer *,
- doublecomplex *, integer *, doublecomplex *, doublecomplex *,
- integer *);
-
- /* Fortran I/O blocks */
- static cilist io___181 = { 0, 0, 0, fmt_9994, 0 };
- static cilist io___184 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___186 = { 0, 0, 0, fmt_10000, 0 };
- static cilist io___187 = { 0, 0, 0, fmt_10001, 0 };
- static cilist io___188 = { 0, 0, 0, fmt_10002, 0 };
- static cilist io___189 = { 0, 0, 0, fmt_10003, 0 };
- static cilist io___190 = { 0, 0, 0, fmt_9996, 0 };
-
-
+ static doublecomplex beta;
+ static integer ldas, ldbs, ldcs;
+ static logical same;
+ static char side[1];
+ static logical isconj, left, null;
+ static char uplo[1];
+ static integer i__, m, n;
+ static doublecomplex alpha;
+ static logical isame[13];
+ static char sides[1];
+ extern /* Subroutine */ int zmake_(char*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, logical*, doublecomplex*);
+ static integer nargs;
+ extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*);
+ static logical reset;
+ static char uplos[1];
+ static integer ia, ib;
+ extern /* Subroutine */ int zprcn2_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublecomplex*, integer*, integer*, doublecomplex*, integer*);
+ static integer na, nc, im, in, ms, ns;
+ extern /* Subroutine */ void czhemm_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*);
+ static doublereal errmax;
+ extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*);
+ extern /* Subroutine */ void czsymm_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*);
+ static integer laa, lbb, lda, lcc, ldb, ldc, ics;
+ static doublecomplex als, bls;
+ static integer icu;
+ static doublereal err;
+ extern logical lze_(doublecomplex*, doublecomplex*, integer*);
/* Tests ZHEMM and ZSYMM. */
@@ -1703,7 +1295,8 @@ static logical c_false = FALSE_;
a -= a_offset;
/* Function Body */
- conj = s_cmp(sname + 7, "he", (ftnlen)2, (ftnlen)2) == 0;
+/* .. Executable Statements .. */
+ isconj = s_cmp(sname + 7, "he", (ftnlen)2, (ftnlen)2) == 0;
nargs = 12;
nc = 0;
@@ -1835,11 +1428,11 @@ static logical c_false = FALSE_;
;
}
if (*rewi) {
- al__1.aerr = 0;
+/* al__1.aerr = 0;
al__1.aunit = *ntra;
- f_rew(&al__1);
+ f_rew(&al__1);*/
}
- if (conj) {
+ if (isconj) {
czhemm_(iorder, side, uplo, &m, &n, &alpha, &
aa[1], &lda, &bb[1], &ldb, &beta, &cc[
1], &ldc);
@@ -1852,9 +1445,7 @@ static logical c_false = FALSE_;
/* Check if error-exit was taken incorrectly. */
if (! infoc_1.ok) {
- io___181.ciunit = *nout;
- s_wsfe(&io___181);
- e_wsfe();
+ printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");
*fatal = TRUE_;
goto L110;
}
@@ -1889,11 +1480,7 @@ static logical c_false = FALSE_;
for (i__ = 1; i__ <= i__5; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
- io___184.ciunit = *nout;
- s_wsfe(&io___184);
- do_fio(&c__1, (char *)&i__, (ftnlen)
- sizeof(integer));
- e_wsfe();
+ printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
}
/* L40: */
}
@@ -1951,44 +1538,25 @@ static logical c_false = FALSE_;
if (errmax < *thresh) {
if (*iorder == 0) {
- io___186.ciunit = *nout;
- s_wsfe(&io___186);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf(" %s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
if (*iorder == 1) {
- io___187.ciunit = *nout;
- s_wsfe(&io___187);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf(" %s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
} else {
if (*iorder == 0) {
- io___188.ciunit = *nout;
- s_wsfe(&io___188);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
- e_wsfe();
+ 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) {
- io___189.ciunit = *nout;
- s_wsfe(&io___189);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
- e_wsfe();
+ 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:
- io___190.ciunit = *nout;
- s_wsfe(&io___190);
- do_fio(&c__1, sname, (ftnlen)13);
- e_wsfe();
+ printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
zprcn2_(nout, &nc, sname, iorder, side, uplo, &m, &n, &alpha, &lda, &ldb,
&beta, &ldc);
@@ -2002,25 +1570,10 @@ static logical c_false = FALSE_;
} /* zchk2_ */
-/* Subroutine */ int zprcn2_(integer *nout, integer *nc, char *sname, integer
- *iorder, char *side, char *uplo, integer *m, integer *n,
- doublecomplex *alpha, integer *lda, integer *ldb, doublecomplex *beta,
- integer *ldc)
+/* Subroutine */ int zprcn2_(integer* nout, integer* nc, char* sname, integer* iorder, char* side, char* uplo, integer* m, integer* n, doublecomplex* alpha, integer* lda, integer* ldb, doublecomplex* beta, integer* ldc)
{
- /* Format strings */
- static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
- "a14,\002,\002,a14,\002,\002)";
- static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002"
- ",f4.1,\002), A,\002,i3,\002, B,\002,i3,\002, (\002,f4.1,\002,"
- "\002,f4.1,\002), \002,\002C,\002,i3,\002).\002)";
-
/* Local variables */
- char cs[14], cu[14], crc[14];
-
- /* Fortran I/O blocks */
- static cilist io___194 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___195 = { 0, 0, 0, fmt_9994, 0 };
-
+ static char cs[14], cu[14], crc[14];
if (*(unsigned char *)side == 'L') {
s_copy(cs, " CblasLeft", (ftnlen)14, (ftnlen)14);
@@ -2037,121 +1590,57 @@ static logical c_false = FALSE_;
} else {
s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
}
- io___194.ciunit = *nout;
- s_wsfe(&io___194);
- do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, crc, (ftnlen)14);
- do_fio(&c__1, cs, (ftnlen)14);
- do_fio(&c__1, cu, (ftnlen)14);
- e_wsfe();
- io___195.ciunit = *nout;
- s_wsfe(&io___195);
- do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
- do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(doublereal));
- do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
- e_wsfe();
- return 0;
+ 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_(char *sname, doublereal *eps, doublereal *thresh,
- integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
- fatal, integer *nidim, integer *idim, integer *nalf, doublecomplex *
- alf, integer *nmax, doublecomplex *a, doublecomplex *aa,
- doublecomplex *as, doublecomplex *b, doublecomplex *bb, doublecomplex
- *bs, doublecomplex *ct, doublereal *g, doublecomplex *c__, integer *
- iorder)
+/* Subroutine */ int zchk3_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublecomplex* alf, integer* nmax, doublecomplex* a, doublecomplex* aa, doublecomplex* as, doublecomplex* b, doublecomplex* bb, doublecomplex* bs, doublecomplex* ct, doublereal* g, doublecomplex* c__, integer* iorder)
{
/* Initialized data */
- static char ichu[2] = "UL";
- static char icht[3] = "NTC";
- static char ichd[2] = "UN";
- static char ichs[2] = "LR";
-
- /* Format strings */
- static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
- "TAKEN ON VALID CALL *******\002)";
- static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
- " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
- static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
- "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
- " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
- "BER:\002)";
+ 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;
- alist al__1;
/* Local variables */
- integer i__, j, m, n, ia, na, nc, im, in, ms, ns, laa, icd, lbb, lda, ldb,
- ics;
- doublecomplex als;
- integer ict, icu;
- doublereal err;
- extern logical lze_(doublecomplex *, doublecomplex *, integer *);
- char diag[1];
- integer ldas, ldbs;
- logical same;
- char side[1];
- logical left, null;
- char uplo[1];
- doublecomplex alpha;
- char diags[1];
- logical isame[13];
- char sides[1];
- extern /* Subroutine */ int zmake_(char *, char *, char *, integer *,
- integer *, doublecomplex *, integer *, doublecomplex *, integer *,
- logical *, doublecomplex *);
- integer nargs;
- extern /* Subroutine */ int zmmch_(char *, char *, integer *, integer *,
- integer *, doublecomplex *, doublecomplex *, integer *,
- doublecomplex *, integer *, doublecomplex *, doublecomplex *,
- integer *, doublecomplex *, doublereal *, doublecomplex *,
- integer *, doublereal *, doublereal *, logical *, integer *,
- logical *);
- logical reset;
- char uplos[1];
- extern /* Subroutine */ int zprcn3_(integer *, integer *, char *, integer
- *, char *, char *, char *, char *, integer *, integer *,
- doublecomplex *, integer *, integer *);
- char tranas[1], transa[1];
- doublereal errmax;
- extern logical lzeres_(char *, char *, integer *, integer *,
- doublecomplex *, doublecomplex *, integer *);
- extern /* Subroutine */ int cztrmm_(integer *, char *, char *, char *,
- char *, integer *, integer *, doublecomplex *, doublecomplex *,
- integer *, doublecomplex *, integer *), cztrsm_(integer *, char *, char *, char *, char *,
- integer *, integer *, doublecomplex *, doublecomplex *, integer *,
- doublecomplex *, integer *);
-
- /* Fortran I/O blocks */
- static cilist io___236 = { 0, 0, 0, fmt_9994, 0 };
- static cilist io___239 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___241 = { 0, 0, 0, fmt_10000, 0 };
- static cilist io___242 = { 0, 0, 0, fmt_10001, 0 };
- static cilist io___243 = { 0, 0, 0, fmt_10002, 0 };
- static cilist io___244 = { 0, 0, 0, fmt_10003, 0 };
- static cilist io___245 = { 0, 0, 0, fmt_9996, 0 };
-
-
+ static char diag[1];
+ static integer ldas, ldbs;
+ static logical same;
+ static char side[1];
+ static logical left, null;
+ static char uplo[1];
+ static integer i__, j, m, n;
+ static doublecomplex alpha;
+ static char diags[1];
+ static logical isame[13];
+ static char sides[1];
+ extern /* Subroutine */ int zmake_(char*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, logical*, doublecomplex*);
+ static integer nargs;
+ extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*);
+ static logical reset;
+ static char uplos[1];
+ static integer ia, na;
+ extern /* Subroutine */ int zprcn3_(integer*, integer*, char*, integer*, char*, char*, char*, char*, integer*, integer*, doublecomplex*, integer*, integer*);
+ static integer nc, im, in, ms, ns;
+ static char tranas[1], transa[1];
+ static doublereal errmax;
+ extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*);
+ extern /* Subroutine */ void cztrmm_(integer*, char*, char*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*);
+ extern /* Subroutine */ void cztrsm_(integer*, char*, char*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*);
+ static integer laa, icd, lbb, lda, ldb, ics;
+ static doublecomplex als;
+ static integer ict, icu;
+ static doublereal err;
+ extern logical lze_(doublecomplex*, doublecomplex*, integer*);
/* Tests ZTRMM and ZTRSM. */
@@ -2310,9 +1799,9 @@ static logical c_false = FALSE_;
&n, &alpha, &lda, &ldb);
}
if (*rewi) {
- al__1.aerr = 0;
+/* al__1.aerr = 0;
al__1.aunit = *ntra;
- f_rew(&al__1);
+ f_rew(&al__1);*/
}
cztrmm_(iorder, side, uplo, transa, diag,
&m, &n, &alpha, &aa[1], &lda, &bb[
@@ -2325,9 +1814,9 @@ static logical c_false = FALSE_;
&n, &alpha, &lda, &ldb);
}
if (*rewi) {
- al__1.aerr = 0;
+/* al__1.aerr = 0;
al__1.aunit = *ntra;
- f_rew(&al__1);
+ f_rew(&al__1);*/
}
cztrsm_(iorder, side, uplo, transa, diag,
&m, &n, &alpha, &aa[1], &lda, &bb[
@@ -2337,9 +1826,7 @@ static logical c_false = FALSE_;
/* Check if error-exit was taken incorrectly. */
if (! infoc_1.ok) {
- io___236.ciunit = *nout;
- s_wsfe(&io___236);
- e_wsfe();
+ printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");
*fatal = TRUE_;
goto L150;
}
@@ -2376,11 +1863,7 @@ static logical c_false = FALSE_;
for (i__ = 1; i__ <= i__4; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
- io___239.ciunit = *nout;
- s_wsfe(&io___239);
- do_fio(&c__1, (char *)&i__, (ftnlen)
- sizeof(integer));
- e_wsfe();
+ printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
}
/* L50: */
}
@@ -2402,8 +1885,7 @@ static logical c_false = FALSE_;
c_b1, &c__[c_offset],
nmax, &ct[1], &g[1], &bb[
1], &ldb, eps, &err,
- fatal, nout, &c_true, (
- ftnlen)1, (ftnlen)1);
+ fatal, nout, &c_true);
} else {
zmmch_("N", transa, &m, &n, &n, &
alpha, &b[b_offset], nmax,
@@ -2490,44 +1972,25 @@ static logical c_false = FALSE_;
if (errmax < *thresh) {
if (*iorder == 0) {
- io___241.ciunit = *nout;
- s_wsfe(&io___241);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf(" %s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
if (*iorder == 1) {
- io___242.ciunit = *nout;
- s_wsfe(&io___242);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf(" %s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
} else {
if (*iorder == 0) {
- io___243.ciunit = *nout;
- s_wsfe(&io___243);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
- e_wsfe();
+ 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) {
- io___244.ciunit = *nout;
- s_wsfe(&io___244);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
- e_wsfe();
+ 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:
- io___245.ciunit = *nout;
- s_wsfe(&io___245);
- do_fio(&c__1, sname, (ftnlen)13);
- e_wsfe();
+ printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
if (*trace) {
zprcn3_(ntra, &nc, sname, iorder, side, uplo, transa, diag, &m, &n, &
alpha, &lda, &ldb);
@@ -2543,24 +2006,11 @@ static logical c_false = FALSE_;
} /* zchk3_ */
-/* Subroutine */ int zprcn3_(integer *nout, integer *nc, char *sname, integer
- *iorder, char *side, char *uplo, char *transa, char *diag, integer *m,
- integer *n, doublecomplex *alpha, integer *lda, integer *ldb)
+/* Subroutine */ int zprcn3_(integer* nout, integer* nc, char* sname, integer* iorder, char* side, char* uplo, char* transa, char* diag, integer* m, integer* n, doublecomplex* alpha, integer* lda, integer* ldb)
{
- /* Format strings */
- static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
- "a14,\002,\002,a14,\002,\002)";
- static char fmt_9994[] = "(10x,2(a14,\002,\002),2(i3,\002,\002),\002 "
- "(\002,f4.1,\002,\002,f4.1,\002), A,\002,i3,\002, B,\002,i3,\002)."
- "\002)";
/* Local variables */
- char ca[14], cd[14], cs[14], cu[14], crc[14];
-
- /* Fortran I/O blocks */
- static cilist io___251 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___252 = { 0, 0, 0, fmt_9994, 0 };
-
+ 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);
@@ -2589,130 +2039,61 @@ static logical c_false = FALSE_;
} else {
s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
}
- io___251.ciunit = *nout;
- s_wsfe(&io___251);
- do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, crc, (ftnlen)14);
- do_fio(&c__1, cs, (ftnlen)14);
- do_fio(&c__1, cu, (ftnlen)14);
- e_wsfe();
- io___252.ciunit = *nout;
- s_wsfe(&io___252);
- do_fio(&c__1, ca, (ftnlen)14);
- do_fio(&c__1, cd, (ftnlen)14);
- do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
- do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
- e_wsfe();
- return 0;
+ 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_(char *sname, doublereal *eps, doublereal *thresh,
- integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
- fatal, integer *nidim, integer *idim, integer *nalf, doublecomplex *
- alf, integer *nbet, doublecomplex *bet, integer *nmax, doublecomplex *
- a, doublecomplex *aa, doublecomplex *as, doublecomplex *b,
- doublecomplex *bb, doublecomplex *bs, doublecomplex *c__,
- doublecomplex *cc, doublecomplex *cs, doublecomplex *ct, doublereal *
- g, integer *iorder)
+/* Subroutine */ int zchk4_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublecomplex* alf, integer* nbet, doublecomplex* bet, integer* nmax, doublecomplex* a, doublecomplex* aa, doublecomplex* as, doublecomplex* b, doublecomplex* bb, doublecomplex* bs, doublecomplex* c__, doublecomplex* cc, doublecomplex* cs, doublecomplex* ct, doublereal* g, integer* iorder)
{
/* Initialized data */
- static char icht[2] = "NC";
- static char ichu[2] = "UL";
-
- /* Format strings */
- static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
- "TAKEN ON VALID CALL *******\002)";
- static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
- " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
- static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
- "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
- " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
- " \002,i3)";
- static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
- "BER:\002)";
+ 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;
- alist al__1;
/* Local variables */
- integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa,
- lda, lcc, ldc;
- doublecomplex als;
- integer ict, icu;
- doublereal err;
- extern logical lze_(doublecomplex *, doublecomplex *, integer *);
- doublecomplex beta;
- integer ldas, ldcs;
- logical same, conj;
- doublecomplex bets;
- doublereal rals;
- logical tran, null;
- char uplo[1];
- doublecomplex alpha;
- doublereal rbeta;
- logical isame[13];
- extern /* Subroutine */ int zmake_(char *, char *, char *, integer *,
- integer *, doublecomplex *, integer *, doublecomplex *, integer *,
- logical *, doublecomplex *);
- integer nargs;
- extern /* Subroutine */ int zmmch_(char *, char *, integer *, integer *,
- integer *, doublecomplex *, doublecomplex *, integer *,
- doublecomplex *, integer *, doublecomplex *, doublecomplex *,
- integer *, doublecomplex *, doublereal *, doublecomplex *,
- integer *, doublereal *, doublereal *, logical *, integer *,
- logical *);
- doublereal rbets;
- logical reset;
- char trans[1];
- logical upper;
- char uplos[1];
- extern /* Subroutine */ int zprcn4_(integer *, integer *, char *, integer
- *, char *, char *, integer *, integer *, doublecomplex *, integer
- *, doublecomplex *, integer *), zprcn6_(
- integer *, integer *, char *, integer *, char *, char *, integer *
- , integer *, doublereal *, integer *, doublereal *, integer *);
- doublereal ralpha;
- extern /* Subroutine */ int czherk_(integer *, char *, char *, integer *,
- integer *, doublereal *, doublecomplex *, integer *, doublereal *,
- doublecomplex *, integer *);
- doublereal errmax;
- extern logical lzeres_(char *, char *, integer *, integer *,
- doublecomplex *, doublecomplex *, integer *);
- char transs[1], transt[1];
- extern /* Subroutine */ int czsyrk_(integer *, char *, char *, integer *,
- integer *, doublecomplex *, doublecomplex *, integer *,
- doublecomplex *, doublecomplex *, integer *);
-
- /* Fortran I/O blocks */
- static cilist io___294 = { 0, 0, 0, fmt_9992, 0 };
- static cilist io___297 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___304 = { 0, 0, 0, fmt_10000, 0 };
- static cilist io___305 = { 0, 0, 0, fmt_10001, 0 };
- static cilist io___306 = { 0, 0, 0, fmt_10002, 0 };
- static cilist io___307 = { 0, 0, 0, fmt_10003, 0 };
- static cilist io___308 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___309 = { 0, 0, 0, fmt_9996, 0 };
-
-
+ static doublecomplex beta;
+ static integer ldas, ldcs;
+ static logical same, isconj;
+ static doublecomplex bets;
+ static doublereal rals;
+ static logical tran, null;
+ static char uplo[1];
+ static integer i__, j, k, n;
+ static doublecomplex alpha;
+ static doublereal rbeta;
+ static logical isame[13];
+ extern /* Subroutine */ int zmake_(char*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, logical*, doublecomplex*);
+ static integer nargs;
+ extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*);
+ static doublereal rbets;
+ static logical reset;
+ static char trans[1];
+ static logical upper;
+ static char uplos[1];
+ static integer ia, ib, jc, ma, na;
+ extern /* Subroutine */ int zprcn4_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*);
+ static integer nc;
+ extern /* Subroutine */ int zprcn6_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*);
+ static integer ik, in, jj, lj, ks, ns;
+ static doublereal ralpha;
+ extern /* Subroutine */ int czherk_(integer*, char*, char*, integer*, integer*, doublereal*, doublecomplex*, integer*, doublereal*, doublecomplex*, integer*);
+ static doublereal errmax;
+ extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*);
+ static char transs[1], transt[1];
+ extern /* Subroutine */ int czsyrk_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*);
+ static integer laa, lda, lcc, ldc;
+ static doublecomplex als;
+ static integer ict, icu;
+ static doublereal err;
+ extern logical lze_(doublecomplex*, doublecomplex*, integer*);
/* Tests ZHERK and ZSYRK. */
@@ -2747,12 +2128,15 @@ static logical c_false = FALSE_;
a -= a_offset;
/* Function Body */
- conj = s_cmp(sname + 7, "he", (ftnlen)2, (ftnlen)2) == 0;
+/* .. 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) {
@@ -2775,7 +2159,7 @@ static logical c_false = FALSE_;
for (ict = 1; ict <= 2; ++ict) {
*(unsigned char *)trans = *(unsigned char *)&icht[ict - 1];
tran = *(unsigned char *)trans == 'C';
- if (tran && ! conj) {
+ if (tran && ! isconj) {
*(unsigned char *)trans = 'T';
}
if (tran) {
@@ -2809,7 +2193,7 @@ static logical c_false = FALSE_;
for (ia = 1; ia <= i__3; ++ia) {
i__4 = ia;
alpha.r = alf[i__4].r, alpha.i = alf[i__4].i;
- if (conj) {
+ if (isconj) {
ralpha = alpha.r;
z__1.r = ralpha, z__1.i = 0.;
alpha.r = z__1.r, alpha.i = z__1.i;
@@ -2819,15 +2203,15 @@ static logical c_false = FALSE_;
for (ib = 1; ib <= i__4; ++ib) {
i__5 = ib;
beta.r = bet[i__5].r, beta.i = bet[i__5].i;
- if (conj) {
+ 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 (conj) {
- null = null || (k <= 0 || ralpha == 0.) &&
- rbeta == 1.;
+ if (isconj) {
+ null = null ||( (k <= 0 || ralpha == 0.) &&
+ rbeta == 1.);
}
/* Generate the matrix C. */
@@ -2845,7 +2229,7 @@ static logical c_false = FALSE_;
trans;
ns = n;
ks = k;
- if (conj) {
+ if (isconj) {
rals = ralpha;
} else {
als.r = alpha.r, als.i = alpha.i;
@@ -2859,7 +2243,7 @@ static logical c_false = FALSE_;
/* L10: */
}
ldas = lda;
- if (conj) {
+ if (isconj) {
rbets = rbeta;
} else {
bets.r = beta.r, bets.i = beta.i;
@@ -2876,16 +2260,16 @@ static logical c_false = FALSE_;
/* Call the subroutine. */
- if (conj) {
+ if (isconj) {
if (*trace) {
zprcn6_(ntra, &nc, sname, iorder, uplo,
trans, &n, &k, &ralpha, &lda, &
rbeta, &ldc);
}
if (*rewi) {
- al__1.aerr = 0;
+/* al__1.aerr = 0;
al__1.aunit = *ntra;
- f_rew(&al__1);
+ f_rew(&al__1);*/
}
czherk_(iorder, uplo, trans, &n, &k, &ralpha,
&aa[1], &lda, &rbeta, &cc[1], &ldc);
@@ -2896,9 +2280,9 @@ static logical c_false = FALSE_;
beta, &ldc);
}
if (*rewi) {
- al__1.aerr = 0;
+/* al__1.aerr = 0;
al__1.aunit = *ntra;
- f_rew(&al__1);
+ f_rew(&al__1);*/
}
czsyrk_(iorder, uplo, trans, &n, &k, &alpha, &
aa[1], &lda, &beta, &cc[1], &ldc);
@@ -2907,9 +2291,7 @@ static logical c_false = FALSE_;
/* Check if error-exit was taken incorrectly. */
if (! infoc_1.ok) {
- io___294.ciunit = *nout;
- s_wsfe(&io___294);
- e_wsfe();
+ printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");
*fatal = TRUE_;
goto L120;
}
@@ -2922,7 +2304,7 @@ static logical c_false = FALSE_;
char *)trans;
isame[2] = ns == n;
isame[3] = ks == k;
- if (conj) {
+ if (isconj) {
isame[4] = rals == ralpha;
} else {
isame[4] = als.r == alpha.r && als.i ==
@@ -2930,7 +2312,7 @@ static logical c_false = FALSE_;
}
isame[5] = lze_(&as[1], &aa[1], &laa);
isame[6] = ldas == lda;
- if (conj) {
+ if (isconj) {
isame[7] = rbets == rbeta;
} else {
isame[7] = bets.r == beta.r && bets.i ==
@@ -2952,11 +2334,7 @@ static logical c_false = FALSE_;
for (i__ = 1; i__ <= i__5; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
- io___297.ciunit = *nout;
- s_wsfe(&io___297);
- do_fio(&c__1, (char *)&i__, (ftnlen)
- sizeof(integer));
- e_wsfe();
+ printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
}
/* L30: */
}
@@ -2969,7 +2347,7 @@ static logical c_false = FALSE_;
/* Check the result column by column. */
- if (conj) {
+ if (isconj) {
*(unsigned char *)transt = 'C';
} else {
*(unsigned char *)transt = 'T';
@@ -3040,53 +2418,31 @@ static logical c_false = FALSE_;
if (errmax < *thresh) {
if (*iorder == 0) {
- io___304.ciunit = *nout;
- s_wsfe(&io___304);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf(" %s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
if (*iorder == 1) {
- io___305.ciunit = *nout;
- s_wsfe(&io___305);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf(" %s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
} else {
if (*iorder == 0) {
- io___306.ciunit = *nout;
- s_wsfe(&io___306);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
- e_wsfe();
+ 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) {
- io___307.ciunit = *nout;
- s_wsfe(&io___307);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
- e_wsfe();
+ 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) {
- io___308.ciunit = *nout;
- s_wsfe(&io___308);
- do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j);
}
L120:
- io___309.ciunit = *nout;
- s_wsfe(&io___309);
- do_fio(&c__1, sname, (ftnlen)13);
- e_wsfe();
- if (conj) {
+ printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
+ if (isconj) {
zprcn6_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &ralpha, &lda,
&rbeta, &ldc);
} else {
@@ -3105,24 +2461,10 @@ static logical c_false = FALSE_;
} /* zchk4_ */
-/* Subroutine */ int zprcn4_(integer *nout, integer *nc, char *sname, integer
- *iorder, char *uplo, char *transa, integer *n, integer *k,
- doublecomplex *alpha, integer *lda, doublecomplex *beta, integer *ldc)
+/* Subroutine */ int zprcn4_(integer* nout, integer* nc, char* sname, integer* iorder, char* uplo, char* transa, integer* n, integer* k, doublecomplex* alpha, integer* lda, doublecomplex* beta, integer* ldc)
{
- /* Format strings */
- static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002,"
- "\002))";
- static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002"
- ",f4.1,\002), A,\002,i3,\002, (\002,f4.1,\002,\002,f4.1,\002), C"
- ",\002,i3,\002).\002)";
-
/* Local variables */
- char ca[14], cu[14], crc[14];
-
- /* Fortran I/O blocks */
- static cilist io___313 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___314 = { 0, 0, 0, fmt_9994, 0 };
-
+ static char ca[14], cu[14], crc[14];
if (*(unsigned char *)uplo == 'U') {
s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14);
@@ -3141,45 +2483,19 @@ static logical c_false = FALSE_;
} else {
s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
}
- io___313.ciunit = *nout;
- s_wsfe(&io___313);
- do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, crc, (ftnlen)14);
- do_fio(&c__1, cu, (ftnlen)14);
- do_fio(&c__1, ca, (ftnlen)14);
- e_wsfe();
- io___314.ciunit = *nout;
- s_wsfe(&io___314);
- do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
- do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(doublereal));
- do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
- e_wsfe();
- return 0;
+ printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca);
+ printf("( %d %d (%4.1lf,%4.1lf) A %d (%4.1lf,%4.1lf) C %d\n",*n,*k,alpha->r,alpha->i,*lda,beta->r,beta->i,*ldc);
+
+return 0;
} /* zprcn4_ */
-/* Subroutine */ int zprcn6_(integer *nout, integer *nc, char *sname, integer
- *iorder, char *uplo, char *transa, integer *n, integer *k, doublereal
- *alpha, integer *lda, doublereal *beta, integer *ldc)
+/* Subroutine */ int zprcn6_(integer* nout, integer* nc, char* sname, integer* iorder, char* uplo, char* transa, integer* n, integer* k, doublereal* alpha, integer* lda, doublereal* beta, integer* ldc)
{
- /* Format strings */
- static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002,"
- "\002))";
- static char fmt_9994[] = "(10x,2(i3,\002,\002),f4.1,\002, A,\002,i3"
- ",\002,\002,f4.1,\002, C,\002,i3,\002).\002)";
/* Local variables */
- char ca[14], cu[14], crc[14];
-
- /* Fortran I/O blocks */
- static cilist io___318 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___319 = { 0, 0, 0, fmt_9994, 0 };
-
+ static char ca[14], cu[14], crc[14];
if (*(unsigned char *)uplo == 'U') {
s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14);
@@ -3198,129 +2514,58 @@ static logical c_false = FALSE_;
} else {
s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
}
- io___318.ciunit = *nout;
- s_wsfe(&io___318);
- do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, crc, (ftnlen)14);
- do_fio(&c__1, cu, (ftnlen)14);
- do_fio(&c__1, ca, (ftnlen)14);
- e_wsfe();
- io___319.ciunit = *nout;
- s_wsfe(&io___319);
- do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
- do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(doublereal));
- do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
- e_wsfe();
- return 0;
+ printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca);
+ printf("( %d %d %4.1lf A %d %4.1lf C %d\n",*n,*k,*alpha,*lda,*beta,*ldc);
+
+return 0;
} /* zprcn6_ */
-/* Subroutine */ int zchk5_(char *sname, doublereal *eps, doublereal *thresh,
- integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
- fatal, integer *nidim, integer *idim, integer *nalf, doublecomplex *
- alf, integer *nbet, doublecomplex *bet, integer *nmax, doublecomplex *
- ab, doublecomplex *aa, doublecomplex *as, doublecomplex *bb,
- doublecomplex *bs, doublecomplex *c__, doublecomplex *cc,
- doublecomplex *cs, doublecomplex *ct, doublereal *g, doublecomplex *w,
- integer *iorder)
+/* Subroutine */ int zchk5_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublecomplex* alf, integer* nbet, doublecomplex* bet, integer* nmax, doublecomplex* ab, doublecomplex* aa, doublecomplex* as, doublecomplex* bb, doublecomplex* bs, doublecomplex* c__, doublecomplex* cc, doublecomplex* cs, doublecomplex* ct, doublereal* g, doublecomplex* w, integer* iorder)
{
/* Initialized data */
- static char icht[2] = "NC";
- static char ichu[2] = "UL";
-
- /* Format strings */
- static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
- "TAKEN ON VALID CALL *******\002)";
- static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
- " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
- static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
- "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
- " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
- " \002,i3)";
- static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
- "BER:\002)";
+ 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;
- alist al__1;
/* Local variables */
- integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa,
- lbb, lda, lcc, ldb, ldc;
- doublecomplex als;
- integer ict, icu;
- doublereal err;
- extern logical lze_(doublecomplex *, doublecomplex *, integer *);
- integer jjab;
- doublecomplex beta;
- integer ldas, ldbs, ldcs;
- logical same, conj;
- doublecomplex bets;
- logical tran, null;
- char uplo[1];
- doublecomplex alpha;
- doublereal rbeta;
- logical isame[13];
- extern /* Subroutine */ int zmake_(char *, char *, char *, integer *,
- integer *, doublecomplex *, integer *, doublecomplex *, integer *,
- logical *, doublecomplex *);
- integer nargs;
- extern /* Subroutine */ int zmmch_(char *, char *, integer *, integer *,
- integer *, doublecomplex *, doublecomplex *, integer *,
- doublecomplex *, integer *, doublecomplex *, doublecomplex *,
- integer *, doublecomplex *, doublereal *, doublecomplex *,
- integer *, doublereal *, doublereal *, logical *, integer *,
- logical *);
- doublereal rbets;
- logical reset;
- char trans[1];
- logical upper;
- char uplos[1];
- extern /* Subroutine */ int zprcn5_(integer *, integer *, char *, integer
- *, char *, char *, integer *, integer *, doublecomplex *, integer
- *, integer *, doublecomplex *, integer *),
- zprcn7_(integer *, integer *, char *, integer *, char *, char *,
- integer *, integer *, doublecomplex *, integer *, integer *,
- doublereal *, integer *);
- doublereal errmax;
- extern logical lzeres_(char *, char *, integer *, integer *,
- doublecomplex *, doublecomplex *, integer *);
- char transs[1], transt[1];
- extern /* Subroutine */ int czher2k_(integer *, char *, char *, integer *,
- integer *, doublecomplex *, doublecomplex *, integer *,
- doublecomplex *, integer *, doublereal *, doublecomplex *,
- integer *), czsyr2k_(integer *, char *, char *,
- integer *, integer *, doublecomplex *, doublecomplex *, integer *,
- doublecomplex *, integer *, doublecomplex *, doublecomplex *,
- integer *);
-
- /* Fortran I/O blocks */
- static cilist io___362 = { 0, 0, 0, fmt_9992, 0 };
- static cilist io___365 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___373 = { 0, 0, 0, fmt_10000, 0 };
- static cilist io___374 = { 0, 0, 0, fmt_10001, 0 };
- static cilist io___375 = { 0, 0, 0, fmt_10002, 0 };
- static cilist io___376 = { 0, 0, 0, fmt_10003, 0 };
- static cilist io___377 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___378 = { 0, 0, 0, fmt_9996, 0 };
-
-
+ static integer jjab;
+ static doublecomplex beta;
+ static integer ldas, ldbs, ldcs;
+ static logical same, isconj;
+ static doublecomplex bets;
+ static logical tran, null;
+ static char uplo[1];
+ static integer i__, j, k, n;
+ static doublecomplex alpha;
+ static doublereal rbeta;
+ static logical isame[13];
+ extern /* Subroutine */ int zmake_(char*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, logical*, doublecomplex*);
+ static integer nargs;
+ extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*);
+ static doublereal rbets;
+ static logical reset;
+ static char trans[1];
+ static logical upper;
+ static char uplos[1];
+ static integer ia, ib, jc, ma, na, nc;
+ extern /* Subroutine */ int zprcn5_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublecomplex*, integer*, integer*, doublecomplex*, integer*);
+ extern /* Subroutine */ int zprcn7_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublecomplex*, integer*, integer*, doublereal*, integer*);
+ static integer ik, in, jj, lj, ks, ns;
+ static doublereal errmax;
+ extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*);
+ static char transs[1], transt[1];
+ extern /* Subroutine */ int czher2k_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublereal*, doublecomplex*, integer*);
+ static integer laa, lbb, lda, lcc, ldb, ldc;
+ static doublecomplex als;
+ static integer ict, icu;
+ extern /* Subroutine */ int czsyr2k_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*);
+ static doublereal err;
+ extern logical lze_(doublecomplex*, doublecomplex*, integer*);
/* Tests ZHER2K and ZSYR2K. */
@@ -3351,7 +2596,8 @@ static logical c_false = FALSE_;
--ab;
/* Function Body */
- conj = s_cmp(sname + 7, "he", (ftnlen)2, (ftnlen)2) == 0;
+/* .. Executable Statements .. */
+ isconj = s_cmp(sname + 7, "he", (ftnlen)2, (ftnlen)2) == 0;
nargs = 12;
nc = 0;
@@ -3379,7 +2625,7 @@ static logical c_false = FALSE_;
for (ict = 1; ict <= 2; ++ict) {
*(unsigned char *)trans = *(unsigned char *)&icht[ict - 1];
tran = *(unsigned char *)trans == 'C';
- if (tran && ! conj) {
+ if (tran && ! isconj) {
*(unsigned char *)trans = 'T';
}
if (tran) {
@@ -3437,15 +2683,15 @@ static logical c_false = FALSE_;
for (ib = 1; ib <= i__4; ++ib) {
i__5 = ib;
beta.r = bet[i__5].r, beta.i = bet[i__5].i;
- if (conj) {
+ 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 (conj) {
- null = null || (k <= 0 || alpha.r == 0. &&
- alpha.i == 0.) && rbeta == 1.;
+ if (isconj) {
+ null = null ||( (k <= 0 || (alpha.r == 0. &&
+ alpha.i == 0.)) && rbeta == 1.);
}
/* Generate the matrix C. */
@@ -3482,7 +2728,7 @@ static logical c_false = FALSE_;
/* L20: */
}
ldbs = ldb;
- if (conj) {
+ if (isconj) {
rbets = rbeta;
} else {
bets.r = beta.r, bets.i = beta.i;
@@ -3499,16 +2745,16 @@ static logical c_false = FALSE_;
/* Call the subroutine. */
- if (conj) {
+ if (isconj) {
if (*trace) {
zprcn7_(ntra, &nc, sname, iorder, uplo,
trans, &n, &k, &alpha, &lda, &ldb,
&rbeta, &ldc);
}
if (*rewi) {
- al__1.aerr = 0;
+/* al__1.aerr = 0;
al__1.aunit = *ntra;
- f_rew(&al__1);
+ f_rew(&al__1);*/
}
czher2k_(iorder, uplo, trans, &n, &k, &alpha,
&aa[1], &lda, &bb[1], &ldb, &rbeta, &
@@ -3520,9 +2766,9 @@ static logical c_false = FALSE_;
&beta, &ldc);
}
if (*rewi) {
- al__1.aerr = 0;
+/* al__1.aerr = 0;
al__1.aunit = *ntra;
- f_rew(&al__1);
+ f_rew(&al__1);*/
}
czsyr2k_(iorder, uplo, trans, &n, &k, &alpha,
&aa[1], &lda, &bb[1], &ldb, &beta, &
@@ -3532,9 +2778,7 @@ static logical c_false = FALSE_;
/* Check if error-exit was taken incorrectly. */
if (! infoc_1.ok) {
- io___362.ciunit = *nout;
- s_wsfe(&io___362);
- e_wsfe();
+ printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");
*fatal = TRUE_;
goto L150;
}
@@ -3552,7 +2796,7 @@ static logical c_false = FALSE_;
isame[6] = ldas == lda;
isame[7] = lze_(&bs[1], &bb[1], &lbb);
isame[8] = ldbs == ldb;
- if (conj) {
+ if (isconj) {
isame[9] = rbets == rbeta;
} else {
isame[9] = bets.r == beta.r && bets.i ==
@@ -3574,12 +2818,8 @@ static logical c_false = FALSE_;
for (i__ = 1; i__ <= i__5; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
- io___365.ciunit = *nout;
- s_wsfe(&io___365);
- do_fio(&c__1, (char *)&i__, (ftnlen)
- sizeof(integer));
- e_wsfe();
- }
+ printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
+ }
/* L40: */
}
if (! same) {
@@ -3591,7 +2831,7 @@ static logical c_false = FALSE_;
/* Check the result column by column. */
- if (conj) {
+ if (isconj) {
*(unsigned char *)transt = 'C';
} else {
*(unsigned char *)transt = 'T';
@@ -3611,7 +2851,7 @@ static logical c_false = FALSE_;
i__6 = k;
for (i__ = 1; i__ <= i__6; ++i__) {
i__7 = i__;
- i__8 = (j - 1 << 1) * *nmax + k +
+ i__8 = ((j - 1) << 1) * *nmax + k +
i__;
z__1.r = alpha.r * ab[i__8].r -
alpha.i * ab[i__8].i,
@@ -3620,17 +2860,17 @@ static logical c_false = FALSE_;
i__8].r;
w[i__7].r = z__1.r, w[i__7].i =
z__1.i;
- if (conj) {
+ if (isconj) {
i__7 = k + i__;
d_cnjg(&z__2, &alpha);
- i__8 = (j - 1 << 1) * *nmax + i__;
+ 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__;
+ 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;
@@ -3650,7 +2890,7 @@ static logical c_false = FALSE_;
} else {
i__6 = k;
for (i__ = 1; i__ <= i__6; ++i__) {
- if (conj) {
+ 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,
@@ -3731,53 +2971,31 @@ static logical c_false = FALSE_;
if (errmax < *thresh) {
if (*iorder == 0) {
- io___373.ciunit = *nout;
- s_wsfe(&io___373);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf(" %s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
if (*iorder == 1) {
- io___374.ciunit = *nout;
- s_wsfe(&io___374);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf(" %s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
} else {
if (*iorder == 0) {
- io___375.ciunit = *nout;
- s_wsfe(&io___375);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
- e_wsfe();
+ 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) {
- io___376.ciunit = *nout;
- s_wsfe(&io___376);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
- e_wsfe();
+ 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) {
- io___377.ciunit = *nout;
- s_wsfe(&io___377);
- do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j);
}
L150:
- io___378.ciunit = *nout;
- s_wsfe(&io___378);
- do_fio(&c__1, sname, (ftnlen)13);
- e_wsfe();
- if (conj) {
+ printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
+ if (isconj) {
zprcn7_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &
ldb, &rbeta, &ldc);
} else {
@@ -3796,25 +3014,10 @@ static logical c_false = FALSE_;
} /* zchk5_ */
-/* Subroutine */ int zprcn5_(integer *nout, integer *nc, char *sname, integer
- *iorder, char *uplo, char *transa, integer *n, integer *k,
- doublecomplex *alpha, integer *lda, integer *ldb, doublecomplex *beta,
- integer *ldc)
+/* Subroutine */ int zprcn5_(integer* nout, integer* nc, char* sname, integer* iorder, char* uplo, char* transa, integer* n, integer* k, doublecomplex* alpha, integer* lda, integer* ldb, doublecomplex* beta, integer* ldc)
{
- /* Format strings */
- static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002,"
- "\002))";
- static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002"
- ",f4.1,\002), A,\002,i3,\002, B\002,i3,\002, (\002,f4.1,\002,\002"
- ",f4.1,\002), C,\002,i3,\002).\002)";
-
/* Local variables */
- char ca[14], cu[14], crc[14];
-
- /* Fortran I/O blocks */
- static cilist io___382 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___383 = { 0, 0, 0, fmt_9994, 0 };
-
+ static char ca[14], cu[14], crc[14];
if (*(unsigned char *)uplo == 'U') {
s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14);
@@ -3833,48 +3036,19 @@ static logical c_false = FALSE_;
} else {
s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
}
- io___382.ciunit = *nout;
- s_wsfe(&io___382);
- do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, crc, (ftnlen)14);
- do_fio(&c__1, cu, (ftnlen)14);
- do_fio(&c__1, ca, (ftnlen)14);
- e_wsfe();
- io___383.ciunit = *nout;
- s_wsfe(&io___383);
- do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
- do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(doublereal));
- do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
- e_wsfe();
- return 0;
+ printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca);
+ printf("%d %d (%4.1lf,%4.1lf) , A, %d, B, %d, (%4.1lf,%4.1lf) , C, %d.\n",*n,*k,alpha->r,alpha->i,*lda,*ldb,beta->r,beta->i,*ldc);
+
+return 0;
} /* zprcn5_ */
-/* Subroutine */ int zprcn7_(integer *nout, integer *nc, char *sname, integer
- *iorder, char *uplo, char *transa, integer *n, integer *k,
- doublecomplex *alpha, integer *lda, integer *ldb, doublereal *beta,
- integer *ldc)
+/* Subroutine */ int zprcn7_(integer* nout, integer* nc, char* sname, integer* iorder, char* uplo, char* transa, integer* n, integer* k, doublecomplex* alpha, integer* lda, integer* ldb, doublereal* beta, integer* ldc)
{
- /* Format strings */
- static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002,"
- "\002))";
- static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002"
- ",f4.1,\002), A,\002,i3,\002, B\002,i3,\002,\002,f4.1,\002, C,"
- "\002,i3,\002).\002)";
/* Local variables */
- char ca[14], cu[14], crc[14];
-
- /* Fortran I/O blocks */
- static cilist io___387 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___388 = { 0, 0, 0, fmt_9994, 0 };
-
+ static char ca[14], cu[14], crc[14];
if (*(unsigned char *)uplo == 'U') {
s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14);
@@ -3893,31 +3067,14 @@ static logical c_false = FALSE_;
} else {
s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
}
- io___387.ciunit = *nout;
- s_wsfe(&io___387);
- do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, crc, (ftnlen)14);
- do_fio(&c__1, cu, (ftnlen)14);
- do_fio(&c__1, ca, (ftnlen)14);
- e_wsfe();
- io___388.ciunit = *nout;
- s_wsfe(&io___388);
- do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
- do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(doublereal));
- do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
- e_wsfe();
- return 0;
+ printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca);
+ printf("%d %d (%4.1lf,%4.1lf), A, %d, B, %d, %4.1lf, C, %d.\n",*n,*k,alpha->r,alpha->i,*lda,*ldb,*beta,*ldc);
+
+return 0;
} /* zprcn7_ */
-/* Subroutine */ int zmake_(char *type__, char *uplo, char *diag, integer *m,
- integer *n, doublecomplex *a, integer *nmax, doublecomplex *aa,
- integer *lda, logical *reset, doublecomplex *transl)
+/* Subroutine */ int zmake_(char* type__, char* uplo, char* diag, integer* m, integer* n, doublecomplex* a, integer* nmax, doublecomplex* aa, integer* lda, logical* reset, doublecomplex* transl)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
@@ -3925,11 +3082,13 @@ static logical c_false = FALSE_;
doublecomplex z__1, z__2;
/* Local variables */
- integer i__, j, jj;
- logical gen, her, tri, sym;
- integer ibeg, iend;
- extern /* Double Complex */ VOID zbeg_(doublecomplex *, logical *);
- logical unit, lower, upper;
+ static integer ibeg, iend;
+ extern /* Double Complex */ VOID zbeg_(doublecomplex*, logical*);
+ static logical unit;
+ static integer i__, j;
+ static logical lower, upper;
+ static integer jj;
+ static logical gen, her, tri, sym;
/* Generates values for an M by N matrix A. */
@@ -3967,7 +3126,7 @@ static logical c_false = FALSE_;
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 (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;
@@ -4090,22 +3249,8 @@ static logical c_false = FALSE_;
} /* zmake_ */
-/* Subroutine */ int zmmch_(char *transa, char *transb, integer *m, integer *
- n, integer *kk, doublecomplex *alpha, doublecomplex *a, integer *lda,
- doublecomplex *b, integer *ldb, doublecomplex *beta, doublecomplex *
- c__, integer *ldc, doublecomplex *ct, doublereal *g, doublecomplex *
- cc, integer *ldcc, doublereal *eps, doublereal *err, logical *fatal,
- integer *nout, logical *mv)
+/* Subroutine */ int zmmch_(char* transa, char* transb, integer* m, integer* n, integer* kk, doublecomplex* alpha, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* beta, doublecomplex* c__, integer* ldc, doublecomplex* ct, doublereal* g, doublecomplex* cc, integer* ldcc, doublereal* eps, doublereal* err, logical* fatal, integer* nout, logical* mv)
{
- /* Format strings */
- static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS"
- " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 "
- " EXPECTED RE\002,\002SULT COMPUTED R"
- "ESULT\002)";
- static char fmt_9998[] = "(1x,i7,2(\002 (\002,g15.6,\002,\002,g15.6,"
- "\002)\002))";
- static char fmt_9997[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
- " \002,i3)";
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, cc_dim1,
@@ -4113,18 +3258,11 @@ static logical c_false = FALSE_;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
doublecomplex z__1, z__2, z__3, z__4;
+ double sqrt(double);
/* Local variables */
- integer i__, j, k;
- doublereal erri;
- logical trana, tranb, ctrana, ctranb;
-
- /* Fortran I/O blocks */
- static cilist io___409 = { 0, 0, 0, fmt_9999, 0 };
- static cilist io___410 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___411 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___412 = { 0, 0, 0, fmt_9997, 0 };
-
-
+ static doublereal erri;
+ static integer i__, j, k;
+ static logical trana, tranb, ctrana, ctranb;
/* Checks the results of the computational tests. */
@@ -4138,7 +3276,7 @@ static logical c_false = FALSE_;
/* Parameter adjustments */
a_dim1 = *lda;
- a_offset = 1 + a_dim1;
+ a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
@@ -4462,35 +3600,19 @@ static logical c_false = FALSE_;
L230:
*fatal = TRUE_;
- io___409.ciunit = *nout;
- s_wsfe(&io___409);
- e_wsfe();
+ 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) {
- io___410.ciunit = *nout;
- s_wsfe(&io___410);
- do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&ct[i__], (ftnlen)sizeof(doublereal));
- do_fio(&c__2, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(
- doublereal));
- e_wsfe();
- } else {
- io___411.ciunit = *nout;
- s_wsfe(&io___411);
- do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(
- doublereal));
- do_fio(&c__2, (char *)&ct[i__], (ftnlen)sizeof(doublereal));
- e_wsfe();
+ 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) {
- io___412.ciunit = *nout;
- s_wsfe(&io___412);
- do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf(" THESE ARE THE RESULTS FOR COLUMN %d\n",j);
}
L250:
@@ -4501,14 +3623,14 @@ static logical c_false = FALSE_;
} /* zmmch_ */
-logical lze_(doublecomplex *ri, doublecomplex *rj, integer *lr)
+logical lze_(doublecomplex* ri, doublecomplex* rj, integer* lr)
{
/* System generated locals */
integer i__1, i__2, i__3;
logical ret_val;
/* Local variables */
- integer i__;
+ static integer i__;
/* Tests if two arrays are identical. */
@@ -4546,16 +3668,15 @@ logical lze_(doublecomplex *ri, doublecomplex *rj, integer *lr)
} /* lze_ */
-logical lzeres_(char *type__, char *uplo, integer *m, integer *n,
- doublecomplex *aa, doublecomplex *as, integer *lda)
+logical lzeres_(char* type__, char* uplo, integer* m, integer* n, doublecomplex *aa, doublecomplex* 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 i__, j, ibeg, iend;
- logical upper;
+ static integer ibeg, iend, i__, j;
+ static logical upper;
/* Tests if selected elements in two arrays are equal. */
@@ -4639,7 +3760,7 @@ logical lzeres_(char *type__, char *uplo, integer *m, integer *n,
} /* lzeres_ */
-/* Double Complex */ VOID zbeg_(doublecomplex * ret_val, logical *reset)
+/* Double Complex */ VOID zbeg_(doublecomplex* ret_val, logical* reset)
{
/* System generated locals */
doublereal d__1, d__2;
@@ -4697,7 +3818,7 @@ logical lzeres_(char *type__, char *uplo, integer *m, integer *n,
} /* zbeg_ */
-doublereal ddiff_(doublereal *x, doublereal *y)
+doublereal ddiff_(doublereal* x, doublereal* y)
{
/* System generated locals */
doublereal ret_val;
@@ -4985,9 +4106,10 @@ doublereal ddiff_(doublereal *x, doublereal *y)
lda, &ldb, &beta, &ldc);
}
if (*rewi) {
- al__1.aerr = 0;
+/* al__1.aerr = 0;
al__1.aunit = *ntra;
f_rew(&al__1);
+*/
}
czgemmtr_(iorder, uplo, transa, transb, &n, &
k, &alpha, &aa[1], &lda, &bb[1], &ldb,
@@ -4996,9 +4118,7 @@ doublereal ddiff_(doublereal *x, doublereal *y)
/* Check if error-exit was taken incorrectly. */
if (! infoc_1.ok) {
- io___468.ciunit = *nout;
- s_wsfe(&io___468);
- e_wsfe();
+ printf(" *** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");
*fatal = TRUE_;
goto L120;
}
@@ -5037,11 +4157,7 @@ doublereal ddiff_(doublereal *x, doublereal *y)
for (i__ = 1; i__ <= i__5; ++i__) {
same = same && isame[i__ - 1];
if (! isame[i__ - 1]) {
- io___471.ciunit = *nout;
- s_wsfe(&io___471);
- do_fio(&c__1, (char *)&i__, (ftnlen)
- sizeof(integer));
- e_wsfe();
+ printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);
}
/* L40: */
}
@@ -5097,44 +4213,25 @@ doublereal ddiff_(doublereal *x, doublereal *y)
if (errmax < *thresh) {
if (*iorder == 0) {
- io___473.ciunit = *nout;
- s_wsfe(&io___473);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf(" %s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
if (*iorder == 1) {
- io___474.ciunit = *nout;
- s_wsfe(&io___474);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf(" %s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc);
}
} else {
if (*iorder == 0) {
- io___475.ciunit = *nout;
- s_wsfe(&io___475);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
- e_wsfe();
+ 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) {
- io___476.ciunit = *nout;
- s_wsfe(&io___476);
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
- e_wsfe();
+ 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:
- io___477.ciunit = *nout;
- s_wsfe(&io___477);
- do_fio(&c__1, sname, (ftnlen)13);
- e_wsfe();
+ printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);
zprcn8_(nout, &nc, sname, iorder, uplo, transa, transb, &n, &k, &alpha, &
lda, &ldb, &beta, &ldc);
@@ -5191,25 +4288,8 @@ doublereal ddiff_(doublereal *x, doublereal *y)
} else {
s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
}
- io___482.ciunit = *nout;
- s_wsfe(&io___482);
- do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer));
- do_fio(&c__1, sname, (ftnlen)13);
- do_fio(&c__1, crc, (ftnlen)14);
- do_fio(&c__1, cuplo, (ftnlen)14);
- do_fio(&c__1, cta, (ftnlen)14);
- do_fio(&c__1, ctb, (ftnlen)14);
- e_wsfe();
- io___483.ciunit = *nout;
- s_wsfe(&io___483);
- do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
- do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
- do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(doublereal));
- do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer));
- e_wsfe();
+ printf("%d %s %s %s %s %s\n",*nc,sname,crc,cuplo,cta,ctb);
+ printf("%d %d %f,%f %d %d %f,%f %d\n",*n,*k,alpha->r,alpha->i,*lda,*ldb,beta->r,beta->i,*ldc);
return 0;
} /* zprcn8_ */
@@ -5244,14 +4324,6 @@ doublereal ddiff_(doublereal *x, doublereal *y)
logical ctrana, ctranb;
integer istart;
- /* Fortran I/O blocks */
- static cilist io___495 = { 0, 0, 0, fmt_9999, 0 };
- static cilist io___496 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___497 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___498 = { 0, 0, 0, fmt_9997, 0 };
-
-
-
/* Checks the results of the computational tests for GEMMTR. */
/* Auxiliary routine for test program for Level 3 Blas. */
@@ -5595,35 +4667,19 @@ doublereal ddiff_(doublereal *x, doublereal *y)
L230:
*fatal = TRUE_;
- io___495.ciunit = *nout;
- s_wsfe(&io___495);
- e_wsfe();
+ printf(" ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HALF ACCURATE *******\n");
+ printf(" EXPECTED RESULT COMPUTED RESULT\n");
i__1 = istop;
for (i__ = istart; i__ <= i__1; ++i__) {
if (*mv) {
- io___496.ciunit = *nout;
- s_wsfe(&io___496);
- do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&ct[i__], (ftnlen)sizeof(doublereal));
- do_fio(&c__2, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(
- doublereal));
- e_wsfe();
- } else {
- io___497.ciunit = *nout;
- s_wsfe(&io___497);
- do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
- do_fio(&c__2, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(
- doublereal));
- do_fio(&c__2, (char *)&ct[i__], (ftnlen)sizeof(doublereal));
- e_wsfe();
+ 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) {
- io___498.ciunit = *nout;
- s_wsfe(&io___498);
- do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
- e_wsfe();
+ printf(" THESE ARE THE RESULTS FOR COLUMN %d",j);
}
L250:
@@ -5634,4 +4690,3 @@ doublereal ddiff_(doublereal *x, doublereal *y)
} /* zmmtch_ */
-/* Main program alias */ int zblat3_ () { MAIN__ (); return 0; }
From 1db585c199e58cb5f094493666bbfb7506e2f4c5 Mon Sep 17 00:00:00 2001
From: Martin Kroeker <martin@ruby.chemie.uni-freiburg.de>
Date: Sun, 11 May 2025 23:51:52 -0700
Subject: [PATCH 14/17] Fix missing return
---
ctest/c_dblat3c.c | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/ctest/c_dblat3c.c b/ctest/c_dblat3c.c
index 97da67b3cb..11e4c53fca 100644
--- a/ctest/c_dblat3c.c
+++ b/ctest/c_dblat3c.c
@@ -3857,7 +3857,7 @@ doublereal ddiff_(doublereal* x, doublereal* y)
}
L150:
-
+ return(0);
/* End of DMMTCH */
From d3ebb85d38ce26b8c391b1fb0addc9e419326639 Mon Sep 17 00:00:00 2001
From: Martin Kroeker <martin@ruby.chemie.uni-freiburg.de>
Date: Mon, 12 May 2025 05:26:32 -0700
Subject: [PATCH 15/17] more cleanup
---
ctest/c_cblat3c.c | 42 +---------------------------------
ctest/c_cblat3c_3m.c | 2 +-
ctest/c_dblat3c.c | 36 +++--------------------------
ctest/c_sblat3c.c | 33 ---------------------------
ctest/c_zblat3c.c | 54 --------------------------------------------
ctest/c_zblat3c_3m.c | 2 +-
6 files changed, 6 insertions(+), 163 deletions(-)
diff --git a/ctest/c_cblat3c.c b/ctest/c_cblat3c.c
index f2fe2fce42..4f1a208a9e 100644
--- a/ctest/c_cblat3c.c
+++ b/ctest/c_cblat3c.c
@@ -1087,9 +1087,6 @@ int /* Main program */ main(void)
/* 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;
@@ -3973,26 +3970,6 @@ real sdiff_(real *x, real *y)
static char ich[3] = "NTC";
static char ishape[2] = "UL";
- /* Format strings */
-// static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
-// "TAKEN ON VALID CALL *******\002)";
-// static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
-// " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
-// static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
-// "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
-// static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
-// "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
-// static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
-// "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
-// "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
-// "ECT *******\002)";
-// static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
-// " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
-// "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
-// "ECT *******\002)";
-// static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
-// "BER:\002)";
-
/* 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;
@@ -4349,13 +4326,6 @@ real sdiff_(real *x, real *y)
k, complex *alpha, integer *lda, integer *ldb, complex *beta, integer
*ldc)
{
- /* Format strings */
- static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
- "a14,\002,\002,a14,\002,\002,a14,\002,\002)";
- static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002"
- ",f4.1,\002) , A,\002,i3,\002, B,\002,i3,\002, (\002,f4.1,\002"
- ",\002,f4.1,\002) , C,\002,i3,\002).\002)";
-
/* Local variables */
char crc[14], cta[14], ctb[14], cuplo[14];
@@ -4384,7 +4354,7 @@ real sdiff_(real *x, real *y)
s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);
}
printf("%6d: %s %s %s %s %s\n",*nc,sname,crc,cuplo,cta,ctb);
- printf("%d %d (%4.1f,%4.1f) A, %d, B, %d, (%4.1f,%4.1f), C, %d.\n",*n,*k,*alpha,*lda,*ldb,*beta,*ldc);
+ 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;
} /* cprcn8_ */
@@ -4394,16 +4364,6 @@ real sdiff_(real *x, real *y)
real *g, complex *cc, integer *ldcc, real *eps, real *err, logical *
fatal, integer *nout, logical *mv)
{
- /* Format strings */
- static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS"
- " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 "
- " EXPECTED RE\002,\002SULT COMPUTED R"
- "ESULT\002)";
- static char fmt_9998[] = "(1x,i7,2(\002 (\002,g15.6,\002,\002,g15.6,"
- "\002)\002))";
- static char fmt_9997[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
- " \002,i3)";
-
/* 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;
diff --git a/ctest/c_cblat3c_3m.c b/ctest/c_cblat3c_3m.c
index b5d6bf9cbb..50bee77e38 100644
--- a/ctest/c_cblat3c_3m.c
+++ b/ctest/c_cblat3c_3m.c
@@ -275,7 +275,7 @@ int /* Main program */ main(void)
{
/* Initialized data */
- static char snames[9][13] = {"cblas_cgemm3m ", "cblas_chemm ", "cblas_csymm ",
+ static char snames[9][13] = {"cblas_cgemm3m", "cblas_chemm ", "cblas_csymm ",
"cblas_ctrmm ", "cblas_ctrsm ", "cblas_cherk ", "cblas_csyrk ",
"cblas_cher2k", "cblas_csyr2k"};
diff --git a/ctest/c_dblat3c.c b/ctest/c_dblat3c.c
index 11e4c53fca..b90ec12fa3 100644
--- a/ctest/c_dblat3c.c
+++ b/ctest/c_dblat3c.c
@@ -3280,30 +3280,9 @@ doublereal ddiff_(doublereal* x, doublereal* y)
static char ich[3] = "NTC";
static char ishape[2] = "UL";
- /* Format strings */
- static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
- "TAKEN ON VALID CALL *******\002)";
- static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
- " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
- static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
- "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
- " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
- "BER:\002)";
-
/* 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;
- alist al__1;
/* Local variables */
extern /* Subroutine */ int cdgemmtr_(integer *, char *, char *, char *,
@@ -3326,7 +3305,8 @@ doublereal ddiff_(doublereal* x, doublereal* y)
char uplos[1];
extern /* Subroutine */ void dprcn8_(integer *, integer *, char *, integer
*, char *, char *, char *, integer *, integer *, doublereal *,
- integer *, integer *, doublereal *, integer *), dmmtch_(char *, char *, char *, integer *,
+ integer *, integer *, doublereal *, integer *);
+ extern int dmmtch_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
@@ -3643,19 +3623,9 @@ doublereal ddiff_(doublereal* x, doublereal* y)
k, doublereal *alpha, integer *lda, integer *ldb, doublereal *beta,
integer *ldc)
{
- /* Format strings */
- static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
- "a14,\002,\002,a14,\002,\002,a14,\002,\002)";
- static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 \002,f4.1,\002 , A"
- ",\002,i3,\002, B,\002,i3,\002, \002,f4.1,\002 , C,\002,i3,\002)"
- ".\002)";
-
/* Local variables */
char crc[14], cta[14], ctb[14], cuplo[14];
- /* Fortran I/O blocks */
- static cilist io___455 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___456 = { 0, 0, 0, fmt_9994, 0 };
if (*(unsigned char *)uplo == 'U') {
@@ -3686,7 +3656,7 @@ doublereal ddiff_(doublereal* x, doublereal* y)
printf("%d %d %4.1f A, %d, B, %d, %4.1f, C, %d.\n",*n,*k,*alpha,*lda,*ldb,*beta,*ldc);
} /* dprcn8_ */
-/* Subroutine */ void dmmtch_(char *uplo, char *transa, char *transb, integer *
+/* Subroutine */ int dmmtch_(char *uplo, char *transa, char *transb, integer *
n, integer *kk, doublereal *alpha, doublereal *a, integer *lda,
doublereal *b, integer *ldb, doublereal *beta, doublereal *c__,
integer *ldc, doublereal *ct, doublereal *g, doublereal *cc, integer *
diff --git a/ctest/c_sblat3c.c b/ctest/c_sblat3c.c
index 99fc4645b4..3973d5f52f 100644
--- a/ctest/c_sblat3c.c
+++ b/ctest/c_sblat3c.c
@@ -3252,30 +3252,9 @@ real sdiff_(real *x, real *y)
static char ich[3] = "NTC";
static char ishape[2] = "UL";
- /* Format strings */
- static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
- "TAKEN ON VALID CALL *******\002)";
- static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
- " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
- static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
- "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
- " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
- "BER:\002)";
-
/* 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;
- alist al__1;
/* Local variables */
extern /* Subroutine */ int csgemmtr_(integer *, char *, char *, char *,
@@ -3618,13 +3597,6 @@ real sdiff_(real *x, real *y)
*iorder, char *uplo, char *transa, char *transb, integer *n, integer *
k, real *alpha, integer *lda, integer *ldb, real *beta, integer *ldc)
{
- /* Format strings */
- static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
- "a14,\002,\002,a14,\002,\002,a14,\002,\002)";
- static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 \002,f4.1,\002 , A"
- ",\002,i3,\002, B,\002,i3,\002, \002,f4.1,\002 , C,\002,i3,\002)"
- ".\002)";
-
/* Local variables */
char crc[14], cta[14], ctb[14], cuplo[14];
@@ -3662,11 +3634,6 @@ real sdiff_(real *x, real *y)
integer *ldcc, real *eps, real *err, logical *fatal, integer *nout,
logical *mv)
{
- /* Format strings */
- static char fmt_9998[] = "(1x,i7,2g18.6)";
- static char fmt_9997[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
- " \002,i3)";
-
/* 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;
diff --git a/ctest/c_zblat3c.c b/ctest/c_zblat3c.c
index d46030b722..87cf127c5f 100644
--- a/ctest/c_zblat3c.c
+++ b/ctest/c_zblat3c.c
@@ -3853,30 +3853,9 @@ doublereal ddiff_(doublereal* x, doublereal* y)
static char ich[3] = "NTC";
static char ishape[2] = "UL";
- /* Format strings */
- static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT "
- "TAKEN ON VALID CALL *******\002)";
- static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
- " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
- static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C"
- "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)";
- static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO"
- "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR "
- " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **"
- "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP"
- "ECT *******\002)";
- static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM"
- "BER:\002)";
-
/* 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;
- alist al__1;
/* Local variables */
extern /* Subroutine */ int czgemmtr_(integer *, char *, char *, char *,
@@ -3914,17 +3893,6 @@ doublereal ddiff_(doublereal* x, doublereal* y)
extern logical lzeres_(char *, char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *);
- /* Fortran I/O blocks */
- static cilist io___468 = { 0, 0, 0, fmt_9994, 0 };
- static cilist io___471 = { 0, 0, 0, fmt_9998, 0 };
- static cilist io___473 = { 0, 0, 0, fmt_10000, 0 };
- static cilist io___474 = { 0, 0, 0, fmt_10001, 0 };
- static cilist io___475 = { 0, 0, 0, fmt_10002, 0 };
- static cilist io___476 = { 0, 0, 0, fmt_10003, 0 };
- static cilist io___477 = { 0, 0, 0, fmt_9996, 0 };
-
-
-
/* Tests CGEMMTR. */
/* Auxiliary routine for test program for Level 3 Blas. */
@@ -4249,21 +4217,9 @@ doublereal ddiff_(doublereal* x, doublereal* y)
k, doublecomplex *alpha, integer *lda, integer *ldb, doublecomplex *
beta, integer *ldc)
{
- /* Format strings */
- static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002,"
- "a14,\002,\002,a14,\002,\002,a14,\002,\002)";
- static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002"
- ",f4.1,\002) , A,\002,i3,\002, B,\002,i3,\002, (\002,f4.1,\002"
- ",\002,f4.1,\002) , C,\002,i3,\002).\002)";
-
/* Local variables */
char crc[14], cta[14], ctb[14], cuplo[14];
- /* Fortran I/O blocks */
- static cilist io___482 = { 0, 0, 0, fmt_9995, 0 };
- static cilist io___483 = { 0, 0, 0, fmt_9994, 0 };
-
-
if (*(unsigned char *)uplo == 'U') {
s_copy(cuplo, "CblasUpper", (ftnlen)14, (ftnlen)10);
} else {
@@ -4300,16 +4256,6 @@ doublereal ddiff_(doublereal* x, doublereal* y)
cc, integer *ldcc, doublereal *eps, doublereal *err, logical *fatal,
integer *nout, logical *mv)
{
- /* Format strings */
- static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS"
- " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 "
- " EXPECTED RE\002,\002SULT COMPUTED R"
- "ESULT\002)";
- static char fmt_9998[] = "(1x,i7,2(\002 (\002,g15.6,\002,\002,g15.6,"
- "\002)\002))";
- static char fmt_9997[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
- " \002,i3)";
-
/* 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;
diff --git a/ctest/c_zblat3c_3m.c b/ctest/c_zblat3c_3m.c
index 0c76f11e76..1a7f512203 100644
--- a/ctest/c_zblat3c_3m.c
+++ b/ctest/c_zblat3c_3m.c
@@ -272,7 +272,7 @@ static logical c_false = FALSE_;
{
/* Initialized data */
- static char snames[9][13] = { "cblas_zgemm3m ", "cblas_zhemm ", "cblas_zsymm ", "cblas_ztrmm ",
+ static char snames[9][13] = { "cblas_zgemm3m", "cblas_zhemm ", "cblas_zsymm ", "cblas_ztrmm ",
"cblas_ztrsm ", "cblas_zherk ", "cblas_zsyrk ", "cblas_zher2k", "cblas_zsyr2k"};
/* System generated locals */
From 4341911ff616141fa94893359358844715324288 Mon Sep 17 00:00:00 2001
From: Martin Kroeker <martin@ruby.chemie.uni-freiburg.de>
Date: Mon, 12 May 2025 13:09:57 -0700
Subject: [PATCH 16/17] Fix CBLAS_?GEMMTR name generation
---
interface/Makefile | 10 +++++-----
1 file changed, 5 insertions(+), 5 deletions(-)
diff --git a/interface/Makefile b/interface/Makefile
index f09a6f46b9..01c9cc9b13 100644
--- a/interface/Makefile
+++ b/interface/Makefile
@@ -1981,13 +1981,13 @@ cblas_sgemmt.$(SUFFIX) cblas_sgemmt.$(PSUFFIX) : gemmt.c ../param.h
$(CC) -DCBLAS -c $(CFLAGS) $< -o $(@F)
cblas_sgemmtr.$(SUFFIX) cblas_sgemmtr.$(PSUFFIX) : gemmt.c ../param.h
- $(CC) -DCBLAS -c $(CFLAGS) $< -o $(@F)
+ $(CC) -DCBLAS -DRNAME -c $(CFLAGS) $< -o $(@F)
ifeq ($(BUILD_BFLOAT16),1)
cblas_sbgemmt.$(SUFFIX) cblas_sbgemmt.$(PSUFFIX) : sbgemmt.c ../param.h
$(CC) -DCBLAS -c $(CFLAGS) $< -o $(@F)
cblas_sbgemmtr.$(SUFFIX) cblas_sbgemmtr.$(PSUFFIX) : sbgemmt.c ../param.h
- $(CC) -DCBLAS -c $(CFLAGS) $< -o $(@F)
+ $(CC) -DCBLAS -DRNAME -c $(CFLAGS) $< -o $(@F)
endif
cblas_dgemmt.$(SUFFIX) cblas_dgemmt.$(PSUFFIX) : gemmt.c ../param.h
@@ -2000,13 +2000,13 @@ cblas_zgemmt.$(SUFFIX) cblas_zgemmt.$(PSUFFIX) : gemmt.c ../param.h
$(CC) -DCBLAS -c $(CFLAGS) $< -o $(@F)
cblas_dgemmtr.$(SUFFIX) cblas_dgemmtr.$(PSUFFIX) : gemmt.c ../param.h
- $(CC) -DCBLAS -c $(CFLAGS) $< -o $(@F)
+ $(CC) -DCBLAS -DRNAME -c $(CFLAGS) $< -o $(@F)
cblas_cgemmtr.$(SUFFIX) cblas_cgemmtr.$(PSUFFIX) : gemmt.c ../param.h
- $(CC) -DCBLAS -c $(CFLAGS) $< -o $(@F)
+ $(CC) -DCBLAS -DRNAME -c $(CFLAGS) $< -o $(@F)
cblas_zgemmtr.$(SUFFIX) cblas_zgemmtr.$(PSUFFIX) : gemmt.c ../param.h
- $(CC) -DCBLAS -c $(CFLAGS) $< -o $(@F)
+ $(CC) -DCBLAS -DRNAME -c $(CFLAGS) $< -o $(@F)
cblas_ssymm.$(SUFFIX) cblas_ssymm.$(PSUFFIX) : symm.c
$(CC) -DCBLAS -c $(CFLAGS) $< -o $(@F)
From e1a6703cf765a1d71aeb284225a2c26f723cc3eb Mon Sep 17 00:00:00 2001
From: Martin Kroeker <martin@ruby.chemie.uni-freiburg.de>
Date: Mon, 12 May 2025 13:21:40 -0700
Subject: [PATCH 17/17] Cleanup and GEMMTR fixes
---
ctest/c_c3chke.c | 231 +++++++++++++++++++++++++++++++++++++++++-
ctest/c_cblat3c.c | 16 +--
ctest/c_cblat3c_3m.c | 14 +--
ctest/c_d3chke.c | 232 ++++++++++++++++++++++++++++++++++++++++++-
ctest/c_dblat3c.c | 2 +-
ctest/c_s3chke.c | 232 ++++++++++++++++++++++++++++++++++++++++++-
ctest/c_sblat3c.c | 6 +-
ctest/c_xerbla.c | 13 ++-
ctest/c_z3chke.c | 228 +++++++++++++++++++++++++++++++++++++++++-
9 files changed, 947 insertions(+), 27 deletions(-)
diff --git a/ctest/c_c3chke.c b/ctest/c_c3chke.c
index 3b4764c4a7..e202be4a9e 100644
--- a/ctest/c_c3chke.c
+++ b/ctest/c_c3chke.c
@@ -45,8 +45,237 @@ void F77_c3chke(char * rout) {
F77_xerbla(cblas_rout,&cblas_info);
}
+ if (strncmp( sf,"cblas_cgemmtr" ,13)==0) {
+ cblas_rout = "cblas_cgemmtr" ;
- if (strncmp( sf,"cblas_cgemm" ,11)==0) {
+ cblas_info = 1;
+ cblas_cgemmtr( INVALID, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 1;
+ cblas_cgemmtr( INVALID, CblasUpper, CblasNoTrans, CblasTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 1;
+ cblas_cgemmtr( INVALID, CblasUpper,CblasTrans, CblasNoTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 1;
+ cblas_cgemmtr( INVALID, CblasUpper, CblasTrans, CblasTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 1;
+ cblas_cgemmtr( INVALID, CblasLower, CblasNoTrans, CblasNoTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 1;
+ cblas_cgemmtr( INVALID, CblasLower, CblasNoTrans, CblasTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 1;
+ cblas_cgemmtr( INVALID, CblasLower,CblasTrans, CblasNoTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 1;
+ cblas_cgemmtr( INVALID, CblasLower, CblasTrans, CblasTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 2; RowMajorStrg = FALSE;
+ cblas_cgemmtr( CblasColMajor, INVALID, CblasNoTrans, CblasNoTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 2; RowMajorStrg = FALSE;
+ cblas_cgemmtr( CblasColMajor, INVALID, CblasNoTrans, CblasTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 3; RowMajorStrg = FALSE;
+ cblas_cgemmtr( CblasColMajor, CblasUpper, INVALID, CblasNoTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 3; RowMajorStrg = FALSE;
+ cblas_cgemmtr( CblasColMajor, CblasUpper, INVALID, CblasTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 4; RowMajorStrg = FALSE;
+ cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 4; RowMajorStrg = FALSE;
+ cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, INVALID, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+
+ cblas_info = 5; RowMajorStrg = FALSE;
+ cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 5; RowMajorStrg = FALSE;
+ cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 5; RowMajorStrg = FALSE;
+ cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 5; RowMajorStrg = FALSE;
+ cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 6; RowMajorStrg = FALSE;
+ cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 6; RowMajorStrg = FALSE;
+ cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 6; RowMajorStrg = FALSE;
+ cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 6; RowMajorStrg = FALSE;
+ cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+
+ cblas_info = 9; RowMajorStrg = FALSE;
+ cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 2 );
+ chkxer();
+ cblas_info = 9; RowMajorStrg = FALSE;
+ cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 2 );
+ chkxer();
+ cblas_info = 9; RowMajorStrg = FALSE;
+ cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2,
+ ALPHA, A, 1, B, 2, BETA, C, 1 );
+ chkxer();
+ cblas_info = 9; RowMajorStrg = FALSE;
+ cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 0, 2,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 11; RowMajorStrg = FALSE;
+ cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 11; RowMajorStrg = FALSE;
+ cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2,
+ ALPHA, A, 2, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 11; RowMajorStrg = FALSE;
+ cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 14; RowMajorStrg = FALSE;
+ cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0,
+ ALPHA, A, 2, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 14; RowMajorStrg = FALSE;
+ cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0,
+ ALPHA, A, 2, B, 2, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 14; RowMajorStrg = FALSE;
+ cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0,
+ ALPHA, A, 2, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 14; RowMajorStrg = FALSE;
+ cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0,
+ ALPHA, A, 2, B, 2, BETA, C, 1 );
+ chkxer();
+
+ /* Row Major */
+ cblas_info = 5; RowMajorStrg = TRUE;
+ cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 5; RowMajorStrg = TRUE;
+ cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 5; RowMajorStrg = TRUE;
+ cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 5; RowMajorStrg = TRUE;
+ cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 6; RowMajorStrg = TRUE;
+ cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 6; RowMajorStrg = TRUE;
+ cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 6; RowMajorStrg = TRUE;
+ cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 6; RowMajorStrg = TRUE;
+ cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 9; RowMajorStrg = TRUE;
+ cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2,
+ ALPHA, A, 1, B, 1, BETA, C, 2 );
+ chkxer();
+ cblas_info = 9; RowMajorStrg = TRUE;
+ cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, 2,
+ ALPHA, A, 1, B, 2, BETA, C, 2 );
+ chkxer();
+ cblas_info = 9; RowMajorStrg = TRUE;
+ cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0,
+ ALPHA, A, 1, B, 2, BETA, C, 1 );
+ chkxer();
+ cblas_info = 9; RowMajorStrg = TRUE;
+ cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 11; RowMajorStrg = TRUE;
+ cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 11; RowMajorStrg = TRUE;
+ cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2,
+ ALPHA, A, 2, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 11; RowMajorStrg = TRUE;
+ cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 14; RowMajorStrg = TRUE;
+ cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0,
+ ALPHA, A, 2, B, 2, BETA, C, 1 );
+ chkxer();
+ cblas_info = 14; RowMajorStrg = TRUE;
+ cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0,
+ ALPHA, A, 2, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 14; RowMajorStrg = TRUE;
+ cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0,
+ ALPHA, A, 2, B, 2, BETA, C, 1 );
+ chkxer();
+ cblas_info = 14; RowMajorStrg = TRUE;
+ cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0,
+ ALPHA, A, 2, B, 2, BETA, C, 1 );
+ chkxer();
+
+ } else if (strncmp( sf,"cblas_cgemm" ,11)==0) {
cblas_rout = "cblas_cgemm" ;
diff --git a/ctest/c_cblat3c.c b/ctest/c_cblat3c.c
index 4f1a208a9e..b25621bc63 100644
--- a/ctest/c_cblat3c.c
+++ b/ctest/c_cblat3c.c
@@ -2330,7 +2330,7 @@ int /* Main program */ main(void)
if (conj) {
rbets = rbeta;
} else {
- bets.r = beta.r, bets.i = beta.i;
+ bets.r = beta.r; bets.i = beta.i;
}
i__5 = lcc;
for (i__ = 1; i__ <= i__5; ++i__) {
@@ -2389,18 +2389,18 @@ int /* Main program */ main(void)
isame[2] = ns == n;
isame[3] = ks == k;
if (conj) {
- isame[4] = rals == ralpha;
+ isame[4] = (rals == ralpha);
} else {
- isame[4] = als.r == alpha.r && als.i ==
- alpha.i;
+ 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;
+ isame[7] = ((bets.r == beta.r) && (bets.i ==
+ beta.i));
}
if (null) {
isame[8] = lce_(&cs[1], &cc[1], &lcc);
@@ -2408,7 +2408,7 @@ int /* Main program */ main(void)
isame[8] = lceres_(sname + 7, uplo, &n, &n, &
cs[1], &cc[1], &ldc);
}
- isame[9] = ldcs == ldc;
+ isame[9] = (ldcs == ldc);
/* If data was incorrectly changed, report and */
/* return. */
@@ -2837,7 +2837,7 @@ int /* Main program */ main(void)
if (conj) {
rbets = rbeta;
} else {
- bets.r = beta.r, bets.i = beta.i;
+ bets.r = beta.r; bets.i = beta.i;
}
i__5 = lcc;
for (i__ = 1; i__ <= i__5; ++i__) {
diff --git a/ctest/c_cblat3c_3m.c b/ctest/c_cblat3c_3m.c
index 50bee77e38..e4c3b12e11 100644
--- a/ctest/c_cblat3c_3m.c
+++ b/ctest/c_cblat3c_3m.c
@@ -2261,7 +2261,7 @@ int /* Main program */ main(void)
if (conj) {
ralpha = alpha.r;
q__1.r = ralpha, q__1.i = 0.f;
- alpha.r = q__1.r, alpha.i = q__1.i;
+ alpha.r = q__1.r; alpha.i = q__1.i;
}
i__4 = *nbet;
@@ -2297,7 +2297,7 @@ int /* Main program */ main(void)
if (conj) {
rals = ralpha;
} else {
- als.r = alpha.r, als.i = alpha.i;
+ als.r = alpha.r; als.i = alpha.i;
}
i__5 = laa;
for (i__ = 1; i__ <= i__5; ++i__) {
@@ -2311,7 +2311,7 @@ int /* Main program */ main(void)
if (conj) {
rbets = rbeta;
} else {
- bets.r = beta.r, bets.i = beta.i;
+ bets.r = beta.r; bets.i = beta.i;
}
i__5 = lcc;
for (i__ = 1; i__ <= i__5; ++i__) {
@@ -2378,10 +2378,10 @@ int /* Main program */ main(void)
isame[5] = lce_(&as[1], &aa[1], &laa);
isame[6] = ldas == lda;
if (conj) {
- isame[7] = rbets == rbeta;
+ isame[7] = (rbets == rbeta);
} else {
- isame[7] = bets.r == beta.r && bets.i ==
- beta.i;
+ isame[7] = ((bets.r == beta.r) && (bets.i ==
+ beta.i));
}
if (null) {
isame[8] = lce_(&cs[1], &cc[1], &lcc);
@@ -2818,7 +2818,7 @@ int /* Main program */ main(void)
if (conj) {
rbets = rbeta;
} else {
- bets.r = beta.r, bets.i = beta.i;
+ bets.r = beta.r; bets.i = beta.i;
}
i__5 = lcc;
for (i__ = 1; i__ <= i__5; ++i__) {
diff --git a/ctest/c_d3chke.c b/ctest/c_d3chke.c
index 700cff28f6..43d0de75d7 100644
--- a/ctest/c_d3chke.c
+++ b/ctest/c_d3chke.c
@@ -43,7 +43,237 @@ void F77_d3chke(char *rout) {
cblas_ok = TRUE ;
cblas_lerr = PASSED ;
- if (strncmp( sf,"cblas_dgemm" ,11)==0) {
+ if (strncmp( sf,"cblas_dgemmtr" ,13)==0) {
+ cblas_rout = "cblas_dgemmtr" ;
+
+ cblas_info = 1;
+ cblas_dgemmtr( INVALID, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 1;
+ cblas_dgemmtr( INVALID, CblasUpper, CblasNoTrans, CblasTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 1;
+ cblas_dgemmtr( INVALID, CblasUpper,CblasTrans, CblasNoTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 1;
+ cblas_dgemmtr( INVALID, CblasUpper, CblasTrans, CblasTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 1;
+ cblas_dgemmtr( INVALID, CblasLower, CblasNoTrans, CblasNoTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 1;
+ cblas_dgemmtr( INVALID, CblasLower, CblasNoTrans, CblasTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 1;
+ cblas_dgemmtr( INVALID, CblasLower,CblasTrans, CblasNoTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 1;
+ cblas_dgemmtr( INVALID, CblasLower, CblasTrans, CblasTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 2; RowMajorStrg = FALSE;
+ cblas_dgemmtr( CblasColMajor, INVALID, CblasNoTrans, CblasNoTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 2; RowMajorStrg = FALSE;
+ cblas_dgemmtr( CblasColMajor, INVALID, CblasNoTrans, CblasTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 3; RowMajorStrg = FALSE;
+ cblas_dgemmtr( CblasColMajor, CblasUpper, INVALID, CblasNoTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 3; RowMajorStrg = FALSE;
+ cblas_dgemmtr( CblasColMajor, CblasUpper, INVALID, CblasTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 4; RowMajorStrg = FALSE;
+ cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 4; RowMajorStrg = FALSE;
+ cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, INVALID, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+
+ cblas_info = 5; RowMajorStrg = FALSE;
+ cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 5; RowMajorStrg = FALSE;
+ cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 5; RowMajorStrg = FALSE;
+ cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 5; RowMajorStrg = FALSE;
+ cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 6; RowMajorStrg = FALSE;
+ cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 6; RowMajorStrg = FALSE;
+ cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 6; RowMajorStrg = FALSE;
+ cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 6; RowMajorStrg = FALSE;
+ cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+
+ cblas_info = 9; RowMajorStrg = FALSE;
+ cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 2 );
+ chkxer();
+ cblas_info = 9; RowMajorStrg = FALSE;
+ cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 2 );
+ chkxer();
+ cblas_info = 9; RowMajorStrg = FALSE;
+ cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2,
+ ALPHA, A, 1, B, 2, BETA, C, 1 );
+ chkxer();
+ cblas_info = 9; RowMajorStrg = FALSE;
+ cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 0, 2,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 11; RowMajorStrg = FALSE;
+ cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 11; RowMajorStrg = FALSE;
+ cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2,
+ ALPHA, A, 2, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 11; RowMajorStrg = FALSE;
+ cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 14; RowMajorStrg = FALSE;
+ cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0,
+ ALPHA, A, 2, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 14; RowMajorStrg = FALSE;
+ cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0,
+ ALPHA, A, 2, B, 2, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 14; RowMajorStrg = FALSE;
+ cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0,
+ ALPHA, A, 2, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 14; RowMajorStrg = FALSE;
+ cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0,
+ ALPHA, A, 2, B, 2, BETA, C, 1 );
+ chkxer();
+
+ /* Row Major */
+ cblas_info = 5; RowMajorStrg = TRUE;
+ cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 5; RowMajorStrg = TRUE;
+ cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 5; RowMajorStrg = TRUE;
+ cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 5; RowMajorStrg = TRUE;
+ cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 6; RowMajorStrg = TRUE;
+ cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 6; RowMajorStrg = TRUE;
+ cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 6; RowMajorStrg = TRUE;
+ cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 6; RowMajorStrg = TRUE;
+ cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 9; RowMajorStrg = TRUE;
+ cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2,
+ ALPHA, A, 1, B, 1, BETA, C, 2 );
+ chkxer();
+ cblas_info = 9; RowMajorStrg = TRUE;
+ cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, 2,
+ ALPHA, A, 1, B, 2, BETA, C, 2 );
+ chkxer();
+ cblas_info = 9; RowMajorStrg = TRUE;
+ cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0,
+ ALPHA, A, 1, B, 2, BETA, C, 1 );
+ chkxer();
+ cblas_info = 9; RowMajorStrg = TRUE;
+ cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 11; RowMajorStrg = TRUE;
+ cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 11; RowMajorStrg = TRUE;
+ cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2,
+ ALPHA, A, 2, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 11; RowMajorStrg = TRUE;
+ cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 14; RowMajorStrg = TRUE;
+ cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0,
+ ALPHA, A, 2, B, 2, BETA, C, 1 );
+ chkxer();
+ cblas_info = 14; RowMajorStrg = TRUE;
+ cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0,
+ ALPHA, A, 2, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 14; RowMajorStrg = TRUE;
+ cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0,
+ ALPHA, A, 2, B, 2, BETA, C, 1 );
+ chkxer();
+ cblas_info = 14; RowMajorStrg = TRUE;
+ cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0,
+ ALPHA, A, 2, B, 2, BETA, C, 1 );
+ chkxer();
+
+ } else if (strncmp( sf,"cblas_dgemm" ,11)==0) {
cblas_rout = "cblas_dgemm" ;
cblas_info = 1;
diff --git a/ctest/c_dblat3c.c b/ctest/c_dblat3c.c
index b90ec12fa3..ae601b6487 100644
--- a/ctest/c_dblat3c.c
+++ b/ctest/c_dblat3c.c
@@ -302,7 +302,7 @@ static logical c_false = FALSE_;
static integer nidim;
static char snaps[32];
static integer isnum;
- static logical ltest[6];
+ static logical ltest[7];
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;
diff --git a/ctest/c_s3chke.c b/ctest/c_s3chke.c
index 632eaae30e..ae7bee6313 100644
--- a/ctest/c_s3chke.c
+++ b/ctest/c_s3chke.c
@@ -43,7 +43,237 @@ void F77_s3chke(char *rout) {
cblas_ok = TRUE ;
cblas_lerr = PASSED ;
- if (strncmp( sf,"cblas_sgemm" ,11)==0) {
+ if (strncmp( sf,"cblas_sgemmtr" ,13)==0) {
+ cblas_rout = "cblas_sgemmtr" ;
+
+ cblas_info = 1;
+ cblas_sgemmtr( INVALID, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 1;
+ cblas_sgemmtr( INVALID, CblasUpper, CblasNoTrans, CblasTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 1;
+ cblas_sgemmtr( INVALID, CblasUpper,CblasTrans, CblasNoTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 1;
+ cblas_sgemmtr( INVALID, CblasUpper, CblasTrans, CblasTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 1;
+ cblas_sgemmtr( INVALID, CblasLower, CblasNoTrans, CblasNoTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 1;
+ cblas_sgemmtr( INVALID, CblasLower, CblasNoTrans, CblasTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 1;
+ cblas_sgemmtr( INVALID, CblasLower,CblasTrans, CblasNoTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 1;
+ cblas_sgemmtr( INVALID, CblasLower, CblasTrans, CblasTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 2; RowMajorStrg = FALSE;
+ cblas_sgemmtr( CblasColMajor, INVALID, CblasNoTrans, CblasNoTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 2; RowMajorStrg = FALSE;
+ cblas_sgemmtr( CblasColMajor, INVALID, CblasNoTrans, CblasTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 3; RowMajorStrg = FALSE;
+ cblas_sgemmtr( CblasColMajor, CblasUpper, INVALID, CblasNoTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 3; RowMajorStrg = FALSE;
+ cblas_sgemmtr( CblasColMajor, CblasUpper, INVALID, CblasTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 4; RowMajorStrg = FALSE;
+ cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 4; RowMajorStrg = FALSE;
+ cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, INVALID, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+
+ cblas_info = 5; RowMajorStrg = FALSE;
+ cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 5; RowMajorStrg = FALSE;
+ cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 5; RowMajorStrg = FALSE;
+ cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 5; RowMajorStrg = FALSE;
+ cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 6; RowMajorStrg = FALSE;
+ cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 6; RowMajorStrg = FALSE;
+ cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 6; RowMajorStrg = FALSE;
+ cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 6; RowMajorStrg = FALSE;
+ cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+
+ cblas_info = 9; RowMajorStrg = FALSE;
+ cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 2 );
+ chkxer();
+ cblas_info = 9; RowMajorStrg = FALSE;
+ cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 2 );
+ chkxer();
+ cblas_info = 9; RowMajorStrg = FALSE;
+ cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2,
+ ALPHA, A, 1, B, 2, BETA, C, 1 );
+ chkxer();
+ cblas_info = 9; RowMajorStrg = FALSE;
+ cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 0, 2,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 11; RowMajorStrg = FALSE;
+ cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 11; RowMajorStrg = FALSE;
+ cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2,
+ ALPHA, A, 2, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 11; RowMajorStrg = FALSE;
+ cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 14; RowMajorStrg = FALSE;
+ cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0,
+ ALPHA, A, 2, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 14; RowMajorStrg = FALSE;
+ cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0,
+ ALPHA, A, 2, B, 2, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 14; RowMajorStrg = FALSE;
+ cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0,
+ ALPHA, A, 2, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 14; RowMajorStrg = FALSE;
+ cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0,
+ ALPHA, A, 2, B, 2, BETA, C, 1 );
+ chkxer();
+
+ /* Row Major */
+ cblas_info = 5; RowMajorStrg = TRUE;
+ cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 5; RowMajorStrg = TRUE;
+ cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 5; RowMajorStrg = TRUE;
+ cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 5; RowMajorStrg = TRUE;
+ cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 6; RowMajorStrg = TRUE;
+ cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 6; RowMajorStrg = TRUE;
+ cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 6; RowMajorStrg = TRUE;
+ cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 6; RowMajorStrg = TRUE;
+ cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 9; RowMajorStrg = TRUE;
+ cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2,
+ ALPHA, A, 1, B, 1, BETA, C, 2 );
+ chkxer();
+ cblas_info = 9; RowMajorStrg = TRUE;
+ cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, 2,
+ ALPHA, A, 1, B, 2, BETA, C, 2 );
+ chkxer();
+ cblas_info = 9; RowMajorStrg = TRUE;
+ cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0,
+ ALPHA, A, 1, B, 2, BETA, C, 1 );
+ chkxer();
+ cblas_info = 9; RowMajorStrg = TRUE;
+ cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 11; RowMajorStrg = TRUE;
+ cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 11; RowMajorStrg = TRUE;
+ cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2,
+ ALPHA, A, 2, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 11; RowMajorStrg = TRUE;
+ cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 14; RowMajorStrg = TRUE;
+ cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0,
+ ALPHA, A, 2, B, 2, BETA, C, 1 );
+ chkxer();
+ cblas_info = 14; RowMajorStrg = TRUE;
+ cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0,
+ ALPHA, A, 2, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 14; RowMajorStrg = TRUE;
+ cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0,
+ ALPHA, A, 2, B, 2, BETA, C, 1 );
+ chkxer();
+ cblas_info = 14; RowMajorStrg = TRUE;
+ cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0,
+ ALPHA, A, 2, B, 2, BETA, C, 1 );
+ chkxer();
+
+ } else if (strncmp( sf,"cblas_sgemm" ,11)==0) {
cblas_rout = "cblas_sgemm" ;
cblas_info = 1;
cblas_sgemm( INVALID, CblasNoTrans, CblasNoTrans, 0, 0, 0,
diff --git a/ctest/c_sblat3c.c b/ctest/c_sblat3c.c
index 3973d5f52f..85b5f05117 100644
--- a/ctest/c_sblat3c.c
+++ b/ctest/c_sblat3c.c
@@ -299,7 +299,7 @@ static logical c_false = FALSE_;
extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*);
static char snaps[32];
static integer isnum;
- static logical ltest[6];
+ static logical ltest[7];
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;
@@ -794,7 +794,7 @@ static logical c_false = FALSE_;
/* 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__3, i__4, i__5, i__6;
/* Local variables */
@@ -1174,7 +1174,7 @@ static logical c_false = FALSE_;
/* 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__3, i__4, i__5;
/* Local variables */
diff --git a/ctest/c_xerbla.c b/ctest/c_xerbla.c
index 9c53576536..935b900a8f 100644
--- a/ctest/c_xerbla.c
+++ b/ctest/c_xerbla.c
@@ -33,13 +33,18 @@ void cblas_xerbla(blasint info, char *rout, char *form, ...)
* for A and B, lda is in position 11 instead of 9, and ldb is in
* position 9 instead of 11.
*/
- if (strstr(rout,"gemm") != 0)
+ if (strstr(rout,"gemm") != 0 && strstr(rout, "gemmtr") == 0)
{
if (info == 5 ) info = 4;
else if (info == 4 ) info = 5;
else if (info == 11) info = 9;
else if (info == 9 ) info = 11;
+ } else if (strstr(rout, "gemmtr") != 0)
+ {
+ if (info == 11) info = 9;
+ else if (info == 9 ) info = 11;
}
+
else if (strstr(rout,"symm") != 0 || strstr(rout,"hemm") != 0)
{
if (info == 5 ) info = 4;
@@ -94,7 +99,7 @@ void F77_xerbla(char *srname, void *vinfo)
char *srname;
#endif
- char rout[] = {'c','b','l','a','s','_','\0','\0','\0','\0','\0','\0','\0'};
+ char rout[] = {'c','b','l','a','s','_','\0','\0','\0','\0','\0','\0','\0','\0'};
#ifdef F77_Integer
F77_Integer *info=vinfo;
@@ -115,8 +120,8 @@ void F77_xerbla(char *srname, void *vinfo)
link_xerbla = 0;
return;
}
- for(i=0; i < 6; i++) rout[i+6] = tolower(srname[i]);
- for(i=11; i >= 9; i--) if (rout[i] == ' ') rout[i] = '\0';
+ for(i=0; i < 7; i++) rout[i+6] = tolower(srname[i]);
+ for(i=12; i >= 9; i--) if (rout[i] == ' ') rout[i] = '\0';
/* We increment *info by 1 since the CBLAS interface adds one more
* argument to all level 2 and 3 routines.
diff --git a/ctest/c_z3chke.c b/ctest/c_z3chke.c
index 054e723603..809f6a3de8 100644
--- a/ctest/c_z3chke.c
+++ b/ctest/c_z3chke.c
@@ -45,11 +45,237 @@ void F77_z3chke(char * rout) {
F77_xerbla(cblas_rout,&cblas_info);
}
+ if (strncmp( sf,"cblas_zgemmtr" ,13)==0) {
+ cblas_rout = "cblas_zgemmtr" ;
+ cblas_info = 1;
+ cblas_zgemmtr( INVALID, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 1;
+ cblas_zgemmtr( INVALID, CblasUpper, CblasNoTrans, CblasTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 1;
+ cblas_zgemmtr( INVALID, CblasUpper,CblasTrans, CblasNoTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 1;
+ cblas_zgemmtr( INVALID, CblasUpper, CblasTrans, CblasTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 1;
+ cblas_zgemmtr( INVALID, CblasLower, CblasNoTrans, CblasNoTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 1;
+ cblas_zgemmtr( INVALID, CblasLower, CblasNoTrans, CblasTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 1;
+ cblas_zgemmtr( INVALID, CblasLower,CblasTrans, CblasNoTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 1;
+ cblas_zgemmtr( INVALID, CblasLower, CblasTrans, CblasTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 2; RowMajorStrg = FALSE;
+ cblas_zgemmtr( CblasColMajor, INVALID, CblasNoTrans, CblasNoTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 2; RowMajorStrg = FALSE;
+ cblas_zgemmtr( CblasColMajor, INVALID, CblasNoTrans, CblasTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 3; RowMajorStrg = FALSE;
+ cblas_zgemmtr( CblasColMajor, CblasUpper, INVALID, CblasNoTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 3; RowMajorStrg = FALSE;
+ cblas_zgemmtr( CblasColMajor, CblasUpper, INVALID, CblasTrans, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 4; RowMajorStrg = FALSE;
+ cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 4; RowMajorStrg = FALSE;
+ cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, INVALID, 0, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+
+ cblas_info = 5; RowMajorStrg = FALSE;
+ cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 5; RowMajorStrg = FALSE;
+ cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 5; RowMajorStrg = FALSE;
+ cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 5; RowMajorStrg = FALSE;
+ cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 6; RowMajorStrg = FALSE;
+ cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 6; RowMajorStrg = FALSE;
+ cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 6; RowMajorStrg = FALSE;
+ cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 6; RowMajorStrg = FALSE;
+ cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+
+ cblas_info = 9; RowMajorStrg = FALSE;
+ cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 2 );
+ chkxer();
+ cblas_info = 9; RowMajorStrg = FALSE;
+ cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 2 );
+ chkxer();
+ cblas_info = 9; RowMajorStrg = FALSE;
+ cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2,
+ ALPHA, A, 1, B, 2, BETA, C, 1 );
+ chkxer();
+ cblas_info = 9; RowMajorStrg = FALSE;
+ cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 0, 2,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 11; RowMajorStrg = FALSE;
+ cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 11; RowMajorStrg = FALSE;
+ cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2,
+ ALPHA, A, 2, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 11; RowMajorStrg = FALSE;
+ cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 14; RowMajorStrg = FALSE;
+ cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0,
+ ALPHA, A, 2, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 14; RowMajorStrg = FALSE;
+ cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0,
+ ALPHA, A, 2, B, 2, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 14; RowMajorStrg = FALSE;
+ cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0,
+ ALPHA, A, 2, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 14; RowMajorStrg = FALSE;
+ cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0,
+ ALPHA, A, 2, B, 2, BETA, C, 1 );
+ chkxer();
+
+ /* Row Major */
+ cblas_info = 5; RowMajorStrg = TRUE;
+ cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 5; RowMajorStrg = TRUE;
+ cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 5; RowMajorStrg = TRUE;
+ cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 5; RowMajorStrg = TRUE;
+ cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, INVALID, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 6; RowMajorStrg = TRUE;
+ cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 6; RowMajorStrg = TRUE;
+ cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 6; RowMajorStrg = TRUE;
+ cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 6; RowMajorStrg = TRUE;
+ cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 0, INVALID,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 9; RowMajorStrg = TRUE;
+ cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2,
+ ALPHA, A, 1, B, 1, BETA, C, 2 );
+ chkxer();
+ cblas_info = 9; RowMajorStrg = TRUE;
+ cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, 2,
+ ALPHA, A, 1, B, 2, BETA, C, 2 );
+ chkxer();
+ cblas_info = 9; RowMajorStrg = TRUE;
+ cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0,
+ ALPHA, A, 1, B, 2, BETA, C, 1 );
+ chkxer();
+ cblas_info = 9; RowMajorStrg = TRUE;
+ cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 11; RowMajorStrg = TRUE;
+ cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 11; RowMajorStrg = TRUE;
+ cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2,
+ ALPHA, A, 2, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 11; RowMajorStrg = TRUE;
+ cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0,
+ ALPHA, A, 1, B, 1, BETA, C, 1 );
+ chkxer();
+
+ cblas_info = 14; RowMajorStrg = TRUE;
+ cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0,
+ ALPHA, A, 2, B, 2, BETA, C, 1 );
+ chkxer();
+ cblas_info = 14; RowMajorStrg = TRUE;
+ cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0,
+ ALPHA, A, 2, B, 1, BETA, C, 1 );
+ chkxer();
+ cblas_info = 14; RowMajorStrg = TRUE;
+ cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0,
+ ALPHA, A, 2, B, 2, BETA, C, 1 );
+ chkxer();
+ cblas_info = 14; RowMajorStrg = TRUE;
+ cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0,
+ ALPHA, A, 2, B, 2, BETA, C, 1 );
+ chkxer();
- if (strncmp( sf,"cblas_zgemm" ,11)==0) {
+ } else if (strncmp( sf,"cblas_zgemm" ,11)==0) {
cblas_rout = "cblas_zgemm" ;
cblas_info = 1;