From cfb7685a7fe726d792f63090f538296006766c5f Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Wed, 19 Mar 2025 22:36:56 +0100 Subject: [PATCH 1/8] 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 Date: Wed, 19 Mar 2025 22:41:20 +0100 Subject: [PATCH 2/8] 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 -#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 -#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 #include -#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 -#include "common.h" +#include +#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 Date: Thu, 20 Mar 2025 11:10:55 +0100 Subject: [PATCH 3/8] 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 Date: Thu, 20 Mar 2025 11:44:10 +0100 Subject: [PATCH 4/8] 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 Date: Thu, 20 Mar 2025 15:44:59 +0100 Subject: [PATCH 5/8] 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 Date: Thu, 20 Mar 2025 20:20:41 +0100 Subject: [PATCH 6/8] 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;ir,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;ir,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 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 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;ir * 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 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= 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 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= 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 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= 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 *nmax) { - goto L80; + } + pCf(z) = zdotc; +} +#else + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i *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 *nmax) { - goto L130; + } + pCd(z) = zdotc; +} +#else + _Complex double zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i *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= 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 *nmax) { - goto L80; + } + pCf(z) = zdotc; +} +#else + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;ir,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 *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 *nmax) { - goto L130; + } + pCd(z) = zdotc; +} +#else + _Complex double zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;ir,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 Date: Thu, 20 Mar 2025 22:27:05 +0100 Subject: [PATCH 7/8] 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 Date: Fri, 21 Mar 2025 09:21:16 +0100 Subject: [PATCH 8/8] 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;im) 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;im) 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;im) 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