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); diff --git a/ctest/c_c3chke.c b/ctest/c_c3chke.c index 3b4764c4a7..e202be4a9e 100644 --- a/ctest/c_c3chke.c +++ b/ctest/c_c3chke.c @@ -45,8 +45,237 @@ void F77_c3chke(char * rout) { F77_xerbla(cblas_rout,&cblas_info); } + if (strncmp( sf,"cblas_cgemmtr" ,13)==0) { + cblas_rout = "cblas_cgemmtr" ; - if (strncmp( sf,"cblas_cgemm" ,11)==0) { + cblas_info = 1; + cblas_cgemmtr( INVALID, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_cgemmtr( INVALID, CblasUpper, CblasNoTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_cgemmtr( INVALID, CblasUpper,CblasTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_cgemmtr( INVALID, CblasUpper, CblasTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 1; + cblas_cgemmtr( INVALID, CblasLower, CblasNoTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_cgemmtr( INVALID, CblasLower, CblasNoTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_cgemmtr( INVALID, CblasLower,CblasTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_cgemmtr( INVALID, CblasLower, CblasTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 2; RowMajorStrg = FALSE; + cblas_cgemmtr( CblasColMajor, INVALID, CblasNoTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_cgemmtr( CblasColMajor, INVALID, CblasNoTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 3; RowMajorStrg = FALSE; + cblas_cgemmtr( CblasColMajor, CblasUpper, INVALID, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_cgemmtr( CblasColMajor, CblasUpper, INVALID, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 4; RowMajorStrg = FALSE; + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + + cblas_info = 5; RowMajorStrg = FALSE; + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 6; RowMajorStrg = FALSE; + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + + cblas_info = 9; RowMajorStrg = FALSE; + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 11; RowMajorStrg = FALSE; + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 14; RowMajorStrg = FALSE; + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + + cblas_info = 14; RowMajorStrg = FALSE; + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + + /* Row Major */ + cblas_info = 5; RowMajorStrg = TRUE; + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 6; RowMajorStrg = TRUE; + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 9; RowMajorStrg = TRUE; + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 11; RowMajorStrg = TRUE; + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 14; RowMajorStrg = TRUE; + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_cgemm" ,11)==0) { cblas_rout = "cblas_cgemm" ; diff --git a/ctest/c_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_cblat3c.c b/ctest/c_cblat3c.c index 5ad9b8bd89..b25621bc63 100644 --- a/ctest/c_cblat3c.c +++ b/ctest/c_cblat3c.c @@ -236,14 +236,11 @@ typedef struct Namelist Namelist; #define mycycle_() continue; #define myceiling_(w) {ceil(w)} #define myhuge_(w) {HUGE_VAL} -//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} -#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) /* procedure parameter types for -A and -C++ */ #define F2C_proc_par_types 1 - /* Common Block Declarations */ struct { @@ -254,7 +251,7 @@ struct { #define infoc_1 infoc_ struct { - char srnamt[12]; + char srnamt[13]; } srnamc_; #define srnamc_1 srnamc_ @@ -275,15 +272,23 @@ 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"}; + static char snames[10][14] = {"cblas_cgemm ", "cblas_chemm ", "cblas_csymm ", + "cblas_ctrmm ", "cblas_ctrsm ", "cblas_cherk ", "cblas_csyrk ", + "cblas_cher2k ", "cblas_csyr2k ", "cblas_cgemmtr"}; /* System generated locals */ integer i__1, i__2, i__3, i__4, i__5; real r__1; /* 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; @@ -310,12 +315,13 @@ int /* Main program */ main(void) 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; + 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; - complex w[130]; extern /* Subroutine */ int cmmch_(char *, char *, integer *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, real *, complex *, @@ -325,29 +331,22 @@ int /* Main program */ main(void) 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]; + 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; - 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 */ +/* 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. */ @@ -361,15 +360,16 @@ int /* Main program */ main(void) /* (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: */ @@ -390,8 +390,9 @@ int /* Main program */ main(void) infoc_1.noutc = 6; /* Read name and unit number for snapshot output file and open file. */ - char line[80]; - + char tmpchar; + char line[80]; + fgets(line,80,stdin); sscanf(line,"'%s'",snaps); fgets(line,80,stdin); @@ -402,7 +403,8 @@ int /* Main program */ main(void) #endif trace = ntra >= 0; if (trace) { -/* o__1.oerr = 0; +/* + o__1.oerr = 0; o__1.ounit = ntra; o__1.ofnmlen = 32; o__1.ofnm = snaps; @@ -411,7 +413,8 @@ int /* Main program */ main(void) o__1.oacc = 0; o__1.ofm = 0; o__1.oblnk = 0; - f_open(&o__1);*/ + f_open(&o__1); +*/ } /* Read the flag that directs rewinding of the snapshot file. */ fgets(line,80,stdin); @@ -424,10 +427,13 @@ int /* Main program */ main(void) 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); @@ -443,8 +449,8 @@ int /* Main program */ main(void) #endif if (nidim < 1 || nidim > 9) { - fprintf(stderr,"NUMBER OF VALUES OF N IS LESS THAN 1 OR GREATER THAN 9"); - goto L220; + fprintf(stderr,"NUMBER OF VALUES OF N IS LESS THAN 1 OR GREATER THAN 9"); + goto L220; } fgets(line,80,stdin); #ifdef USE64BITINT @@ -456,10 +462,10 @@ int /* Main program */ main(void) #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; - } + 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 */ @@ -470,17 +476,14 @@ int /* Main program */ main(void) 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; + fprintf(stderr,"NUMBER OF VALUES 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 @@ -531,7 +534,7 @@ int /* Main program */ main(void) /* Read names of subroutines and flags which indicate */ /* whether they are to be tested. */ - for (i__ = 1; i__ <= 9; ++i__) { + for (i__ = 1; i__ <= 10; ++i__) { ltest[i__ - 1] = FALSE_; /* L20: */ } @@ -539,14 +542,14 @@ int /* Main program */ main(void) if (! fgets(line,80,stdin)) { goto L60; } - i__1 = sscanf(line,"%12c %c",snamet,&tmpchar); + i__1 = sscanf(line,"%13c %c",snamet,&tmpchar); ltestt=FALSE_; if (tmpchar=='T')ltestt=TRUE_; if (i__1 < 2) { goto L60; } - for (i__ = 1; i__ <= 9; ++i__) { - if (s_cmp(snamet, snames[i__ - 1] , (ftnlen)12, (ftnlen)12) == + for (i__ = 1; i__ <= 10; ++i__) { + if (s_cmp(snamet, snames[i__ - 1] , (ftnlen)13, (ftnlen)13) == 0) { goto L50; } @@ -559,11 +562,12 @@ int /* Main program */ main(void) goto L30; L60: -/* cl__1.cerr = 0; +/* + cl__1.cerr = 0; cl__1.cunit = 5; cl__1.csta = 0; - f_clos(&cl__1);*/ - + f_clos(&cl__1); +*/ /* Compute EPS (the machine precision). */ eps = 1.f; @@ -683,13 +687,13 @@ int /* Main program */ main(void) /* Test each subroutine in turn. */ - for (isnum = 1; isnum <= 9; ++isnum) { + for (isnum = 1; isnum <= 10; ++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); + s_copy(srnamc_1.srnamt, snames [isnum - 1] , (ftnlen)13, ( + ftnlen)13); /* Test error exits. */ if (tsterr) { cc3chke_(snames[isnum - 1]); @@ -708,6 +712,7 @@ int /* Main program */ main(void) case 7: goto L170; case 8: goto L180; case 9: goto L180; + case 10: goto L185; } /* Test CGEMM, 01. */ L140: @@ -784,6 +789,21 @@ int /* Main program */ main(void) ct, g, w, &c__1); } goto L190; +/* Test CGEMMTR, 10. */ +L185: + if (corder) { + cchk6_(snames [isnum - 1] , &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__0); + } + if (rorder) { + cchk6_(snames [isnum - 1], &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) { @@ -802,12 +822,15 @@ int /* Main program */ main(void) 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.cerr = 0; cl__1.cunit = ntra; cl__1.csta = 0; - f_clos(&cl__1);*/ + f_clos(&cl__1); +*/ } /* cl__1.cerr = 0; cl__1.cunit = 6; @@ -837,10 +860,14 @@ int /* Main program */ main(void) i__3, i__4, i__5, i__6, i__7, i__8; /* 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; - integer i__, k, m, n; extern /* Subroutine */ int cmake_(char *, char *, char *, integer *, integer *, complex *, integer *, complex *, integer *, logical *, complex *); @@ -855,19 +882,14 @@ int /* Main program */ main(void) 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. */ @@ -888,17 +910,17 @@ int /* Main program */ main(void) --cs; --cc; c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; + c_offset = 1 + c_dim1; c__ -= c_offset; --bs; --bb; b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; + b_offset = 1 + b_dim1; b -= b_offset; --as; --aa; a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; /* Function Body */ @@ -1065,9 +1087,6 @@ int /* Main program */ main(void) /* Check if error-exit was taken incorrectly. */ if (! infoc_1.ok) { -// io___128.ciunit = *nout; -// s_wsfe(&io___128); -// e_wsfe(); printf(" *** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); *fatal = TRUE_; goto L120; @@ -1244,13 +1263,19 @@ int /* Main program */ main(void) i__3, i__4, i__5, i__6, i__7; /* 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]; - integer i__, m, n; extern /* Subroutine */ int cmake_(char *, char *, char *, integer *, integer *, complex *, integer *, complex *, integer *, logical *, complex *); @@ -1267,23 +1292,16 @@ int /* Main program */ main(void) 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. */ @@ -1304,17 +1322,17 @@ int /* Main program */ main(void) --cs; --cc; c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; + c_offset = 1 + c_dim1; c__ -= c_offset; --bs; --bb; b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; + b_offset = 1 + b_dim1; b -= b_offset; --as; --aa; a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; /* Function Body */ @@ -1697,19 +1715,19 @@ int /* Main program */ main(void) --idim; --alf; c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; + c_offset = 1 + c_dim1; c__ -= c_offset; --g; --ct; --bs; --bb; b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; + b_offset = 1 + b_dim1; b -= b_offset; --as; --aa; a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; /* Function Body */ @@ -2180,17 +2198,17 @@ int /* Main program */ main(void) --cs; --cc; c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; + c_offset = 1 + c_dim1; c__ -= c_offset; --bs; --bb; b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; + b_offset = 1 + b_dim1; b -= b_offset; --as; --aa; a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; /* Function Body */ @@ -2202,7 +2220,8 @@ int /* Main program */ main(void) errmax = 0.f; rals = 1.f; rbets = 1.f; - + bets.r=bets.i=0.f; + i__1 = *nidim; for (in = 1; in <= i__1; ++in) { n = idim[in]; @@ -2311,7 +2330,7 @@ int /* Main program */ main(void) if (conj) { rbets = rbeta; } else { - bets.r = beta.r, bets.i = beta.i; + bets.r = beta.r; bets.i = beta.i; } i__5 = lcc; for (i__ = 1; i__ <= i__5; ++i__) { @@ -2370,18 +2389,18 @@ int /* Main program */ main(void) isame[2] = ns == n; isame[3] = ks == k; if (conj) { - isame[4] = rals == ralpha; + isame[4] = (rals == ralpha); } else { - isame[4] = als.r == alpha.r && als.i == - alpha.i; + isame[4] = (( als.r == alpha.r) && (als.i == + alpha.i)); } isame[5] = lce_(&as[1], &aa[1], &laa); isame[6] = ldas == lda; if (conj) { isame[7] = rbets == rbeta; } else { - isame[7] = bets.r == beta.r && bets.i == - beta.i; + isame[7] = ((bets.r == beta.r) && (bets.i == + beta.i)); } if (null) { isame[8] = lce_(&cs[1], &cc[1], &lcc); @@ -2389,7 +2408,7 @@ int /* Main program */ main(void) isame[8] = lceres_(sname + 7, uplo, &n, &n, & cs[1], &cc[1], &ldc); } - isame[9] = ldcs == ldc; + isame[9] = (ldcs == ldc); /* If data was incorrectly changed, report and */ /* return. */ @@ -2675,7 +2694,7 @@ int /* Main program */ main(void) --cs; --cc; c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; + c_offset = 1 + c_dim1; c__ -= c_offset; --bs; --bb; @@ -2818,7 +2837,7 @@ int /* Main program */ main(void) if (conj) { rbets = rbeta; } else { - bets.r = beta.r, bets.i = beta.i; + bets.r = beta.r; bets.i = beta.i; } i__5 = lcc; for (i__ = 1; i__ <= i__5; ++i__) { @@ -3375,18 +3394,18 @@ int /* Main program */ main(void) /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; b_dim1 = *ldb; - b_offset = 1 + b_dim1 * 1; + b_offset = 1 + b_dim1; b -= b_offset; c_dim1 = *ldc; - c_offset = 1 + c_dim1 * 1; + c_offset = 1 + c_dim1; c__ -= c_offset; --ct; --g; cc_dim1 = *ldcc; - cc_offset = 1 + cc_dim1 * 1; + cc_offset = 1 + cc_dim1; cc -= cc_offset; /* Function Body */ @@ -3793,10 +3812,10 @@ logical lceres_(char *type__, char *uplo, integer *m, integer *n, complex *aa, /* Parameter adjustments */ as_dim1 = *lda; - as_offset = 1 + as_dim1 * 1; + as_offset = 1 + as_dim1; as -= as_offset; aa_dim1 = *lda; - aa_offset = 1 + aa_dim1 * 1; + aa_offset = 1 + aa_dim1; aa -= aa_offset; /* Function Body */ @@ -3848,7 +3867,7 @@ logical lceres_(char *type__, char *uplo, integer *m, integer *n, complex *aa, } } -/* 60 CONTINUE */ +/* L60: */ ret_val = TRUE_; goto L80; L70: @@ -3939,4 +3958,791 @@ real sdiff_(real *x, real *y) } /* sdiff_ */ -/* Main program alias */ /*int cblat3_ () { MAIN__ (); return 0; }*/ +/* 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"; + + /* 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 */ + 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; + + +/* 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); + } + 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) { + 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 *)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]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* 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) { + 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); + 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) +{ + /* Local variables */ + char crc[14], cta[14], ctb[14], cuplo[14]; + + 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); + } + printf("%6d: %s %s %s %s %s\n",*nc,sname,crc,cuplo,cta,ctb); + printf("%d %d (%4.1f,%4.1f) A, %d, B, %d, (%4.1f,%4.1f), C, %d.\n",*n,*k,alpha->r,alpha->i,*lda,*ldb,beta->r,beta->i,*ldc); + 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) +{ + /* 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; + +/* 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_; + printf(" ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HALF ACCURATE *******\n"); + printf(" EXPECTED RESULT COMPUTED RESULT\n"); + + i__1 = istop; + for (i__ = istart; i__ <= i__1; ++i__) { + if (*mv) { + 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 CMMTCH. */ + +} /* cmmtch_ */ + diff --git a/ctest/c_cblat3c_3m.c b/ctest/c_cblat3c_3m.c index b5d6bf9cbb..e4c3b12e11 100644 --- a/ctest/c_cblat3c_3m.c +++ b/ctest/c_cblat3c_3m.c @@ -275,7 +275,7 @@ int /* Main program */ main(void) { /* Initialized data */ - static char snames[9][13] = {"cblas_cgemm3m ", "cblas_chemm ", "cblas_csymm ", + static char snames[9][13] = {"cblas_cgemm3m", "cblas_chemm ", "cblas_csymm ", "cblas_ctrmm ", "cblas_ctrsm ", "cblas_cherk ", "cblas_csyrk ", "cblas_cher2k", "cblas_csyr2k"}; @@ -2261,7 +2261,7 @@ int /* Main program */ main(void) if (conj) { ralpha = alpha.r; q__1.r = ralpha, q__1.i = 0.f; - alpha.r = q__1.r, alpha.i = q__1.i; + alpha.r = q__1.r; alpha.i = q__1.i; } i__4 = *nbet; @@ -2297,7 +2297,7 @@ int /* Main program */ main(void) if (conj) { rals = ralpha; } else { - als.r = alpha.r, als.i = alpha.i; + als.r = alpha.r; als.i = alpha.i; } i__5 = laa; for (i__ = 1; i__ <= i__5; ++i__) { @@ -2311,7 +2311,7 @@ int /* Main program */ main(void) if (conj) { rbets = rbeta; } else { - bets.r = beta.r, bets.i = beta.i; + bets.r = beta.r; bets.i = beta.i; } i__5 = lcc; for (i__ = 1; i__ <= i__5; ++i__) { @@ -2378,10 +2378,10 @@ int /* Main program */ main(void) isame[5] = lce_(&as[1], &aa[1], &laa); isame[6] = ldas == lda; if (conj) { - isame[7] = rbets == rbeta; + isame[7] = (rbets == rbeta); } else { - isame[7] = bets.r == beta.r && bets.i == - beta.i; + isame[7] = ((bets.r == beta.r) && (bets.i == + beta.i)); } if (null) { isame[8] = lce_(&cs[1], &cc[1], &lcc); @@ -2818,7 +2818,7 @@ int /* Main program */ main(void) if (conj) { rbets = rbeta; } else { - bets.r = beta.r, bets.i = beta.i; + bets.r = beta.r; bets.i = beta.i; } i__5 = lcc; for (i__ = 1; i__ <= i__5; ++i__) { diff --git a/ctest/c_d3chke.c b/ctest/c_d3chke.c index 700cff28f6..43d0de75d7 100644 --- a/ctest/c_d3chke.c +++ b/ctest/c_d3chke.c @@ -43,7 +43,237 @@ void F77_d3chke(char *rout) { cblas_ok = TRUE ; cblas_lerr = PASSED ; - if (strncmp( sf,"cblas_dgemm" ,11)==0) { + if (strncmp( sf,"cblas_dgemmtr" ,13)==0) { + cblas_rout = "cblas_dgemmtr" ; + + cblas_info = 1; + cblas_dgemmtr( INVALID, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_dgemmtr( INVALID, CblasUpper, CblasNoTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_dgemmtr( INVALID, CblasUpper,CblasTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_dgemmtr( INVALID, CblasUpper, CblasTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 1; + cblas_dgemmtr( INVALID, CblasLower, CblasNoTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_dgemmtr( INVALID, CblasLower, CblasNoTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_dgemmtr( INVALID, CblasLower,CblasTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_dgemmtr( INVALID, CblasLower, CblasTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, INVALID, CblasNoTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, INVALID, CblasNoTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, INVALID, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, INVALID, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + + cblas_info = 9; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 11; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 14; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + + cblas_info = 14; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + + /* Row Major */ + cblas_info = 5; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 9; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 11; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 14; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_dgemm" ,11)==0) { cblas_rout = "cblas_dgemm" ; cblas_info = 1; diff --git a/ctest/c_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_dblat3c.c b/ctest/c_dblat3c.c index dc3d6f9e7f..ae601b6487 100644 --- a/ctest/c_dblat3c.c +++ b/ctest/c_dblat3c.c @@ -236,8 +236,6 @@ typedef struct Namelist Namelist; #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++ */ @@ -254,7 +252,7 @@ struct { #define infoc_1 infoc_ struct { - char srnamt[12]; + char srnamt[13]; } srnamc_; #define srnamc_1 srnamc_ @@ -270,11 +268,12 @@ static logical c_true = TRUE_; static integer c__0 = 0; static logical c_false = FALSE_; -/* Main program MAIN__() */ int main(void) +/* Main program */ int main(void) { /* Initialized data */ - static char snames[6][13] = {"cblas_dgemm ", "cblas_dsymm ", "cblas_dtrmm ", "cblas_dtrsm ", "cblas_dsyrk ", "cblas_dsyr2k"}; + static char snames[7][14] = {"cblas_dgemm ", "cblas_dsymm ", "cblas_dtrmm ", "cblas_dtrsm ", + "cblas_dsyrk ", "cblas_dsyr2k ", "cblas_dgemmtr"}; /* System generated locals */ integer i__1, i__2, i__3; @@ -286,30 +285,31 @@ static logical c_false = FALSE_; 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); + extern /* Subroutine */ int dchk1_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, integer*); + extern /* Subroutine */ int dchk2_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, integer*); + extern /* Subroutine */ int dchk3_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, integer*); + extern /* Subroutine */ int dchk4_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, integer*); + extern /* Subroutine */ int dchk5_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublereal* alf, integer* nbet, doublereal* bet, integer* nmax, doublereal* ab, doublereal* aa, doublereal* as, doublereal* bb, doublereal* bs, doublereal* c__, doublereal* cc, doublereal* cs, doublereal* ct, doublereal* g, doublereal* w, integer*); + extern /* Subroutine */ int dchk6_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublereal* alf, integer* nbet, doublereal* bet, integer* nmax, doublereal* ab, doublereal* aa, doublereal* as, doublereal* bb, doublereal* bs, doublereal* c__, doublereal* cc, doublereal* cs, doublereal* ct, doublereal* g, doublereal* w, integer*); static doublereal c__[4225] /* was [65][65] */, g[65]; static integer i__, j; extern doublereal ddiff_(doublereal*, doublereal*); static integer n; static logical fatal; static doublereal w[130]; - extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); + extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*); static logical trace; static integer nidim; static char snaps[32]; static integer isnum; - static logical ltest[6]; + static logical ltest[7]; static doublereal aa[4225], ab[8450] /* was [65][130] */, bb[4225], cc[4225], as[4225], bs[4225], cs[4225], ct[65]; static logical sfatal, corder; static char snamet[12], transa[1], transb[1]; static doublereal thresh; static logical rorder; - extern /* Subroutine */ void cd3chke_(char*, ftnlen); + extern /* Subroutine */ void cd3chke_(char*); static integer layout; static logical ltestt, tsterr; static doublereal alf[7]; @@ -321,14 +321,14 @@ static logical c_false = FALSE_; /* 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 STOP ON FAILURES. */ -/* T LOGICAL FLAG, T TO TEST ERROR EXITS. */ +/* 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 */ @@ -337,12 +337,13 @@ static logical c_false = FALSE_; /* 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: */ @@ -359,16 +360,6 @@ static logical c_false = FALSE_; /* 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. */ @@ -512,7 +503,7 @@ static logical c_false = FALSE_; /* Read names of subroutines and flags which indicate */ /* whether they are to be tested. */ - for (i__ = 1; i__ <= 6; ++i__) { + for (i__ = 1; i__ <= 7; ++i__) { ltest[i__ - 1] = FALSE_; /* L20: */ } @@ -520,14 +511,14 @@ static logical c_false = FALSE_; if (! fgets(line,80,stdin)) { goto L60; } - i__1 = sscanf(line,"%12c %c",snamet,&tmpchar); + i__1 = sscanf(line,"%13c %c",snamet,&tmpchar); ltestt=FALSE_; if (tmpchar=='T')ltestt=TRUE_; if (i__1 < 2) { goto L60; } - for (i__ = 1; i__ <= 6; ++i__) { - if (s_cmp(snamet, snames[i__ - 1] , (ftnlen)12, (ftnlen)12) == + for (i__ = 1; i__ <= 7; ++i__) { + if (s_cmp(snamet, snames[i__ - 1] , (ftnlen)13, (ftnlen)13) == 0) { goto L50; } @@ -590,7 +581,7 @@ static logical c_false = FALSE_; *(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); + fatal, &c__6, &c_true); same = lde_(cc, ct, &n); if (! same || err != 0.) { printf("ERROR IN DMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); @@ -603,7 +594,7 @@ static logical c_false = FALSE_; *(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); + fatal, &c__6, &c_true); same = lde_(cc, ct, &n); if (! same || err != 0.) { printf("ERROR IN DMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); @@ -629,7 +620,7 @@ static logical c_false = FALSE_; *(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); + fatal, &c__6, &c_true); same = lde_(cc, ct, &n); if (! same || err != 0.) { printf("ERROR IN DMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); @@ -642,23 +633,29 @@ static logical c_false = FALSE_; *(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); + fatal, &c__6, &c_true); 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); } /* Test each subroutine in turn. */ - for (isnum = 1; isnum <= 6; ++isnum) { + for (isnum = 1; isnum <= 7; ++isnum) { if (! ltest[isnum - 1]) { /* Subprogram is not to be tested. */ - printf("%12s WAS NOT TESTED\n",snames[isnum-1]); + printf("%13s WAS NOT TESTED\n",snames[isnum-1]); } else { - s_copy(srnamc_1.srnamt, snames[isnum - 1], (ftnlen)12, ( - ftnlen)12); + s_copy(srnamc_1.srnamt, snames[isnum - 1], (ftnlen)13, ( + ftnlen)13); /* Test error exits. */ if (tsterr) { - cd3chke_(snames[isnum - 1], (ftnlen)12); + cd3chke_(snames[isnum - 1]); } /* Test computations. */ infoc_1.infot = 0; @@ -671,6 +668,7 @@ static logical c_false = FALSE_; case 4: goto L160; case 5: goto L170; case 6: goto L180; + case 7: goto L185; } /* Test DGEMM, 01. */ L140: @@ -678,13 +676,13 @@ static logical c_false = FALSE_; 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); + cc, cs, ct, g, &c__0); } 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); + cc, cs, ct, g, &c__1); } goto L190; /* Test DSYMM, 02. */ @@ -693,13 +691,13 @@ static logical c_false = FALSE_; 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); + cc, cs, ct, g, &c__0); } 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); + cc, cs, ct, g, &c__1); } goto L190; /* Test DTRMM, 03, DTRSM, 04. */ @@ -708,13 +706,13 @@ static logical c_false = FALSE_; 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); + c__0); } 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); + c__1); } goto L190; /* Test DSYRK, 05. */ @@ -723,13 +721,13 @@ static logical c_false = FALSE_; 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); + cc, cs, ct, g, &c__0); } 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); + cc, cs, ct, g, &c__1); } goto L190; /* Test DSYR2K, 06. */ @@ -738,13 +736,28 @@ static logical c_false = FALSE_; 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); + ct, g, w, &c__0); } 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); + ct, g, w, &c__1); + } + goto L190; +/* Test DGEMMTR, 07. */ +L185: + if (corder) { + dchk6_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, + ct, g, w, &c__0); + } + if (rorder) { + dchk6_(snames[isnum - 1], &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; @@ -781,9 +794,16 @@ static logical c_false = FALSE_; /* 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, ftnlen sname_len) +/* 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 */ @@ -799,17 +819,17 @@ static logical c_false = FALSE_; 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); + extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*); static doublereal alpha; - extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); + extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*); static logical isame[13], trana, tranb; static integer nargs; static logical reset; - extern /* Subroutine */ void dprcn1_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, integer*, doublereal*, integer*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ void dprcn1_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, integer*, doublereal*, integer*, integer*, doublereal*, integer*); static integer ia, ib, ma, mb, na, nb, nc, ik, im, in; - extern /* Subroutine */ void cdgemm_(integer*, char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen); + extern /* Subroutine */ void cdgemm_(integer*, char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*); static integer ks, ms, ns; - extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen); + extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*); static char tranas[1], tranbs[1], transa[1], transb[1]; static doublereal errmax; static integer ica, icb, laa, lbb, lda, lcc, ldb, ldc; @@ -826,17 +846,6 @@ static logical c_false = FALSE_; /* 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; @@ -846,21 +855,20 @@ static logical c_false = FALSE_; --cs; --cc; c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; + c_offset = 1 + c_dim1; c__ -= c_offset; --bs; --bb; b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; + b_offset = 1 + b_dim1; b -= b_offset; --as; --aa; a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; /* Function Body */ -/* .. Executable Statements .. */ nargs = 13; nc = 0; @@ -917,8 +925,7 @@ static logical c_false = FALSE_; /* Generate the matrix A. */ dmake_("GE", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[ - 1], &lda, &reset, &c_b104, (ftnlen)2, (ftnlen)1, ( - ftnlen)1); + 1], &lda, &reset, &c_b104); for (icb = 1; icb <= 3; ++icb) { *(unsigned char *)transb = *(unsigned char *)&ich[icb @@ -947,8 +954,7 @@ static logical c_false = FALSE_; /* Generate the matrix B. */ dmake_("GE", " ", " ", &mb, &nb, &b[b_offset], nmax, & - bb[1], &ldb, &reset, &c_b104, (ftnlen)2, ( - ftnlen)1, (ftnlen)1); + bb[1], &ldb, &reset, &c_b104); i__4 = *nalf; for (ia = 1; ia <= i__4; ++ia) { @@ -961,8 +967,7 @@ static logical c_false = FALSE_; /* Generate the matrix C. */ dmake_("GE", " ", " ", &m, &n, &c__[c_offset], - nmax, &cc[1], &ldc, &reset, &c_b104, - (ftnlen)2, (ftnlen)1, (ftnlen)1); + nmax, &cc[1], &ldc, &reset, &c_b104); ++nc; @@ -1002,8 +1007,7 @@ static logical c_false = FALSE_; if (*trace) { dprcn1_(ntra, &nc, sname, iorder, transa, transb, &m, &n, &k, &alpha, &lda, - &ldb, &beta, &ldc, (ftnlen)12, ( - ftnlen)1, (ftnlen)1); + &ldb, &beta, &ldc); } if (*rewi) { /* al__1.aerr = 0; @@ -1012,8 +1016,7 @@ static logical c_false = FALSE_; } cdgemm_(iorder, transa, transb, &m, &n, &k, & alpha, &aa[1], &lda, &bb[1], &ldb, & - beta, &cc[1], &ldc, (ftnlen)1, ( - ftnlen)1); + beta, &cc[1], &ldc); /* Check if error-exit was taken incorrectly. */ @@ -1042,8 +1045,7 @@ static logical c_false = FALSE_; isame[11] = lde_(&cs[1], &cc[1], &lcc); } else { isame[11] = lderes_("GE", " ", &m, &n, & - cs[1], &cc[1], &ldc, (ftnlen)2, ( - ftnlen)1); + cs[1], &cc[1], &ldc); } isame[12] = ldcs == ldc; @@ -1072,8 +1074,7 @@ static logical c_false = FALSE_; &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); + eps, &err, fatal, nout, &c_true); errmax = f2cmax(errmax,err); /* If got really bad answer, report and */ /* return. */ @@ -1130,20 +1131,21 @@ static logical c_false = FALSE_; 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); + lda, &ldb, &beta, &ldc); L130: return 0; -/* 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',', */ -/* $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ', */ -/* $ 'C,', I3, ').' ) */ +/* L9995: */ /* 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) +/* 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) { /* Local variables */ @@ -1173,7 +1175,13 @@ static logical c_false = FALSE_; } /* 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) +/* 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 */ @@ -1193,18 +1201,18 @@ static logical c_false = FALSE_; 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); + extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*); static doublereal alpha; - extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); + extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*); static logical isame[13]; static char sides[1]; static integer nargs; static logical reset; static char uplos[1]; - extern /* Subroutine */ void dprcn2_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublereal*, integer*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ void dprcn2_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublereal*, integer*, integer*, doublereal*, integer*); static integer ia, ib, na, nc, im, in, ms, ns; - extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen); - extern /* Subroutine */ void cdsymm_(integer*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen); + extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*); + extern /* Subroutine */ void cdsymm_(integer*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*); static doublereal errmax; static integer laa, lbb, lda, lcc, ldb, ldc; extern logical lde_(doublereal*, doublereal*, integer*); @@ -1223,17 +1231,6 @@ static logical c_false = FALSE_; /* 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; @@ -1243,21 +1240,20 @@ static logical c_false = FALSE_; --cs; --cc; c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; + c_offset = 1 + c_dim1; c__ -= c_offset; --bs; --bb; b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; + b_offset = 1 + b_dim1; b -= b_offset; --as; --aa; a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; /* Function Body */ -/* .. Executable Statements .. */ nargs = 12; nc = 0; @@ -1297,7 +1293,7 @@ static logical c_false = FALSE_; /* Generate the matrix B. */ dmake_("GE", " ", " ", &m, &n, &b[b_offset], nmax, &bb[1], &ldb, & - reset, &c_b104, (ftnlen)2, (ftnlen)1, (ftnlen)1); + reset, &c_b104); for (ics = 1; ics <= 2; ++ics) { *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1]; @@ -1325,8 +1321,7 @@ static logical c_false = FALSE_; /* 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); + 1], &lda, &reset, &c_b104); i__3 = *nalf; for (ia = 1; ia <= i__3; ++ia) { @@ -1339,8 +1334,7 @@ static logical c_false = FALSE_; /* Generate the matrix C. */ dmake_("GE", " ", " ", &m, &n, &c__[c_offset], - nmax, &cc[1], &ldc, &reset, &c_b104, ( - ftnlen)2, (ftnlen)1, (ftnlen)1); + nmax, &cc[1], &ldc, &reset, &c_b104); ++nc; @@ -1377,7 +1371,7 @@ static logical c_false = FALSE_; if (*trace) { dprcn2_(ntra, &nc, sname, iorder, side, uplo, &m, &n, &alpha, &lda, &ldb, &beta, & - ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1) + ldc) ; } if (*rewi) { @@ -1386,8 +1380,7 @@ static logical c_false = FALSE_; 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); + , &lda, &bb[1], &ldb, &beta, &cc[1], &ldc); /* Check if error-exit was taken incorrectly. */ @@ -1415,7 +1408,7 @@ static logical c_false = FALSE_; isame[10] = lde_(&cs[1], &cc[1], &lcc); } else { isame[10] = lderes_("GE", " ", &m, &n, &cs[1], - &cc[1], &ldc, (ftnlen)2, (ftnlen)1); + &cc[1], &ldc); } isame[11] = ldcs == ldc; @@ -1445,15 +1438,13 @@ static logical c_false = FALSE_; 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); + &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, ( - ftnlen)1, (ftnlen)1); + &err, fatal, nout, &c_true); } errmax = f2cmax(errmax,err); /* If got really bad answer, report and */ @@ -1507,21 +1498,21 @@ static logical c_false = FALSE_; 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); + &beta, &ldc); L120: return 0; -/* 9995 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ -/* $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', */ -/* $ ' .' ) */ +/* L9995: */ /* 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) +/* 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) { /* Local variables */ @@ -1547,7 +1538,12 @@ static logical c_false = FALSE_; } /* 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) +/* 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 */ @@ -1568,21 +1564,21 @@ static logical c_false = FALSE_; 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); + extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*); static doublereal alpha; static char diags[1]; - extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); + extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*); static logical isame[13]; static char sides[1]; static integer nargs; static logical reset; static char uplos[1]; - extern /* Subroutine */ void dprcn3_(integer*, integer*, char*, integer*, char*, char*, char*, char*, integer*, integer*, doublereal*, integer*, integer*, ftnlen, ftnlen, ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ void dprcn3_(integer*, integer*, char*, integer*, char*, char*, char*, char*, integer*, integer*, doublereal*, integer*, integer*); static integer ia, na, nc, im, in, ms, ns; - extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen); - extern /* Subroutine */ void cdtrmm_(integer*, char*, char*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen, ftnlen); + extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*); + extern /* Subroutine */ void cdtrmm_(integer*, char*, char*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*); static char tranas[1], transa[1]; - extern /* Subroutine */ void cdtrsm_(integer*, char*, char*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ void cdtrsm_(integer*, char*, char*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*); static doublereal errmax; static integer laa, icd, lbb, lda, ldb; extern logical lde_(doublereal*, doublereal*, integer*); @@ -1601,38 +1597,26 @@ static logical c_false = FALSE_; /* 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_offset = 1 + c_dim1; c__ -= c_offset; --g; --ct; --bs; --bb; b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; + b_offset = 1 + b_dim1; b -= b_offset; --as; --aa; a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; /* Function Body */ -/* .. Executable Statements .. */ nargs = 11; nc = 0; @@ -1706,14 +1690,12 @@ static logical c_false = FALSE_; dmake_("TR", uplo, diag, &na, &na, &a[ a_offset], nmax, &aa[1], &lda, &reset, - &c_b104, (ftnlen)2, (ftnlen)1, ( - ftnlen)1); + &c_b104); /* Generate the matrix B. */ dmake_("GE", " ", " ", &m, &n, &b[b_offset], - nmax, &bb[1], &ldb, &reset, &c_b104, ( - ftnlen)2, (ftnlen)1, (ftnlen)1); + nmax, &bb[1], &ldb, &reset, &c_b104); ++nc; @@ -1751,9 +1733,7 @@ static logical c_false = FALSE_; 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); + &n, &alpha, &lda, &ldb); } if (*rewi) { /* al__1.aerr = 0; @@ -1762,16 +1742,13 @@ static logical c_false = FALSE_; } cdtrmm_(iorder, side, uplo, transa, diag, &m, &n, &alpha, &aa[1], &lda, &bb[ - 1], &ldb, (ftnlen)1, (ftnlen)1, ( - ftnlen)1, (ftnlen)1); + 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)12, (ftnlen)1, (ftnlen) - 1, (ftnlen)1, (ftnlen)1); + &n, &alpha, &lda, &ldb); } if (*rewi) { /* al__1.aerr = 0; @@ -1780,8 +1757,7 @@ static logical c_false = FALSE_; } cdtrsm_(iorder, side, uplo, transa, diag, &m, &n, &alpha, &aa[1], &lda, &bb[ - 1], &ldb, (ftnlen)1, (ftnlen)1, ( - ftnlen)1, (ftnlen)1); + 1], &ldb); } /* Check if error-exit was taken incorrectly. */ @@ -1811,8 +1787,7 @@ static logical c_false = FALSE_; isame[9] = lde_(&bs[1], &bb[1], &lbb); } else { isame[9] = lderes_("GE", " ", &m, &n, &bs[ - 1], &bb[1], &ldb, (ftnlen)2, ( - ftnlen)1); + 1], &bb[1], &ldb); } isame[10] = ldbs == ldb; @@ -1846,8 +1821,7 @@ static logical c_false = FALSE_; c_b104, &c__[c_offset], nmax, &ct[1], &g[1], &bb[ 1], &ldb, eps, &err, - fatal, nout, &c_true, ( - ftnlen)1, (ftnlen)1); + fatal, nout, &c_true); } else { dmmch_("N", transa, &m, &n, &n, & alpha, &b[b_offset], nmax, @@ -1855,8 +1829,7 @@ static logical c_false = FALSE_; c_b104, &c__[c_offset], nmax, &ct[1], &g[1], &bb[ 1], &ldb, eps, &err, - fatal, nout, &c_true, ( - ftnlen)1, (ftnlen)1); + fatal, nout, &c_true); } } else if (s_cmp(sname + 9, "sm", (ftnlen) 2, (ftnlen)2) == 0) { @@ -1884,8 +1857,7 @@ static logical c_false = FALSE_; c_b104, &b[b_offset], nmax, &ct[1], &g[1], &bb[ 1], &ldb, eps, &err, - fatal, nout, &c_false, ( - ftnlen)1, (ftnlen)1); + fatal, nout, &c_false); } else { dmmch_("N", transa, &m, &n, &n, & c_b90, &c__[c_offset], @@ -1893,8 +1865,7 @@ static logical c_false = FALSE_; &c_b104, &b[b_offset], nmax, &ct[1], &g[1], &bb[ 1], &ldb, eps, &err, - fatal, nout, &c_false, ( - ftnlen)1, (ftnlen)1); + fatal, nout, &c_false); } } errmax = f2cmax(errmax,err); @@ -1952,22 +1923,22 @@ static logical c_false = FALSE_; 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); + alpha, &lda, &ldb); } L160: return 0; -/* 9995 FORMAT( 1X, I6, ': ', A12,'(', 4( '''', A1, ''',' ), 2( I3, ',' ), */ -/* $ F4.1, ', A,', I3, ', B,', I3, ') .' ) */ +/* L9995: */ /* 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) +/* 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) { /* Local variables */ @@ -2005,7 +1976,13 @@ static logical c_false = FALSE_; } /* 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) +/* 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 */ @@ -2025,20 +2002,20 @@ static logical c_false = FALSE_; 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); + extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*); static doublereal alpha; - extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); + extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*); static logical isame[13]; static integer nargs; static logical reset; static char trans[1]; static logical upper; static char uplos[1]; - extern /* Subroutine */ void dprcn4_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ void dprcn4_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*); static integer ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns; - extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen); + extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*); static doublereal errmax; - extern /* Subroutine */ void cdsyrk_(integer*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen); + extern /* Subroutine */ void cdsyrk_(integer*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, integer*); static char transs[1]; static integer laa, lda, lcc, ldc; extern logical lde_(doublereal*, doublereal*, integer*); @@ -2056,17 +2033,6 @@ static logical c_false = FALSE_; /* 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; @@ -2076,21 +2042,20 @@ static logical c_false = FALSE_; --cs; --cc; c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; + c_offset = 1 + c_dim1; c__ -= c_offset; --bs; --bb; b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; + b_offset = 1 + b_dim1; b -= b_offset; --as; --aa; a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; /* Function Body */ -/* .. Executable Statements .. */ nargs = 10; nc = 0; @@ -2141,7 +2106,7 @@ static logical c_false = FALSE_; /* Generate the matrix A. */ dmake_("GE", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[1], & - lda, &reset, &c_b104, (ftnlen)2, (ftnlen)1, (ftnlen)1) + lda, &reset, &c_b104) ; for (icu = 1; icu <= 2; ++icu) { @@ -2159,8 +2124,7 @@ static logical c_false = FALSE_; /* 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); + nmax, &cc[1], &ldc, &reset, &c_b104); ++nc; @@ -2190,8 +2154,7 @@ static logical c_false = FALSE_; if (*trace) { dprcn4_(ntra, &nc, sname, iorder, uplo, trans, - &n, &k, &alpha, &lda, &beta, &ldc, ( - ftnlen)12, (ftnlen)1, (ftnlen)1); + &n, &k, &alpha, &lda, &beta, &ldc); } if (*rewi) { /* al__1.aerr = 0; @@ -2199,8 +2162,7 @@ static logical c_false = FALSE_; f_rew(&al__1);*/ } cdsyrk_(iorder, uplo, trans, &n, &k, &alpha, &aa[ - 1], &lda, &beta, &cc[1], &ldc, (ftnlen)1, - (ftnlen)1); + 1], &lda, &beta, &cc[1], &ldc); /* Check if error-exit was taken incorrectly. */ @@ -2226,7 +2188,7 @@ static logical c_false = FALSE_; 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); + &cc[1], &ldc); } isame[9] = ldcs == ldc; @@ -2268,8 +2230,7 @@ static logical c_false = FALSE_; 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); + fatal, nout, &c_true); } else { dmmch_("N", "T", &lj, &c__1, &k, & alpha, &a[jj + a_dim1], nmax, @@ -2277,7 +2238,7 @@ static logical c_false = FALSE_; c__[jj + j * c_dim1], nmax, & ct[1], &g[1], &cc[jc], &ldc, eps, &err, fatal, nout, & - c_true, (ftnlen)1, (ftnlen)1); + c_true); } if (upper) { jc += ldc; @@ -2343,20 +2304,21 @@ static logical c_false = FALSE_; 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); + beta, &ldc); L130: return 0; -/* 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ -/* $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' ) */ +/* L9994: */ /* 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) +/* 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) { /* Local variables */ @@ -2384,7 +2346,13 @@ static logical c_false = FALSE_; } /* 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) +/* 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 */ @@ -2404,23 +2372,23 @@ static logical c_false = FALSE_; 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); + extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*); static doublereal alpha; - extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); + extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*); static logical isame[13]; static integer nargs; static logical reset; static char trans[1]; static logical upper; static char uplos[1]; - extern /* Subroutine */ void dprcn5_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublereal*, integer*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ void dprcn5_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublereal*, integer*, integer*, doublereal*, integer*); static integer ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns; - extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen); + extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*); static doublereal errmax; static char transs[1]; static integer laa, lbb, lda, lcc, ldb, ldc; extern logical lde_(doublereal*, doublereal*, integer*); - extern /* Subroutine */ void cdsyr2k_(integer*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen); + extern /* Subroutine */ void cdsyr2k_(integer*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*); static doublereal als; static integer ict, icu; static doublereal err; @@ -2435,17 +2403,6 @@ static logical c_false = FALSE_; /* 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; @@ -2456,7 +2413,7 @@ static logical c_false = FALSE_; --cs; --cc; c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; + c_offset = 1 + c_dim1; c__ -= c_offset; --bs; --bb; @@ -2465,7 +2422,6 @@ static logical c_false = FALSE_; --ab; /* Function Body */ -/* .. Executable Statements .. */ nargs = 12; nc = 0; @@ -2518,12 +2474,10 @@ static logical c_false = FALSE_; if (tran) { i__3 = *nmax << 1; dmake_("GE", " ", " ", &ma, &na, &ab[1], &i__3, &aa[1], & - lda, &reset, &c_b104, (ftnlen)2, (ftnlen)1, ( - ftnlen)1); + lda, &reset, &c_b104); } else { dmake_("GE", " ", " ", &ma, &na, &ab[1], nmax, &aa[1], & - lda, &reset, &c_b104, (ftnlen)2, (ftnlen)1, ( - ftnlen)1); + lda, &reset, &c_b104); } /* Generate the matrix B. */ @@ -2533,12 +2487,10 @@ static logical c_false = FALSE_; if (tran) { i__3 = *nmax << 1; dmake_("GE", " ", " ", &ma, &na, &ab[k + 1], &i__3, &bb[1] - , &ldb, &reset, &c_b104, (ftnlen)2, (ftnlen)1, ( - ftnlen)1); + , &ldb, &reset, &c_b104); } else { dmake_("GE", " ", " ", &ma, &na, &ab[k * *nmax + 1], nmax, - &bb[1], &ldb, &reset, &c_b104, (ftnlen)2, ( - ftnlen)1, (ftnlen)1); + &bb[1], &ldb, &reset, &c_b104); } for (icu = 1; icu <= 2; ++icu) { @@ -2556,8 +2508,7 @@ static logical c_false = FALSE_; /* 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); + nmax, &cc[1], &ldc, &reset, &c_b104); ++nc; @@ -2594,7 +2545,7 @@ static logical c_false = FALSE_; if (*trace) { dprcn5_(ntra, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &ldb, &beta, & - ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1) + ldc) ; } if (*rewi) { @@ -2604,7 +2555,7 @@ static logical c_false = FALSE_; } cdsyr2k_(iorder, uplo, trans, &n, &k, &alpha, &aa[ 1], &lda, &bb[1], &ldb, &beta, &cc[1], & - ldc, (ftnlen)1, (ftnlen)1); + ldc); /* Check if error-exit was taken incorrectly. */ @@ -2632,7 +2583,7 @@ static logical c_false = FALSE_; isame[10] = lde_(&cs[1], &cc[1], &lcc); } else { isame[10] = lderes_("SY", uplo, &n, &n, &cs[1] - , &cc[1], &ldc, (ftnlen)2, (ftnlen)1); + , &cc[1], &ldc); } isame[11] = ldcs == ldc; @@ -2685,8 +2636,7 @@ static logical c_false = FALSE_; , &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); + fatal, nout, &c_true); } else { i__6 = k; for (i__ = 1; i__ <= i__6; ++i__) { @@ -2703,8 +2653,7 @@ static logical c_false = FALSE_; 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); + fatal, nout, &c_true); } if (upper) { jc += ldc; @@ -2773,21 +2722,21 @@ static logical c_false = FALSE_; 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); + &beta, &ldc); L160: return 0; -/* 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ -/* $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', */ -/* $ ' .' ) */ +/* L9994: */ /* 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) +/* 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) { /* Local variables */ @@ -2815,7 +2764,9 @@ static logical c_false = FALSE_; } /* 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) +/* 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; @@ -2842,15 +2793,9 @@ static logical c_false = FALSE_; /* 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_offset = 1 + a_dim1; a -= a_offset; --aa; @@ -2953,7 +2898,12 @@ static logical c_false = FALSE_; } /* dmake_ */ -/* Subroutine */ int dmmch_(char* transa, char* transb, integer* m, integer* n, integer* kk, doublereal* alpha, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* beta, doublereal* c__, integer* ldc, doublereal* ct, doublereal* g, doublereal* cc, integer* ldcc, doublereal* eps, doublereal* err, logical* fatal, integer* nout, logical* mv, ftnlen transa_len, ftnlen transb_len) +/* 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) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, cc_dim1, @@ -2978,26 +2928,20 @@ static logical c_false = FALSE_; /* 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_offset = 1 + a_dim1; a -= a_offset; b_dim1 = *ldb; - b_offset = 1 + b_dim1 * 1; + b_offset = 1 + b_dim1; b -= b_offset; c_dim1 = *ldc; - c_offset = 1 + c_dim1 * 1; + c_offset = 1 + c_dim1; c__ -= c_offset; --ct; --g; cc_dim1 = *ldcc; - cc_offset = 1 + cc_dim1 * 1; + cc_offset = 1 + cc_dim1; cc -= cc_offset; /* Function Body */ @@ -3145,10 +3089,6 @@ logical lde_(doublereal* ri, doublereal* rj, integer* lr) /* 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; @@ -3172,7 +3112,8 @@ logical lde_(doublereal* ri, doublereal* rj, integer* lr) } /* lde_ */ -logical lderes_(char* type__, char* uplo, integer* m, integer* n, doublereal* aa, doublereal* as, integer* lda, ftnlen type_len, ftnlen uplo_len) +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; @@ -3195,16 +3136,12 @@ logical lderes_(char* type__, char* uplo, integer* m, integer* n, doublereal* aa /* 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_offset = 1 + as_dim1; as -= as_offset; aa_dim1 = *lda; - aa_offset = 1 + aa_dim1 * 1; + aa_offset = 1 + aa_dim1; aa -= aa_offset; /* Function Body */ @@ -3249,7 +3186,7 @@ logical lderes_(char* type__, char* uplo, integer* m, integer* n, doublereal* aa } } -/* 60 CONTINUE */ +/* L60: */ ret_val = TRUE_; goto L80; L70: @@ -3280,10 +3217,6 @@ doublereal dbeg_(logical* reset) /* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ /* Sven Hammarling, Numerical Algorithms Group Ltd. */ -/* .. Scalar Arguments .. */ -/* .. Local Scalars .. */ -/* .. Save statement .. */ -/* .. Executable Statements .. */ if (*reset) { /* Initialize local variables. */ mi = 891; @@ -3327,8 +3260,6 @@ doublereal ddiff_(doublereal* x, doublereal* y) /* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ /* Sven Hammarling, Numerical Algorithms Group Ltd. */ -/* .. Scalar Arguments .. */ -/* .. Executable Statements .. */ ret_val = *x - *y; return ret_val; @@ -3336,4 +3267,569 @@ doublereal ddiff_(doublereal* x, doublereal* y) } /* ddiff_ */ -/* Main program alias */ /*int dblat3_ () { MAIN__ (); }*/ +/* 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"; + + /* 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 */ + 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 */ void dprcn8_(integer *, integer *, char *, integer + *, char *, char *, char *, integer *, integer *, doublereal *, + integer *, integer *, doublereal *, integer *); + extern int dmmtch_(char *, char *, char *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, doublereal *, + logical *, integer *, logical *); + extern logical lderes_(char *, char *, integer *, integer *, doublereal *, + doublereal *, integer *); + char tranas[1], tranbs[1], transa[1], transb[1]; + doublereal errmax; + +/* 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); + } + 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_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 *)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]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* 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) { + 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); + 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 */ void dprcn8_(integer *nout, integer *nc, char *sname, integer + *iorder, char *uplo, char *transa, char *transb, integer *n, integer * + k, doublereal *alpha, integer *lda, integer *ldb, doublereal *beta, + integer *ldc) +{ + /* Local variables */ + char crc[14], cta[14], ctb[14], cuplo[14]; + + + + 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); + } + printf("%6d: %s %s %s %s %s\n",*nc,sname,crc,cuplo,cta,ctb); + printf("%d %d %4.1f A, %d, B, %d, %4.1f, C, %d.\n",*n,*k,*alpha,*lda,*ldb,*beta,*ldc); +} /* dprcn8_ */ + +/* Subroutine */ int dmmtch_(char *uplo, char *transa, char *transb, integer * + 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) +{ + /* 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; + + +/* 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_; + printf(" ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HALF ACCURATE *******\n"); + printf(" EXPECTED RESULT COMPUTED RESULT\n"); + + for (i__ = 1; i__ <= i__1; ++i__) { + if (*mv) { + printf("%7d %15.6g %15.6g\n",i__,ct[i__],cc[i__+j*cc_dim1]); + } else { + printf("%7d %15.6g %15.6g\n",i__,cc[i__+j*cc_dim1],ct[i__]); + } + +/* L140: */ + } + if (*n > 1) { + printf(" THESE ARE THE RESULTS FOR COLUMN %d\n",j); + } + +L150: + return(0); + +/* End of DMMTCH */ + +} /* dmmtch_ */ + diff --git a/ctest/c_s3chke.c b/ctest/c_s3chke.c index 632eaae30e..ae7bee6313 100644 --- a/ctest/c_s3chke.c +++ b/ctest/c_s3chke.c @@ -43,7 +43,237 @@ void F77_s3chke(char *rout) { cblas_ok = TRUE ; cblas_lerr = PASSED ; - if (strncmp( sf,"cblas_sgemm" ,11)==0) { + if (strncmp( sf,"cblas_sgemmtr" ,13)==0) { + cblas_rout = "cblas_sgemmtr" ; + + cblas_info = 1; + cblas_sgemmtr( INVALID, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_sgemmtr( INVALID, CblasUpper, CblasNoTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_sgemmtr( INVALID, CblasUpper,CblasTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_sgemmtr( INVALID, CblasUpper, CblasTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 1; + cblas_sgemmtr( INVALID, CblasLower, CblasNoTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_sgemmtr( INVALID, CblasLower, CblasNoTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_sgemmtr( INVALID, CblasLower,CblasTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_sgemmtr( INVALID, CblasLower, CblasTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 2; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, INVALID, CblasNoTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, INVALID, CblasNoTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 3; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, INVALID, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, INVALID, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 4; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + + cblas_info = 5; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 6; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + + cblas_info = 9; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 11; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 14; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + + cblas_info = 14; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + + /* Row Major */ + cblas_info = 5; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 6; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 9; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 11; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 14; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_sgemm" ,11)==0) { cblas_rout = "cblas_sgemm" ; cblas_info = 1; cblas_sgemm( INVALID, CblasNoTrans, CblasNoTrans, 0, 0, 0, diff --git a/ctest/c_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_sblat3c.c b/ctest/c_sblat3c.c index 402c58c8b5..85b5f05117 100644 --- a/ctest/c_sblat3c.c +++ b/ctest/c_sblat3c.c @@ -236,8 +236,6 @@ typedef struct Namelist Namelist; #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++ */ @@ -254,7 +252,7 @@ struct { #define infoc_1 infoc_ struct { - char srnamt[12]; + char srnamt[13]; } srnamc_; #define srnamc_1 srnamc_ @@ -270,11 +268,11 @@ static logical c_true = TRUE_; static integer c__0 = 0; static logical c_false = FALSE_; -/* Main program MAIN__() */ int main(void) +/* Main program */ int main(void) { /* Initialized data */ - static char snames[6][13] = {"cblas_sgemm ", "cblas_ssymm ", "cblas_strmm ", "cblas_strsm ", "cblas_ssyrk ", "cblas_ssyr2k"}; + static char snames[7][14] = {"cblas_sgemm ", "cblas_ssymm ", "cblas_strmm ", "cblas_strsm ", "cblas_ssyrk ", "cblas_ssyr2k ", "cblas_sgemmtr"}; /* System generated locals */ integer i__1, i__2, i__3; @@ -285,22 +283,23 @@ static logical c_false = FALSE_; 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); + extern /* Subroutine */ int schk1_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, real*, integer*, real*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*); + extern /* Subroutine */ int schk2_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, real*, integer*, real*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*); + extern /* Subroutine */ int schk3_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, real*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*); + extern /* Subroutine */ int schk4_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, real*, integer*, real*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*); + extern /* Subroutine */ int schk5_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, real*, integer*, real*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*); + extern /* Subroutine */ int schk6_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, real*, integer*, real*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*); static real c__[4225] /* was [65][65] */, g[65]; static integer i__, j, n; static logical fatal; static real w[130]; - extern doublereal sdiff_(real*, real*); + extern real sdiff_(real*, real*); static logical trace; static integer nidim; - extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*, 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*); static char snaps[32]; static integer isnum; - static logical ltest[6]; + static logical ltest[7]; static real aa[4225], ab[8450] /* was [65][130] */, bb[4225], cc[ 4225], as[4225], bs[4225], cs[4225], ct[65]; static logical sfatal, corder; @@ -309,7 +308,7 @@ static logical c_false = FALSE_; static logical rorder; static integer layout; static logical ltestt, tsterr; - extern /* Subroutine */ void cs3chke_(char*, ftnlen); + extern /* Subroutine */ void cs3chke_(char*); static real alf[7], bet[7]; extern logical lse_(real*, real*, integer*); static real eps, err; @@ -319,14 +318,14 @@ static logical c_false = FALSE_; /* 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 STOP ON FAILURES. */ -/* T LOGICAL FLAG, T TO TEST ERROR EXITS. */ +/* 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 */ @@ -335,12 +334,13 @@ static logical c_false = FALSE_; /* 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: */ @@ -357,16 +357,6 @@ static logical c_false = FALSE_; /* 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. */ @@ -508,7 +498,7 @@ static logical c_false = FALSE_; /* Read names of subroutines and flags which indicate */ /* whether they are to be tested. */ - for (i__ = 1; i__ <= 6; ++i__) { + for (i__ = 1; i__ <= 7; ++i__) { ltest[i__ - 1] = FALSE_; /* L20: */ } @@ -516,7 +506,7 @@ static logical c_false = FALSE_; if (! fgets(line,80,stdin)) { goto L60; } - i__1 = sscanf(line,"%12c %c",snamet,&tmpchar); + i__1 = sscanf(line,"%13c %c",snamet,&tmpchar); ltestt=FALSE_; if (tmpchar=='T')ltestt=TRUE_; if (i__1 < 2) { @@ -582,7 +572,7 @@ static logical c_false = FALSE_; *(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); + fatal, &c__6, &c_true); same = lse_(cc, ct, &n); if (! same || err != (float)0.) { printf("ERROR IN SMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); @@ -595,7 +585,7 @@ static logical c_false = FALSE_; *(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); + fatal, &c__6, &c_true); same = lse_(cc, ct, &n); if (! same || err != (float)0.) { printf("ERROR IN SMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); @@ -621,7 +611,7 @@ static logical c_false = FALSE_; *(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); + fatal, &c__6, &c_true); same = lse_(cc, ct, &n); if (! same || err != (float)0.) { printf("ERROR IN SMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); @@ -634,7 +624,7 @@ static logical c_false = FALSE_; *(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); + fatal, &c__6, &c_true); same = lse_(cc, ct, &n); if (! same || err != (float)0.) { printf("ERROR IN SMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); @@ -647,16 +637,16 @@ static logical c_false = FALSE_; /* Test each subroutine in turn. */ - for (isnum = 1; isnum <= 6; ++isnum) { + for (isnum = 1; isnum <= 7; ++isnum) { if (! ltest[isnum - 1]) { /* Subprogram is not to be tested. */ - printf("%12s WAS NOT TESTED\n",snames[isnum-1]); + printf("%13s WAS NOT TESTED\n",snames[isnum-1]); } else { - s_copy(srnamc_1.srnamt, snames[isnum - 1], (ftnlen)12, ( - ftnlen)12); + s_copy(srnamc_1.srnamt, snames[isnum - 1], (ftnlen)13, ( + ftnlen)13); /* Test error exits. */ if (tsterr) { - cs3chke_(snames[isnum - 1], (ftnlen)12); + cs3chke_(snames[isnum - 1]); } /* Test computations. */ infoc_1.infot = 0; @@ -669,6 +659,7 @@ static logical c_false = FALSE_; case 4: goto L160; case 5: goto L170; case 6: goto L180; + case 7: goto L185; } /* Test SGEMM, 01. */ L140: @@ -676,13 +667,13 @@ static logical c_false = FALSE_; 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); + cc, cs, ct, g, &c__0); } 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); + cc, cs, ct, g, &c__1); } goto L190; /* Test SSYMM, 02. */ @@ -691,13 +682,13 @@ static logical c_false = FALSE_; 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); + cc, cs, ct, g, &c__0); } 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); + cc, cs, ct, g, &c__1); } goto L190; /* Test STRMM, 03, STRSM, 04. */ @@ -706,13 +697,13 @@ static logical c_false = FALSE_; 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); + c__0); } 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); + c__1); } goto L190; /* Test SSYRK, 05. */ @@ -721,13 +712,13 @@ static logical c_false = FALSE_; 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); + cc, cs, ct, g, &c__0); } 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); + cc, cs, ct, g, &c__1); } goto L190; /* Test SSYR2K, 06. */ @@ -736,13 +727,28 @@ static logical c_false = FALSE_; 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); + ct, g, w, &c__0); } 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); + ct, g, w, &c__1); + } + goto L190; +/* Test SGEMMTR, 07. */ +L185: + if (corder) { + schk6_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, + ct, g, w, &c__0); + } + if (rorder) { + schk6_(snames[isnum - 1], &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; @@ -775,7 +781,12 @@ static logical c_false = FALSE_; } /* 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) +/* 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 */ @@ -796,14 +807,14 @@ static logical c_false = FALSE_; 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); + extern /* Subroutine */ void sprcn1_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, integer*, real*, integer*, integer*, real*, integer*); + extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, logical*, real*); + extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*); static integer ia, ib, ma, mb, na, nb, nc, ik, im, in, ks, ms, ns; - extern /* Subroutine */ void csgemm_(integer*, char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, ftnlen, ftnlen); + extern /* Subroutine */ void csgemm_(integer*, char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*); static char tranas[1], tranbs[1], transa[1], transb[1]; static real errmax; - extern logical lseres_(char*, char*, integer*, integer*, real*, real*, integer*, ftnlen, ftnlen); + extern logical lseres_(char*, char*, integer*, integer*, real*, real*, integer*); extern logical lse_(real*, real*, integer*); static integer ica, icb, laa, lbb, lda, lcc, ldb, ldc; static real als, bls; @@ -819,17 +830,6 @@ static logical c_false = FALSE_; /* 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; @@ -839,26 +839,25 @@ static logical c_false = FALSE_; --cs; --cc; c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; + c_offset = 1 + c_dim1; c__ -= c_offset; --bs; --bb; b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; + b_offset = 1 + b_dim1; b -= b_offset; --as; --aa; a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; /* Function Body */ -/* .. Executable Statements .. */ nargs = 13; nc = 0; reset = TRUE_; - errmax = (float)0.; + errmax = 0.f; i__1 = *nidim; for (im = 1; im <= i__1; ++im) { @@ -910,8 +909,7 @@ static logical c_false = FALSE_; /* Generate the matrix A. */ smake_("GE", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[ - 1], &lda, &reset, &c_b103, (ftnlen)2, (ftnlen)1, ( - ftnlen)1); + 1], &lda, &reset, &c_b103); for (icb = 1; icb <= 3; ++icb) { *(unsigned char *)transb = *(unsigned char *)&ich[icb @@ -940,8 +938,7 @@ static logical c_false = FALSE_; /* Generate the matrix B. */ smake_("GE", " ", " ", &mb, &nb, &b[b_offset], nmax, & - bb[1], &ldb, &reset, &c_b103, (ftnlen)2, ( - ftnlen)1, (ftnlen)1); + bb[1], &ldb, &reset, &c_b103); i__4 = *nalf; for (ia = 1; ia <= i__4; ++ia) { @@ -954,8 +951,7 @@ static logical c_false = FALSE_; /* Generate the matrix C. */ smake_("GE", " ", " ", &m, &n, &c__[c_offset], - nmax, &cc[1], &ldc, &reset, &c_b103, - (ftnlen)2, (ftnlen)1, (ftnlen)1); + nmax, &cc[1], &ldc, &reset, &c_b103); ++nc; @@ -995,16 +991,14 @@ static logical c_false = FALSE_; if (*trace) { sprcn1_(ntra, &nc, sname, iorder, transa, transb, &m, &n, &k, &alpha, &lda, - &ldb, &beta, &ldc, (ftnlen)12, ( - ftnlen)1, (ftnlen)1); + &ldb, &beta, &ldc); } 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); + beta, &cc[1], &ldc); /* Check if error-exit was taken incorrectly. */ @@ -1033,8 +1027,7 @@ static logical c_false = FALSE_; isame[11] = lse_(&cs[1], &cc[1], &lcc); } else { isame[11] = lseres_("GE", " ", &m, &n, & - cs[1], &cc[1], &ldc, (ftnlen)2, ( - ftnlen)1); + cs[1], &cc[1], &ldc); } isame[12] = ldcs == ldc; @@ -1063,8 +1056,7 @@ static logical c_false = FALSE_; &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); + eps, &err, fatal, nout, &c_true); errmax = dmax(errmax,err); /* If got really bad answer, report and */ /* return. */ @@ -1121,14 +1113,12 @@ static logical c_false = FALSE_; 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); + lda, &ldb, &beta, &ldc); L130: return 0; -/* 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',', */ -/* $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ', */ -/* $ 'C,', I3, ').' ) */ +/* L9995: */ /* End of SCHK1. */ @@ -1137,7 +1127,9 @@ static logical c_false = FALSE_; -/* 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) +/* 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) { /* Local variables */ @@ -1168,7 +1160,12 @@ static logical c_false = FALSE_; } /* 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) +/* 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 */ @@ -1196,11 +1193,11 @@ static logical c_false = FALSE_; 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); + extern logical lseres_(char*, char*, integer*, integer*, real*, real*, integer*); + extern /* Subroutine */ void cssymm_(integer*, char*, char*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*); + extern void sprcn2_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, real*, integer*, integer*, real*, integer*); + extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, logical*, real*); + extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*); static integer laa, lbb, lda, lcc, ldb, ldc, ics; static real als, bls; static integer icu; @@ -1217,17 +1214,6 @@ static logical c_false = FALSE_; /* 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; @@ -1237,26 +1223,25 @@ static logical c_false = FALSE_; --cs; --cc; c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; + c_offset = 1 + c_dim1; c__ -= c_offset; --bs; --bb; b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; + b_offset = 1 + b_dim1; b -= b_offset; --as; --aa; a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; /* Function Body */ -/* .. Executable Statements .. */ nargs = 12; nc = 0; reset = TRUE_; - errmax = (float)0.; + errmax = 0.f; i__1 = *nidim; for (im = 1; im <= i__1; ++im) { @@ -1291,7 +1276,7 @@ static logical c_false = FALSE_; /* Generate the matrix B. */ smake_("GE", " ", " ", &m, &n, &b[b_offset], nmax, &bb[1], &ldb, & - reset, &c_b103, (ftnlen)2, (ftnlen)1, (ftnlen)1); + reset, &c_b103); for (ics = 1; ics <= 2; ++ics) { *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1]; @@ -1319,8 +1304,7 @@ static logical c_false = FALSE_; /* Generate the symmetric matrix A. */ smake_("SY", uplo, " ", &na, &na, &a[a_offset], nmax, &aa[ - 1], &lda, &reset, &c_b103, (ftnlen)2, (ftnlen)1, ( - ftnlen)1); + 1], &lda, &reset, &c_b103); i__3 = *nalf; for (ia = 1; ia <= i__3; ++ia) { @@ -1333,8 +1317,7 @@ static logical c_false = FALSE_; /* Generate the matrix C. */ smake_("GE", " ", " ", &m, &n, &c__[c_offset], - nmax, &cc[1], &ldc, &reset, &c_b103, ( - ftnlen)2, (ftnlen)1, (ftnlen)1); + nmax, &cc[1], &ldc, &reset, &c_b103); ++nc; @@ -1371,15 +1354,13 @@ static logical c_false = FALSE_; if (*trace) { sprcn2_(ntra, &nc, sname, iorder, side, uplo, &m, &n, &alpha, &lda, &ldb, &beta, & - ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1) - ; + ldc); } if (*rewi) { // f_rew(&al__1); } cssymm_(iorder, side, uplo, &m, &n, &alpha, &aa[1] - , &lda, &bb[1], &ldb, &beta, &cc[1], &ldc, - (ftnlen)1, (ftnlen)1); + , &lda, &bb[1], &ldb, &beta, &cc[1], &ldc); /* Check if error-exit was taken incorrectly. */ @@ -1407,7 +1388,7 @@ static logical c_false = FALSE_; isame[10] = lse_(&cs[1], &cc[1], &lcc); } else { isame[10] = lseres_("GE", " ", &m, &n, &cs[1], - &cc[1], &ldc, (ftnlen)2, (ftnlen)1); + &cc[1], &ldc); } isame[11] = ldcs == ldc; @@ -1437,15 +1418,13 @@ static logical c_false = FALSE_; 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); + &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, ( - ftnlen)1, (ftnlen)1); + &err, fatal, nout, &c_true); } errmax = dmax(errmax,err); /* If got really bad answer, report and */ @@ -1499,21 +1478,21 @@ static logical c_false = FALSE_; L110: printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); sprcn2_(nout, &nc, sname, iorder, side, uplo, &m, &n, &alpha, &lda, &ldb, - &beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); + &beta, &ldc); L120: return 0; -/* 9995 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ -/* $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', */ -/* $ ' .' ) */ +/* L9995: */ /* End of SCHK2. */ } /* schk2_ */ -/* Subroutine */ void sprcn2_(integer* nout, integer* nc, char* sname, integer* iorder, char* side, char* uplo, integer* m, integer* n, real* alpha, integer* lda, integer* ldb, real* beta, integer* ldc, ftnlen sname_len, ftnlen side_len, ftnlen uplo_len) +/* Subroutine */ void sprcn2_(integer *nout, integer *nc, char *sname, integer + *iorder, char *side, char *uplo, integer *m, integer *n, real *alpha, + integer *lda, integer *ldb, real *beta, integer *ldc) { /* Local variables */ @@ -1539,7 +1518,11 @@ static logical c_false = FALSE_; } /* sprcn2_ */ -/* Subroutine */ int schk3_(char* sname, real* eps, real* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, real* alf, integer* nmax, real* a, real* aa, real* as, real* b, real* bb, real* bs, real* ct, real* g, real* c__, integer* iorder, ftnlen sname_len) +/* 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 */ @@ -1568,15 +1551,15 @@ static logical c_false = FALSE_; static integer nargs; static logical reset; static char uplos[1]; - extern /* Subroutine */ void sprcn3_(integer*, integer*, char*, integer*, char*, char*, char*, char*, integer*, integer*, real*, integer*, integer*, ftnlen , ftnlen, ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ void sprcn3_(integer*, integer*, char*, integer*, char*, char*, char*, char*, integer*, integer*, real*, integer*, integer*); static integer ia, na, nc, im, in, ms, ns; static char tranas[1], transa[1]; static real errmax; - extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, logical*, real*, ftnlen, ftnlen, ftnlen); - extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*, ftnlen, ftnlen); - extern logical lseres_(char*, char*, integer*, integer*, real*, real*, integer*, ftnlen, ftnlen); - extern /* Subroutine */ void cstrmm_(integer*, char*, char*, char*, char*, integer*, integer*, real*, real*, integer*, real*, integer*, ftnlen, ftnlen, ftnlen, ftnlen); - extern /* Subroutine */ void cstrsm_(integer*, char*, char*, char*, char*, integer*, integer*, real*, real*, integer*, real*, integer*, ftnlen, ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, logical*, real*); + extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*); + extern logical lseres_(char*, char*, integer*, integer*, real*, real*, integer*); + extern /* Subroutine */ void cstrmm_(integer*, char*, char*, char*, char*, integer*, integer*, real*, real*, integer*, real*, integer*); + extern /* Subroutine */ void cstrsm_(integer*, char*, char*, char*, char*, integer*, integer*, real*, real*, integer*, real*, integer*); static integer laa, icd, lbb, lda, ldb, ics; static real als; static integer ict, icu; @@ -1593,49 +1576,37 @@ static logical c_false = FALSE_; /* 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_offset = 1 + c_dim1; c__ -= c_offset; --g; --ct; --bs; --bb; b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; + b_offset = 1 + b_dim1; b -= b_offset; --as; --aa; a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; /* Function Body */ -/* .. Executable Statements .. */ nargs = 11; nc = 0; reset = TRUE_; - errmax = (float)0.; + 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] = (float)0.; + c__[i__ + j * c_dim1] = 0.f; /* L10: */ } /* L20: */ @@ -1698,14 +1669,12 @@ static logical c_false = FALSE_; smake_("TR", uplo, diag, &na, &na, &a[ a_offset], nmax, &aa[1], &lda, &reset, - &c_b103, (ftnlen)2, (ftnlen)1, ( - ftnlen)1); + &c_b103); /* Generate the matrix B. */ smake_("GE", " ", " ", &m, &n, &b[b_offset], - nmax, &bb[1], &ldb, &reset, &c_b103, ( - ftnlen)2, (ftnlen)1, (ftnlen)1); + nmax, &bb[1], &ldb, &reset, &c_b103); ++nc; @@ -1743,33 +1712,27 @@ static logical c_false = FALSE_; if (*trace) { sprcn3_(ntra, &nc, sname, iorder, side, uplo, transa, diag, &m, - &n, &alpha, &lda, &ldb, ( - ftnlen)12, (ftnlen)1, (ftnlen) - 1, (ftnlen)1, (ftnlen)1); + &n, &alpha, &lda, &ldb); } if (*rewi) { // f_rew(&al__1); } cstrmm_(iorder, side, uplo, transa, diag, &m, &n, &alpha, &aa[1], &lda, &bb[ - 1], &ldb, (ftnlen)1, (ftnlen)1, ( - ftnlen)1, (ftnlen)1); + 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)12, (ftnlen)1, (ftnlen) - 1, (ftnlen)1, (ftnlen)1); + &n, &alpha, &lda, &ldb); } if (*rewi) { // f_rew(&al__1); } cstrsm_(iorder, side, uplo, transa, diag, &m, &n, &alpha, &aa[1], &lda, &bb[ - 1], &ldb, (ftnlen)1, (ftnlen)1, ( - ftnlen)1, (ftnlen)1); + 1], &ldb); } /* Check if error-exit was taken incorrectly. */ @@ -1799,8 +1762,7 @@ static logical c_false = FALSE_; isame[9] = lse_(&bs[1], &bb[1], &lbb); } else { isame[9] = lseres_("GE", " ", &m, &n, &bs[ - 1], &bb[1], &ldb, (ftnlen)2, ( - ftnlen)1); + 1], &bb[1], &ldb); } isame[10] = ldbs == ldb; @@ -1834,8 +1796,7 @@ static logical c_false = FALSE_; c_b103, &c__[c_offset], nmax, &ct[1], &g[1], &bb[ 1], &ldb, eps, &err, - fatal, nout, &c_true, ( - ftnlen)1, (ftnlen)1); + fatal, nout, &c_true); } else { smmch_("N", transa, &m, &n, &n, & alpha, &b[b_offset], nmax, @@ -1843,8 +1804,7 @@ static logical c_false = FALSE_; c_b103, &c__[c_offset], nmax, &ct[1], &g[1], &bb[ 1], &ldb, eps, &err, - fatal, nout, &c_true, ( - ftnlen)1, (ftnlen)1); + fatal, nout, &c_true); } } else if (s_cmp(sname + 9, "sm", (ftnlen) 2, (ftnlen)2) == 0) { @@ -1872,8 +1832,7 @@ static logical c_false = FALSE_; c_b103, &b[b_offset], nmax, &ct[1], &g[1], &bb[ 1], &ldb, eps, &err, - fatal, nout, &c_false, ( - ftnlen)1, (ftnlen)1); + fatal, nout, &c_false); } else { smmch_("N", transa, &m, &n, &n, & c_b89, &c__[c_offset], @@ -1881,8 +1840,7 @@ static logical c_false = FALSE_; &c_b103, &b[b_offset], nmax, &ct[1], &g[1], &bb[ 1], &ldb, eps, &err, - fatal, nout, &c_false, ( - ftnlen)1, (ftnlen)1); + fatal, nout, &c_false); } } errmax = dmax(errmax,err); @@ -1940,22 +1898,22 @@ static logical c_false = FALSE_; printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); if (*trace) { sprcn3_(ntra, &nc, sname, iorder, side, uplo, transa, diag, &m, &n, & - alpha, &lda, &ldb, (ftnlen)12, (ftnlen)1, (ftnlen)1, (ftnlen) - 1, (ftnlen)1); + alpha, &lda, &ldb); } L160: return 0; -/* 9995 FORMAT( 1X, I6, ': ', A12,'(', 4( '''', A1, ''',' ), 2( I3, ',' ), */ -/* $ F4.1, ', A,', I3, ', B,', I3, ') .' ) */ +/* L9995: */ /* End of SCHK3. */ } /* schk3_ */ -/* Subroutine */ void sprcn3_(integer* nout, integer* nc, char* sname, integer* iorder, char* side, char* uplo, char* transa, char* diag, integer* m, integer* n, real* alpha, integer* lda, integer* ldb, ftnlen sname_len, ftnlen side_len, ftnlen uplo_len, ftnlen transa_len, ftnlen diag_len) +/* Subroutine */ void sprcn3_(integer *nout, integer *nc, char *sname, integer + *iorder, char *side, char *uplo, char *transa, char *diag, integer *m, + integer *n, real *alpha, integer *lda, integer *ldb) { /* Local variables */ @@ -1994,7 +1952,12 @@ static logical c_false = FALSE_; } /* sprcn3_ */ -/* Subroutine */ int schk4_(char* sname, real* eps, real* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, real* alf, integer* nbet, real* bet, integer* nmax, real* a, real* aa, real* as, real* b, real* bb, real* bs, real* c__, real* cc, real* cs, real* ct, real* g, integer* iorder, ftnlen sname_len) +/* 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 */ @@ -2021,14 +1984,14 @@ static logical c_false = FALSE_; static char trans[1]; static logical upper; static char uplos[1]; - extern /* Subroutine */ void sprcn4_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, ftnlen, ftnlen, ftnlen); - extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, logical*, real*, ftnlen, ftnlen, ftnlen); - extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*, ftnlen, ftnlen); + extern /* Subroutine */ void sprcn4_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, real*, integer*, real*, integer*); + extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, logical*, real*); + extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*); static integer ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns; static real errmax; - extern logical lseres_(char*, char*, integer*, integer*, real*, real*, integer*, ftnlen, ftnlen); + extern logical lseres_(char*, char*, integer*, integer*, real*, real*, integer*); static char transs[1]; - extern /* Subroutine */ void cssyrk_(integer*, char*, char*, integer*, integer*, real*, real*, integer*, real*, real*, integer*, ftnlen, ftnlen); + extern /* Subroutine */ void cssyrk_(integer*, char*, char*, integer*, integer*, real*, real*, integer*, real*, real*, integer*); static integer laa, lda, lcc, ldc; static real als; static integer ict, icu; @@ -2045,17 +2008,6 @@ static logical c_false = FALSE_; /* 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; @@ -2065,26 +2017,25 @@ static logical c_false = FALSE_; --cs; --cc; c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; + c_offset = 1 + c_dim1; c__ -= c_offset; --bs; --bb; b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; + b_offset = 1 + b_dim1; b -= b_offset; --as; --aa; a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; /* Function Body */ -/* .. Executable Statements .. */ nargs = 10; nc = 0; reset = TRUE_; - errmax = (float)0.; + errmax = 0.f; i__1 = *nidim; for (in = 1; in <= i__1; ++in) { @@ -2130,7 +2081,7 @@ static logical c_false = FALSE_; /* Generate the matrix A. */ smake_("GE", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[1], & - lda, &reset, &c_b103, (ftnlen)2, (ftnlen)1, (ftnlen)1) + lda, &reset, &c_b103) ; for (icu = 1; icu <= 2; ++icu) { @@ -2148,8 +2099,7 @@ static logical c_false = FALSE_; /* 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); + nmax, &cc[1], &ldc, &reset, &c_b103); ++nc; @@ -2179,15 +2129,13 @@ static logical c_false = FALSE_; if (*trace) { sprcn4_(ntra, &nc, sname, iorder, uplo, trans, - &n, &k, &alpha, &lda, &beta, &ldc, ( - ftnlen)12, (ftnlen)1, (ftnlen)1); + &n, &k, &alpha, &lda, &beta, &ldc); } if (*rewi) { // f_rew(&al__1); } cssyrk_(iorder, uplo, trans, &n, &k, &alpha, &aa[ - 1], &lda, &beta, &cc[1], &ldc, (ftnlen)1, - (ftnlen)1); + 1], &lda, &beta, &cc[1], &ldc); /* Check if error-exit was taken incorrectly. */ @@ -2213,7 +2161,7 @@ static logical c_false = FALSE_; 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); + &cc[1], &ldc); } isame[9] = ldcs == ldc; @@ -2255,8 +2203,7 @@ static logical c_false = FALSE_; 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); + fatal, nout, &c_true); } else { smmch_("N", "T", &lj, &c__1, &k, & alpha, &a[jj + a_dim1], nmax, @@ -2264,7 +2211,7 @@ static logical c_false = FALSE_; c__[jj + j * c_dim1], nmax, & ct[1], &g[1], &cc[jc], &ldc, eps, &err, fatal, nout, & - c_true, (ftnlen)1, (ftnlen)1); + c_true); } if (upper) { jc += ldc; @@ -2330,20 +2277,21 @@ static logical c_false = FALSE_; 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); + beta, &ldc); L130: return 0; -/* 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ -/* $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' ) */ +/* L9994: */ /* 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) +/* 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) { /* Local variables */ @@ -2372,7 +2320,12 @@ static logical c_false = FALSE_; } /* 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) +/* 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 */ @@ -2400,18 +2353,18 @@ static logical c_false = FALSE_; 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); + extern /* Subroutine */ void sprcn5_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, real*, integer*, integer*, real*, integer*); static integer jc, ma, na, nc, ik, in, jj, lj, ks, ns; static real errmax; - extern logical lseres_(char*, char*, integer*, integer*, real*, real*, integer*, ftnlen, ftnlen); - extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, logical*, real*, ftnlen, ftnlen, ftnlen); + extern logical lseres_(char*, char*, integer*, integer*, real*, real*, integer*); + extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, logical*, real*); static char transs[1]; static integer laa, lbb, lda, lcc, ldb, ldc; static real als; static integer ict, icu; - extern /* Subroutine */ void cssyr2k_(integer*, char*, char*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, ftnlen, ftnlen); + extern /* Subroutine */ void cssyr2k_(integer*, char*, char*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*); extern logical lse_(real*, real*, integer*); - extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*, 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*); static real err; /* Tests SSYR2K. */ @@ -2424,17 +2377,6 @@ static logical c_false = FALSE_; /* 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; @@ -2445,7 +2387,7 @@ static logical c_false = FALSE_; --cs; --cc; c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; + c_offset = 1 + c_dim1; c__ -= c_offset; --bs; --bb; @@ -2454,12 +2396,11 @@ static logical c_false = FALSE_; --ab; /* Function Body */ -/* .. Executable Statements .. */ nargs = 12; nc = 0; reset = TRUE_; - errmax = (float)0.; + errmax = 0.f; i__1 = *nidim; for (in = 1; in <= i__1; ++in) { @@ -2507,12 +2448,10 @@ static logical c_false = FALSE_; 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); + lda, &reset, &c_b103); } else { smake_("GE", " ", " ", &ma, &na, &ab[1], nmax, &aa[1], & - lda, &reset, &c_b103, (ftnlen)2, (ftnlen)1, ( - ftnlen)1); + lda, &reset, &c_b103); } /* Generate the matrix B. */ @@ -2522,12 +2461,10 @@ static logical c_false = FALSE_; 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); + , &ldb, &reset, &c_b103); } else { smake_("GE", " ", " ", &ma, &na, &ab[k * *nmax + 1], nmax, - &bb[1], &ldb, &reset, &c_b103, (ftnlen)2, ( - ftnlen)1, (ftnlen)1); + &bb[1], &ldb, &reset, &c_b103); } for (icu = 1; icu <= 2; ++icu) { @@ -2545,8 +2482,7 @@ static logical c_false = FALSE_; /* 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); + nmax, &cc[1], &ldc, &reset, &c_b103); ++nc; @@ -2583,7 +2519,7 @@ static logical c_false = FALSE_; if (*trace) { sprcn5_(ntra, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &ldb, &beta, & - ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1) + ldc) ; } if (*rewi) { @@ -2591,7 +2527,7 @@ static logical c_false = FALSE_; } cssyr2k_(iorder, uplo, trans, &n, &k, &alpha, &aa[ 1], &lda, &bb[1], &ldb, &beta, &cc[1], & - ldc, (ftnlen)1, (ftnlen)1); + ldc); /* Check if error-exit was taken incorrectly. */ @@ -2619,7 +2555,7 @@ static logical c_false = FALSE_; 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); + , &cc[1], &ldc); } isame[11] = ldcs == ldc; @@ -2672,8 +2608,7 @@ static logical c_false = FALSE_; , &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); + fatal, nout, &c_true); } else { i__6 = k; for (i__ = 1; i__ <= i__6; ++i__) { @@ -2690,8 +2625,7 @@ static logical c_false = FALSE_; 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); + fatal, nout, &c_true); } if (upper) { jc += ldc; @@ -2760,21 +2694,21 @@ static logical c_false = FALSE_; 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); + &beta, &ldc); L160: return 0; -/* 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ -/* $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', */ -/* $ ' .' ) */ +/* L9994: */ /* 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) +/* 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) { /* Local variables */ @@ -2803,16 +2737,16 @@ static logical c_false = FALSE_; } /* 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) +/* 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; - /* Builtin functions */ - /* Local variables */ static integer ibeg, iend; - extern doublereal sbeg_(logical*); + extern real sbeg_(logical*); static logical unit; static integer i__, j; static logical lower, upper, gen, tri, sym; @@ -2832,15 +2766,9 @@ static logical c_false = FALSE_; /* 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_offset = 1 + a_dim1; a -= a_offset; --aa; @@ -2863,22 +2791,22 @@ static logical c_false = FALSE_; if (i__ != j) { /* Set some elements to zero */ if (*n > 3 && j == *n / 2) { - a[i__ + j * a_dim1] = (float)0.; + 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] = (float)0.; + a[j + i__ * a_dim1] = 0.f; } } } /* L10: */ } if (tri) { - a[j + j * a_dim1] += (float)1.; + a[j + j * a_dim1] += 1.f; } if (unit) { - a[j + j * a_dim1] = (float)1.; + a[j + j * a_dim1] = 1.f; } /* L20: */ } @@ -2895,7 +2823,7 @@ static logical c_false = FALSE_; } i__2 = *lda; for (i__ = *m + 1; i__ <= i__2; ++i__) { - aa[i__ + (j - 1) * *lda] = (float)-1e10; + aa[i__ + (j - 1) * *lda] = -1e10f; /* L40: */ } /* L50: */ @@ -2921,7 +2849,7 @@ static logical c_false = FALSE_; } i__2 = ibeg - 1; for (i__ = 1; i__ <= i__2; ++i__) { - aa[i__ + (j - 1) * *lda] = (float)-1e10; + aa[i__ + (j - 1) * *lda] = -1e10f; /* L60: */ } i__2 = iend; @@ -2931,7 +2859,7 @@ static logical c_false = FALSE_; } i__2 = *lda; for (i__ = iend + 1; i__ <= i__2; ++i__) { - aa[i__ + (j - 1) * *lda] = (float)-1e10; + aa[i__ + (j - 1) * *lda] = -1e10f; /* L80: */ } /* L90: */ @@ -2943,7 +2871,11 @@ static logical c_false = FALSE_; } /* 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) +/* 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) { /* System generated locals */ @@ -2969,26 +2901,20 @@ static logical c_false = FALSE_; /* 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_offset = 1 + a_dim1; a -= a_offset; b_dim1 = *ldb; - b_offset = 1 + b_dim1 * 1; + b_offset = 1 + b_dim1; b -= b_offset; c_dim1 = *ldc; - c_offset = 1 + c_dim1 * 1; + c_offset = 1 + c_dim1; c__ -= c_offset; --ct; --g; cc_dim1 = *ldcc; - cc_offset = 1 + cc_dim1 * 1; + cc_offset = 1 + cc_dim1; cc -= cc_offset; /* Function Body */ @@ -3006,8 +2932,8 @@ static logical c_false = FALSE_; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { - ct[i__] = (float)0.; - g[i__] = (float)0.; + ct[i__] = 0.f; + g[i__] = 0.f; /* L10: */ } if (! trana && ! tranb) { @@ -3069,7 +2995,7 @@ static logical c_false = FALSE_; /* Compute the error ratio for this result. */ - *err = (float)0.; + *err = 0.f; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { erri = (r__1 = ct[i__] - cc[i__ + j * cc_dim1], dabs(r__1)) / * @@ -3137,10 +3063,6 @@ logical lse_(real* ri, real* rj, integer* lr) /* 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; @@ -3164,14 +3086,12 @@ logical lse_(real* ri, real* rj, integer* lr) } /* lse_ */ -logical lseres_(char* type__, char* uplo, integer* m, integer* n, real* aa, real* as, integer* lda, ftnlen type_len, ftnlen uplo_len) +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; - /* Builtin functions */ - /* Local variables */ static integer ibeg, iend, i__, j; static logical upper; @@ -3189,16 +3109,12 @@ logical lseres_(char* type__, char* uplo, integer* m, integer* n, real* aa, real /* 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_offset = 1 + as_dim1; as -= as_offset; aa_dim1 = *lda; - aa_offset = 1 + aa_dim1 * 1; + aa_offset = 1 + aa_dim1; aa -= aa_offset; /* Function Body */ @@ -3243,7 +3159,7 @@ logical lseres_(char* type__, char* uplo, integer* m, integer* n, real* aa, real } } -/* 60 CONTINUE */ +/* L60: */ ret_val = TRUE_; goto L80; L70: @@ -3255,7 +3171,7 @@ logical lseres_(char* type__, char* uplo, integer* m, integer* n, real* aa, real } /* lseres_ */ -doublereal sbeg_(logical* reset) +real sbeg_(logical *reset) { /* System generated locals */ real ret_val; @@ -3274,10 +3190,6 @@ doublereal sbeg_(logical* reset) /* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ /* Sven Hammarling, Numerical Algorithms Group Ltd. */ -/* .. Scalar Arguments .. */ -/* .. Local Scalars .. */ -/* .. Save statement .. */ -/* .. Executable Statements .. */ if (*reset) { /* Initialize local variables. */ mi = 891; @@ -3300,14 +3212,14 @@ doublereal sbeg_(logical* reset) ic = 0; goto L10; } - ret_val = (i__ - 500) / (float)1001.; + ret_val = (i__ - 500) / 1001.f; return ret_val; /* End of SBEG. */ } /* sbeg_ */ -doublereal sdiff_(real* x, real* y) +real sdiff_(real *x, real *y) { /* System generated locals */ real ret_val; @@ -3321,8 +3233,6 @@ doublereal sdiff_(real* x, real* y) /* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ /* Sven Hammarling, Numerical Algorithms Group Ltd. */ -/* .. Scalar Arguments .. */ -/* .. Executable Statements .. */ ret_val = *x - *y; return ret_val; @@ -3330,4 +3240,568 @@ doublereal sdiff_(real* x, real* y) } /* sdiff_ */ -/* Main program alias */ /*int sblat3_ () { MAIN__ (); }*/ +/* 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"; + + /* 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 */ + 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 */ void sprcn8_(integer *, integer *, char *, integer + *, char *, char *, char *, integer *, integer *, real *, integer * + , integer *, real *, integer *); + char tranas[1], tranbs[1], transa[1], transb[1]; + 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 *); + +/* 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) { + } + 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_.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 *)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]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* 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) { + 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); + 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 */ void sprcn8_(integer *nout, integer *nc, char *sname, integer + *iorder, char *uplo, char *transa, char *transb, integer *n, integer * + k, real *alpha, integer *lda, integer *ldb, real *beta, integer *ldc) +{ + /* Local variables */ + char crc[14], cta[14], ctb[14], cuplo[14]; + + 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); + } + printf("%6d: %s %s %s %s %s\n",*nc,sname,crc,cuplo,cta,ctb); + printf("%d %d %4.1f A, %d, B, %d, %4.1f, C, %d.\n",*n,*k,*alpha,*lda,*ldb,*beta,*ldc); +} /* sprcn8_ */ + +/* Subroutine */ int smmtch_(char *uplo, char *transa, char *transb, integer * + 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) +{ + /* 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; + +/* 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_; + printf(" ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HALF ACCURATE *******\n"); + printf(" EXPECTED RESULT COMPUTED RESULT\n"); + + i__1 = istop; + for (i__ = istart; i__ <= i__1; ++i__) { + if (*mv) { + 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 SMMTCH */ + +} /* smmtch_ */ + diff --git a/ctest/c_xerbla.c b/ctest/c_xerbla.c index 9c53576536..935b900a8f 100644 --- a/ctest/c_xerbla.c +++ b/ctest/c_xerbla.c @@ -33,13 +33,18 @@ void cblas_xerbla(blasint info, char *rout, char *form, ...) * for A and B, lda is in position 11 instead of 9, and ldb is in * position 9 instead of 11. */ - if (strstr(rout,"gemm") != 0) + if (strstr(rout,"gemm") != 0 && strstr(rout, "gemmtr") == 0) { if (info == 5 ) info = 4; else if (info == 4 ) info = 5; else if (info == 11) info = 9; else if (info == 9 ) info = 11; + } else if (strstr(rout, "gemmtr") != 0) + { + if (info == 11) info = 9; + else if (info == 9 ) info = 11; } + else if (strstr(rout,"symm") != 0 || strstr(rout,"hemm") != 0) { if (info == 5 ) info = 4; @@ -94,7 +99,7 @@ void F77_xerbla(char *srname, void *vinfo) char *srname; #endif - char rout[] = {'c','b','l','a','s','_','\0','\0','\0','\0','\0','\0','\0'}; + char rout[] = {'c','b','l','a','s','_','\0','\0','\0','\0','\0','\0','\0','\0'}; #ifdef F77_Integer F77_Integer *info=vinfo; @@ -115,8 +120,8 @@ void F77_xerbla(char *srname, void *vinfo) link_xerbla = 0; return; } - for(i=0; i < 6; i++) rout[i+6] = tolower(srname[i]); - for(i=11; i >= 9; i--) if (rout[i] == ' ') rout[i] = '\0'; + for(i=0; i < 7; i++) rout[i+6] = tolower(srname[i]); + for(i=12; i >= 9; i--) if (rout[i] == ' ') rout[i] = '\0'; /* We increment *info by 1 since the CBLAS interface adds one more * argument to all level 2 and 3 routines. diff --git a/ctest/c_z3chke.c b/ctest/c_z3chke.c index 054e723603..809f6a3de8 100644 --- a/ctest/c_z3chke.c +++ b/ctest/c_z3chke.c @@ -45,11 +45,237 @@ void F77_z3chke(char * rout) { F77_xerbla(cblas_rout,&cblas_info); } + if (strncmp( sf,"cblas_zgemmtr" ,13)==0) { + cblas_rout = "cblas_zgemmtr" ; + cblas_info = 1; + cblas_zgemmtr( INVALID, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_zgemmtr( INVALID, CblasUpper, CblasNoTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_zgemmtr( INVALID, CblasUpper,CblasTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_zgemmtr( INVALID, CblasUpper, CblasTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 1; + cblas_zgemmtr( INVALID, CblasLower, CblasNoTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_zgemmtr( INVALID, CblasLower, CblasNoTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_zgemmtr( INVALID, CblasLower,CblasTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_zgemmtr( INVALID, CblasLower, CblasTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 2; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, INVALID, CblasNoTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, INVALID, CblasNoTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 3; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, INVALID, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, INVALID, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + + cblas_info = 9; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 14; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + + cblas_info = 14; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + + /* Row Major */ + cblas_info = 5; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 6; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 9; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 11; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 14; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); - if (strncmp( sf,"cblas_zgemm" ,11)==0) { + } else if (strncmp( sf,"cblas_zgemm" ,11)==0) { cblas_rout = "cblas_zgemm" ; cblas_info = 1; 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/c_zblat3c.c b/ctest/c_zblat3c.c index 6025c0052a..87cf127c5f 100644 --- a/ctest/c_zblat3c.c +++ b/ctest/c_zblat3c.c @@ -233,14 +233,11 @@ typedef struct Namelist Namelist; #define mycycle_() continue; #define myceiling_(w) {ceil(w)} #define myhuge_(w) {HUGE_VAL} -//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} -#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) /* procedure parameter types for -A and -C++ */ #define F2C_proc_par_types 1 - /* Common Block Declarations */ struct { @@ -251,7 +248,7 @@ struct { #define infoc_1 infoc_ struct { - char srnamt[12]; + char srnamt[13]; } srnamc_; #define srnamc_1 srnamc_ @@ -268,70 +265,98 @@ static logical c_true = TRUE_; static integer c__0 = 0; static logical c_false = FALSE_; -/* Main program MAIN__() */ int main(void) +/* Main program */ 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"}; + static char snames[10][14] = {"cblas_zgemm ","cblas_zhemm ","cblas_zsymm ", + "cblas_ztrmm ","cblas_ztrsm ","cblas_zherk ","cblas_zsyrk ", + "cblas_zher2k ","cblas_zsyr2k ","cblas_zgemmtr"}; /* System generated locals */ integer i__1, i__2, i__3, i__4, i__5; doublereal d__1; - /* 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; - + 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 *); + + /* 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 */ +/* 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 EXITS. */ +/* 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 */ @@ -340,16 +365,16 @@ static logical c_false = FALSE_; /* (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. */ @@ -365,21 +390,11 @@ static logical c_false = FALSE_; /* 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 tmpchar; char line[80]; fgets(line,80,stdin); @@ -518,7 +533,7 @@ static logical c_false = FALSE_; /* Read names of subroutines and flags which indicate */ /* whether they are to be tested. */ - for (i__ = 1; i__ <= 9; ++i__) { + for (i__ = 1; i__ <= 10; ++i__) { ltest[i__ - 1] = FALSE_; /* L20: */ } @@ -526,14 +541,14 @@ static logical c_false = FALSE_; if (! fgets(line,80,stdin)) { goto L60; } - i__1 = sscanf(line,"%12c %c",snamet,&tmpchar); + i__1 = sscanf(line,"%13c %c",snamet,&tmpchar); ltestt=FALSE_; if (tmpchar=='T')ltestt=TRUE_; if (i__1 < 2) { goto L60; } - for (i__ = 1; i__ <= 9; ++i__) { - if (s_cmp(snamet, snames[i__ - 1] , (ftnlen)12, (ftnlen)12) == + for (i__ = 1; i__ <= 10; ++i__) { + if (s_cmp(snamet, snames[i__ - 1] , (ftnlen)13, (ftnlen)13) == 0) { goto L50; } @@ -600,7 +615,7 @@ static logical c_false = FALSE_; *(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); + &c__6, &c_true); same = lze_(cc, ct, &n); if (! same || err != 0.) { printf("ERROR IN ZMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); @@ -613,7 +628,7 @@ static logical c_false = FALSE_; *(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); + &c__6, &c_true); same = lze_(cc, ct, &n); if (! same || err != 0.) { printf("ERROR IN ZMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); @@ -644,7 +659,7 @@ static logical c_false = FALSE_; *(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); + &c__6, &c_true); same = lze_(cc, ct, &n); if (! same || err != 0.) { printf("ERROR IN ZMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); @@ -657,7 +672,7 @@ static logical c_false = FALSE_; *(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); + &c__6, &c_true); same = lze_(cc, ct, &n); if (! same || err != 0.) { printf("ERROR IN ZMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); @@ -670,7 +685,7 @@ static logical c_false = FALSE_; /* Test each subroutine in turn. */ - for (isnum = 1; isnum <= 9; ++isnum) { + for (isnum = 1; isnum <= 10; ++isnum) { if (! ltest[isnum - 1]) { /* Subprogram is not to be tested. */ printf("%12s WAS NOT TESTED\n",snames[isnum-1]); @@ -679,7 +694,7 @@ static logical c_false = FALSE_; ftnlen)12); /* Test error exits. */ if (tsterr) { - cz3chke_(snames[isnum - 1], (ftnlen)12); + cz3chke_(snames[isnum - 1]); } /* Test computations. */ infoc_1.infot = 0; @@ -695,6 +710,7 @@ static logical c_false = FALSE_; case 7: goto L170; case 8: goto L180; case 9: goto L180; + case 10: goto L185; } /* Test ZGEMM, 01. */ L140: @@ -702,13 +718,13 @@ static logical c_false = FALSE_; 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); + cc, cs, ct, g, &c__0); } 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); + cc, cs, ct, g, &c__1); } goto L190; /* Test ZHEMM, 02, ZSYMM, 03. */ @@ -717,13 +733,13 @@ static logical c_false = FALSE_; 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); + cc, cs, ct, g, &c__0); } 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); + cc, cs, ct, g, &c__1); } goto L190; /* Test ZTRMM, 04, ZTRSM, 05. */ @@ -732,13 +748,13 @@ static logical c_false = FALSE_; 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); + c__0); } 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); + c__1); } goto L190; /* Test ZHERK, 06, ZSYRK, 07. */ @@ -747,13 +763,13 @@ static logical c_false = FALSE_; 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); + cc, cs, ct, g, &c__0); } 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); + cc, cs, ct, g, &c__1); } goto L190; /* Test ZHER2K, 08, ZSYR2K, 09. */ @@ -762,13 +778,28 @@ static logical c_false = FALSE_; 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); + ct, g, w, &c__0); } 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); + ct, g, w, &c__1); + } + goto L190; +/* Test ZGEMMTR, 10 */ +L185: + if (corder) { + zchk6_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__0); + } + if (rorder) { + zchk6_(snames[isnum - 1], &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; @@ -807,7 +838,7 @@ static logical c_false = FALSE_; } /* 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) +/* 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 */ @@ -824,17 +855,17 @@ static logical c_false = FALSE_; 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); + extern /* Subroutine */ int zmake_(char*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, logical*, doublecomplex*); static integer nargs; - extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); + extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*); static logical reset; static integer ia, ib; - extern /* Subroutine */ int zprcn1_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, integer*, doublecomplex*, integer*, integer*, doublecomplex*, integer*, ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ int zprcn1_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, integer*, doublecomplex*, integer*, integer*, doublecomplex*, integer*); static integer ma, mb, na, nb, nc, ik, im, in, ks, ms, ns; - extern /* Subroutine */ void czgemm_(integer*, char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen); + extern /* Subroutine */ void czgemm_(integer*, char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*); static char tranas[1], tranbs[1], transa[1], transb[1]; static doublereal errmax; - extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen); + extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*); static integer ica, icb, laa, lbb, lda, lcc, ldb, ldc; static doublecomplex als, bls; static doublereal err; @@ -850,17 +881,6 @@ static logical c_false = FALSE_; /* 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; @@ -870,21 +890,20 @@ static logical c_false = FALSE_; --cs; --cc; c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; + c_offset = 1 + c_dim1; c__ -= c_offset; --bs; --bb; b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; + b_offset = 1 + b_dim1; b -= b_offset; --as; --aa; a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; /* Function Body */ -/* .. Executable Statements .. */ nargs = 13; nc = 0; @@ -941,8 +960,7 @@ static logical c_false = FALSE_; /* Generate the matrix A. */ zmake_("ge", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[ - 1], &lda, &reset, &c_b1, (ftnlen)2, (ftnlen)1, ( - ftnlen)1); + 1], &lda, &reset, &c_b1); for (icb = 1; icb <= 3; ++icb) { *(unsigned char *)transb = *(unsigned char *)&ich[icb @@ -971,8 +989,7 @@ static logical c_false = FALSE_; /* Generate the matrix B. */ zmake_("ge", " ", " ", &mb, &nb, &b[b_offset], nmax, & - bb[1], &ldb, &reset, &c_b1, (ftnlen)2, ( - ftnlen)1, (ftnlen)1); + bb[1], &ldb, &reset, &c_b1); i__4 = *nalf; for (ia = 1; ia <= i__4; ++ia) { @@ -987,8 +1004,7 @@ static logical c_false = FALSE_; /* Generate the matrix C. */ zmake_("ge", " ", " ", &m, &n, &c__[c_offset], - nmax, &cc[1], &ldc, &reset, &c_b1, ( - ftnlen)2, (ftnlen)1, (ftnlen)1); + nmax, &cc[1], &ldc, &reset, &c_b1); ++nc; @@ -1037,8 +1053,7 @@ static logical c_false = FALSE_; if (*trace) { zprcn1_(ntra, &nc, sname, iorder, transa, transb, &m, &n, &k, &alpha, &lda, - &ldb, &beta, &ldc, (ftnlen)12, ( - ftnlen)1, (ftnlen)1); + &ldb, &beta, &ldc); } if (*rewi) { /* al__1.aerr = 0; @@ -1047,8 +1062,7 @@ static logical c_false = FALSE_; } czgemm_(iorder, transa, transb, &m, &n, &k, & alpha, &aa[1], &lda, &bb[1], &ldb, & - beta, &cc[1], &ldc, (ftnlen)1, ( - ftnlen)1); + beta, &cc[1], &ldc); /* Check if error-exit was taken incorrectly. */ @@ -1079,8 +1093,7 @@ static logical c_false = FALSE_; isame[11] = lze_(&cs[1], &cc[1], &lcc); } else { isame[11] = lzeres_("ge", " ", &m, &n, & - cs[1], &cc[1], &ldc, (ftnlen)2, ( - ftnlen)1); + cs[1], &cc[1], &ldc); } isame[12] = ldcs == ldc; @@ -1109,8 +1122,7 @@ static logical c_false = FALSE_; &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); + eps, &err, fatal, nout, &c_true); errmax = f2cmax(errmax,err); /* If got really bad answer, report and */ /* return. */ @@ -1147,19 +1159,19 @@ static logical c_false = FALSE_; if (errmax < *thresh) { if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + 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); + 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); + 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); + 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; @@ -1167,21 +1179,19 @@ static logical c_false = FALSE_; 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); + 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, ').' ) */ +/* 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, ftnlen sname_len, ftnlen transa_len, ftnlen transb_len) +/* 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) { /* Local variables */ static char crc[14], cta[14], ctb[14]; @@ -1212,7 +1222,7 @@ 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) +/* 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 */ @@ -1234,18 +1244,18 @@ return 0; 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); + extern /* Subroutine */ int zmake_(char*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, logical*, doublecomplex*); static integer nargs; - extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); + extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*); static logical reset; static char uplos[1]; static integer ia, ib; - extern /* Subroutine */ int zprcn2_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublecomplex*, integer*, integer*, doublecomplex*, integer*, ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ int zprcn2_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublecomplex*, integer*, integer*, doublecomplex*, integer*); static integer na, nc, im, in, ms, ns; - extern /* Subroutine */ void czhemm_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen); + extern /* Subroutine */ void czhemm_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*); static doublereal errmax; - extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen); - extern /* Subroutine */ void czsymm_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen); + extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*); + extern /* Subroutine */ void czsymm_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*); static integer laa, lbb, lda, lcc, ldb, ldc, ics; static doublecomplex als, bls; static integer icu; @@ -1262,17 +1272,6 @@ return 0; /* 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; @@ -1282,17 +1281,17 @@ return 0; --cs; --cc; c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; + c_offset = 1 + c_dim1; c__ -= c_offset; --bs; --bb; b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; + b_offset = 1 + b_dim1; b -= b_offset; --as; --aa; a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; /* Function Body */ @@ -1336,7 +1335,7 @@ return 0; /* Generate the matrix B. */ zmake_("ge", " ", " ", &m, &n, &b[b_offset], nmax, &bb[1], &ldb, & - reset, &c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)1); + reset, &c_b1); for (ics = 1; ics <= 2; ++ics) { *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1]; @@ -1364,8 +1363,7 @@ return 0; /* Generate the hermitian or symmetric matrix A. */ zmake_(sname + 7, uplo, " ", &na, &na, &a[a_offset], nmax, - &aa[1], &lda, &reset, &c_b1, (ftnlen)2, (ftnlen) - 1, (ftnlen)1); + &aa[1], &lda, &reset, &c_b1); i__3 = *nalf; for (ia = 1; ia <= i__3; ++ia) { @@ -1380,8 +1378,7 @@ return 0; /* Generate the matrix C. */ zmake_("ge", " ", " ", &m, &n, &c__[c_offset], - nmax, &cc[1], &ldc, &reset, &c_b1, ( - ftnlen)2, (ftnlen)1, (ftnlen)1); + nmax, &cc[1], &ldc, &reset, &c_b1); ++nc; @@ -1427,7 +1424,7 @@ return 0; if (*trace) { zprcn2_(ntra, &nc, sname, iorder, side, uplo, &m, &n, &alpha, &lda, &ldb, &beta, & - ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1) + ldc) ; } if (*rewi) { @@ -1438,11 +1435,11 @@ return 0; if (isconj) { czhemm_(iorder, side, uplo, &m, &n, &alpha, & aa[1], &lda, &bb[1], &ldb, &beta, &cc[ - 1], &ldc, (ftnlen)1, (ftnlen)1); + 1], &ldc); } else { czsymm_(iorder, side, uplo, &m, &n, &alpha, & aa[1], &lda, &bb[1], &ldb, &beta, &cc[ - 1], &ldc, (ftnlen)1, (ftnlen)1); + 1], &ldc); } /* Check if error-exit was taken incorrectly. */ @@ -1471,7 +1468,7 @@ return 0; isame[10] = lze_(&cs[1], &cc[1], &lcc); } else { isame[10] = lzeres_("ge", " ", &m, &n, &cs[1], - &cc[1], &ldc, (ftnlen)2, (ftnlen)1); + &cc[1], &ldc); } isame[11] = ldcs == ldc; @@ -1501,15 +1498,13 @@ return 0; 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); + &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, ( - ftnlen)1, (ftnlen)1); + &err, fatal, nout, &c_true); } errmax = f2cmax(errmax,err); /* If got really bad answer, report and */ @@ -1543,19 +1538,19 @@ return 0; if (errmax < *thresh) { if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + 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); + 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); + 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); + 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; @@ -1563,21 +1558,19 @@ return 0; L110: printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); zprcn2_(nout, &nc, sname, iorder, side, uplo, &m, &n, &alpha, &lda, &ldb, - &beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); + &beta, &ldc); L120: return 0; -/* 9995 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */ -/* $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1, */ -/* $ ',', F4.1, '), C,', I3, ') .' ) */ +/* 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, ftnlen sname_len, ftnlen side_len, ftnlen uplo_len) +/* 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) { /* Local variables */ static char cs[14], cu[14], crc[14]; @@ -1604,7 +1597,7 @@ 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) +/* 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 */ @@ -1630,19 +1623,19 @@ return 0; 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); + extern /* Subroutine */ int zmake_(char*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, logical*, doublecomplex*); static integer nargs; - extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); + extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*); static logical reset; static char uplos[1]; static integer ia, na; - extern /* Subroutine */ int zprcn3_(integer*, integer*, char*, integer*, char*, char*, char*, char*, integer*, integer*, doublecomplex*, integer*, integer*, ftnlen, ftnlen, ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ int zprcn3_(integer*, integer*, char*, integer*, char*, char*, char*, char*, integer*, integer*, doublecomplex*, integer*, integer*); static integer nc, im, in, ms, ns; static char tranas[1], transa[1]; static doublereal errmax; - extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, 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); + extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*); + extern /* Subroutine */ void cztrmm_(integer*, char*, char*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*); + extern /* Subroutine */ void cztrsm_(integer*, char*, char*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*); static integer laa, icd, lbb, lda, ldb, ics; static doublecomplex als; static integer ict, icu; @@ -1659,38 +1652,26 @@ return 0; /* 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_offset = 1 + c_dim1; c__ -= c_offset; --g; --ct; --bs; --bb; b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; + b_offset = 1 + b_dim1; b -= b_offset; --as; --aa; a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; /* Function Body */ -/* .. Executable Statements .. */ nargs = 11; nc = 0; @@ -1766,14 +1747,12 @@ return 0; zmake_("tr", uplo, diag, &na, &na, &a[ a_offset], nmax, &aa[1], &lda, &reset, - &c_b1, (ftnlen)2, (ftnlen)1, (ftnlen) - 1); + &c_b1); /* Generate the matrix B. */ zmake_("ge", " ", " ", &m, &n, &b[b_offset], - nmax, &bb[1], &ldb, &reset, &c_b1, ( - ftnlen)2, (ftnlen)1, (ftnlen)1); + nmax, &bb[1], &ldb, &reset, &c_b1); ++nc; @@ -1817,9 +1796,7 @@ return 0; if (*trace) { zprcn3_(ntra, &nc, sname, iorder, side, uplo, transa, diag, &m, - &n, &alpha, &lda, &ldb, ( - ftnlen)12, (ftnlen)1, (ftnlen) - 1, (ftnlen)1, (ftnlen)1); + &n, &alpha, &lda, &ldb); } if (*rewi) { /* al__1.aerr = 0; @@ -1828,16 +1805,13 @@ return 0; } cztrmm_(iorder, side, uplo, transa, diag, &m, &n, &alpha, &aa[1], &lda, &bb[ - 1], &ldb, (ftnlen)1, (ftnlen)1, ( - ftnlen)1, (ftnlen)1); + 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)12, (ftnlen)1, (ftnlen) - 1, (ftnlen)1, (ftnlen)1); + &n, &alpha, &lda, &ldb); } if (*rewi) { /* al__1.aerr = 0; @@ -1846,8 +1820,7 @@ return 0; } cztrsm_(iorder, side, uplo, transa, diag, &m, &n, &alpha, &aa[1], &lda, &bb[ - 1], &ldb, (ftnlen)1, (ftnlen)1, ( - ftnlen)1, (ftnlen)1); + 1], &ldb); } /* Check if error-exit was taken incorrectly. */ @@ -1878,8 +1851,7 @@ return 0; isame[9] = lze_(&bs[1], &bb[1], &lbb); } else { isame[9] = lzeres_("ge", " ", &m, &n, &bs[ - 1], &bb[1], &ldb, (ftnlen)2, ( - ftnlen)1); + 1], &bb[1], &ldb); } isame[10] = ldbs == ldb; @@ -1913,8 +1885,7 @@ return 0; c_b1, &c__[c_offset], nmax, &ct[1], &g[1], &bb[ 1], &ldb, eps, &err, - fatal, nout, &c_true, ( - ftnlen)1, (ftnlen)1); + fatal, nout, &c_true); } else { zmmch_("N", transa, &m, &n, &n, & alpha, &b[b_offset], nmax, @@ -1922,8 +1893,7 @@ return 0; c_b1, &c__[c_offset], nmax, &ct[1], &g[1], &bb[ 1], &ldb, eps, &err, - fatal, nout, &c_true, ( - ftnlen)1, (ftnlen)1); + fatal, nout, &c_true); } } else if (s_cmp(sname + 9, "sm", (ftnlen) 2, (ftnlen)2) == 0) { @@ -1957,8 +1927,7 @@ return 0; c_b1, &b[b_offset], nmax, &ct[1], &g[1], &bb[1], & ldb, eps, &err, fatal, - nout, &c_false, (ftnlen)1, - (ftnlen)1); + nout, &c_false); } else { zmmch_("N", transa, &m, &n, &n, & c_b2, &c__[c_offset], @@ -1966,8 +1935,7 @@ return 0; &c_b1, &b[b_offset], nmax, &ct[1], &g[1], &bb[1], & ldb, eps, &err, fatal, - nout, &c_false, (ftnlen)1, - (ftnlen)1); + nout, &c_false); } } errmax = f2cmax(errmax,err); @@ -2004,19 +1972,19 @@ return 0; if (errmax < *thresh) { if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + 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); + 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); + 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); + 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; @@ -2025,23 +1993,20 @@ return 0; printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); if (*trace) { zprcn3_(ntra, &nc, sname, iorder, side, uplo, transa, diag, &m, &n, & - alpha, &lda, &ldb, (ftnlen)12, (ftnlen)1, (ftnlen)1, (ftnlen) - 1, (ftnlen)1); + alpha, &lda, &ldb); } L160: return 0; -/* 9995 FORMAT(1X, I6, ': ', A12,'(', 4( '''', A1, ''',' ), 2( I3, ',' ), */ -/* $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ') ', */ -/* $ ' .' ) */ +/* 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, ftnlen sname_len, ftnlen side_len, ftnlen uplo_len, ftnlen transa_len, ftnlen diag_len) +/* 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) { /* Local variables */ @@ -2081,7 +2046,7 @@ 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) +/* 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 */ @@ -2105,25 +2070,25 @@ return 0; 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); + extern /* Subroutine */ int zmake_(char*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, logical*, doublecomplex*); static integer nargs; - extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); + extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*); static doublereal rbets; static logical reset; static char trans[1]; static logical upper; static char uplos[1]; static integer ia, ib, jc, ma, na; - extern /* Subroutine */ int zprcn4_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ int zprcn4_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*); static integer nc; - extern /* Subroutine */ int zprcn6_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ int zprcn6_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*); static integer ik, in, jj, lj, ks, ns; static doublereal ralpha; - extern /* Subroutine */ int czherk_(integer*, char*, char*, integer*, integer*, doublereal*, doublecomplex*, integer*, doublereal*, doublecomplex*, integer*, ftnlen, ftnlen); + extern /* Subroutine */ int czherk_(integer*, char*, char*, integer*, integer*, doublereal*, doublecomplex*, integer*, doublereal*, doublecomplex*, integer*); static doublereal errmax; - extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen); + extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*); static char transs[1], transt[1]; - extern /* Subroutine */ int czsyrk_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen); + extern /* Subroutine */ int czsyrk_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*); static integer laa, lda, lcc, ldc; static doublecomplex als; static integer ict, icu; @@ -2140,17 +2105,6 @@ return 0; /* 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; @@ -2160,17 +2114,17 @@ return 0; --cs; --cc; c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; + c_offset = 1 + c_dim1; c__ -= c_offset; --bs; --bb; b_dim1 = *nmax; - b_offset = 1 + b_dim1 * 1; + b_offset = 1 + b_dim1; b -= b_offset; --as; --aa; a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; /* Function Body */ @@ -2229,7 +2183,7 @@ return 0; /* Generate the matrix A. */ zmake_("ge", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[1], & - lda, &reset, &c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)1); + lda, &reset, &c_b1); for (icu = 1; icu <= 2; ++icu) { *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1]; @@ -2264,7 +2218,7 @@ return 0; zmake_(sname + 7, uplo, " ", &n, &n, &c__[ c_offset], nmax, &cc[1], &ldc, &reset, & - c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)1); + c_b1); ++nc; @@ -2310,8 +2264,7 @@ return 0; if (*trace) { zprcn6_(ntra, &nc, sname, iorder, uplo, trans, &n, &k, &ralpha, &lda, & - rbeta, &ldc, (ftnlen)12, (ftnlen) - 1, (ftnlen)1); + rbeta, &ldc); } if (*rewi) { /* al__1.aerr = 0; @@ -2319,14 +2272,12 @@ return 0; f_rew(&al__1);*/ } czherk_(iorder, uplo, trans, &n, &k, &ralpha, - &aa[1], &lda, &rbeta, &cc[1], &ldc, ( - ftnlen)1, (ftnlen)1); + &aa[1], &lda, &rbeta, &cc[1], &ldc); } else { if (*trace) { zprcn4_(ntra, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, & - beta, &ldc, (ftnlen)12, (ftnlen)1, - (ftnlen)1); + beta, &ldc); } if (*rewi) { /* al__1.aerr = 0; @@ -2334,8 +2285,7 @@ return 0; f_rew(&al__1);*/ } czsyrk_(iorder, uplo, trans, &n, &k, &alpha, & - aa[1], &lda, &beta, &cc[1], &ldc, ( - ftnlen)1, (ftnlen)1); + aa[1], &lda, &beta, &cc[1], &ldc); } /* Check if error-exit was taken incorrectly. */ @@ -2372,8 +2322,7 @@ return 0; 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); + cs[1], &cc[1], &ldc); } isame[9] = ldcs == ldc; @@ -2420,8 +2369,7 @@ return 0; 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); + fatal, nout, &c_true); } else { zmmch_("N", transt, &lj, &c__1, &k, & alpha, &a[jj + a_dim1], nmax, @@ -2429,7 +2377,7 @@ return 0; c__[jj + j * c_dim1], nmax, & ct[1], &g[1], &cc[jc], &ldc, eps, &err, fatal, nout, & - c_true, (ftnlen)1, (ftnlen)1); + c_true); } if (upper) { jc += ldc; @@ -2470,19 +2418,19 @@ return 0; if (errmax < *thresh) { if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + 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); + 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); + 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); + 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; @@ -2496,28 +2444,24 @@ return 0; 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); + &rbeta, &ldc); } else { zprcn4_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, & - beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); + 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, ') .' ) */ +/* 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, ftnlen sname_len, ftnlen uplo_len, ftnlen transa_len) +/* 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) { /* Local variables */ static char ca[14], cu[14], crc[14]; @@ -2547,7 +2491,7 @@ return 0; -/* 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) +/* 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) { /* Local variables */ @@ -2577,7 +2521,7 @@ 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) +/* 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 */ @@ -2600,26 +2544,26 @@ return 0; 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); + extern /* Subroutine */ int zmake_(char*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, logical*, doublecomplex*); static integer nargs; - extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); + extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*); static doublereal rbets; static logical reset; static char trans[1]; static logical upper; static char uplos[1]; static integer ia, ib, jc, ma, na, nc; - extern /* Subroutine */ int zprcn5_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublecomplex*, integer*, integer*, doublecomplex*, integer*, ftnlen, ftnlen, ftnlen); - extern /* Subroutine */ int zprcn7_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublecomplex*, integer*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen); + extern /* Subroutine */ int zprcn5_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublecomplex*, integer*, integer*, doublecomplex*, integer*); + extern /* Subroutine */ int zprcn7_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublecomplex*, integer*, integer*, doublereal*, integer*); static integer ik, in, jj, lj, ks, ns; static doublereal errmax; - extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen); + extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*); static char transs[1], transt[1]; - extern /* Subroutine */ int czher2k_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublereal*, doublecomplex*, integer*, ftnlen, ftnlen); + extern /* Subroutine */ int czher2k_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublereal*, doublecomplex*, integer*); static integer laa, lbb, lda, lcc, ldb, ldc; static doublecomplex als; static integer ict, icu; - extern /* Subroutine */ int czsyr2k_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen); + extern /* Subroutine */ int czsyr2k_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*); static doublereal err; extern logical lze_(doublecomplex*, doublecomplex*, integer*); @@ -2633,17 +2577,6 @@ return 0; /* 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; @@ -2654,7 +2587,7 @@ return 0; --cs; --cc; c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; + c_offset = 1 + c_dim1; c__ -= c_offset; --bs; --bb; @@ -2718,12 +2651,10 @@ return 0; 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); + lda, &reset, &c_b1); } else { zmake_("ge", " ", " ", &ma, &na, &ab[1], nmax, &aa[1], & - lda, &reset, &c_b1, (ftnlen)2, (ftnlen)1, (ftnlen) - 1); + lda, &reset, &c_b1); } /* Generate the matrix B. */ @@ -2733,12 +2664,10 @@ return 0; 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); + , &ldb, &reset, &c_b1); } else { zmake_("ge", " ", " ", &ma, &na, &ab[k * *nmax + 1], nmax, - &bb[1], &ldb, &reset, &c_b1, (ftnlen)2, (ftnlen) - 1, (ftnlen)1); + &bb[1], &ldb, &reset, &c_b1); } for (icu = 1; icu <= 2; ++icu) { @@ -2769,7 +2698,7 @@ return 0; zmake_(sname + 7, uplo, " ", &n, &n, &c__[ c_offset], nmax, &cc[1], &ldc, &reset, & - c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)1); + c_b1); ++nc; @@ -2820,8 +2749,7 @@ return 0; if (*trace) { zprcn7_(ntra, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &ldb, - &rbeta, &ldc, (ftnlen)12, ( - ftnlen)1, (ftnlen)1); + &rbeta, &ldc); } if (*rewi) { /* al__1.aerr = 0; @@ -2830,13 +2758,12 @@ return 0; } czher2k_(iorder, uplo, trans, &n, &k, &alpha, &aa[1], &lda, &bb[1], &ldb, &rbeta, & - cc[1], &ldc, (ftnlen)1, (ftnlen)1); + cc[1], &ldc); } else { if (*trace) { zprcn5_(ntra, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &ldb, - &beta, &ldc, (ftnlen)12, (ftnlen) - 1, (ftnlen)1); + &beta, &ldc); } if (*rewi) { /* al__1.aerr = 0; @@ -2845,7 +2772,7 @@ return 0; } czsyr2k_(iorder, uplo, trans, &n, &k, &alpha, &aa[1], &lda, &bb[1], &ldb, &beta, & - cc[1], &ldc, (ftnlen)1, (ftnlen)1); + cc[1], &ldc); } /* Check if error-exit was taken incorrectly. */ @@ -2879,7 +2806,7 @@ return 0; 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); + , &cc[1], &ldc); } isame[11] = ldcs == ldc; @@ -2959,8 +2886,7 @@ return 0; 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); + fatal, nout, &c_true); } else { i__6 = k; for (i__ = 1; i__ <= i__6; ++i__) { @@ -3001,8 +2927,7 @@ return 0; 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); + fatal, nout, &c_true); } if (upper) { jc += ldc; @@ -3046,19 +2971,19 @@ return 0; if (errmax < *thresh) { if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + 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); + 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); + 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); + 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; @@ -3072,28 +2997,24 @@ return 0; 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); + ldb, &rbeta, &ldc); } else { zprcn5_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, & - ldb, &beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1); + 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, ') .' ) */ +/* 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, ftnlen sname_len, ftnlen uplo_len, ftnlen transa_len) +/* 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) { /* Local variables */ static char ca[14], cu[14], crc[14]; @@ -3123,7 +3044,7 @@ return 0; -/* 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) +/* 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) { /* Local variables */ @@ -3153,7 +3074,7 @@ 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) +/* 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; @@ -3184,16 +3105,9 @@ return 0; /* 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_offset = 1 + a_dim1; a -= a_offset; --aa; @@ -3335,7 +3249,7 @@ return 0; } /* 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) +/* 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) { /* System generated locals */ @@ -3360,28 +3274,20 @@ return 0; /* 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_offset = 1 + b_dim1; b -= b_offset; c_dim1 = *ldc; - c_offset = 1 + c_dim1 * 1; + c_offset = 1 + c_dim1; c__ -= c_offset; --ct; --g; cc_dim1 = *ldcc; - cc_offset = 1 + cc_dim1 * 1; + cc_offset = 1 + cc_dim1; cc -= cc_offset; /* Function Body */ @@ -3737,10 +3643,6 @@ logical lze_(doublecomplex* ri, doublecomplex* rj, integer* lr) /* 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; @@ -3766,7 +3668,7 @@ logical lze_(doublecomplex* ri, doublecomplex* rj, integer* lr) } /* lze_ */ -logical lzeres_(char* type__, char* uplo, integer* m, integer* n, doublecomplex *aa, doublecomplex* as, integer* lda, ftnlen type_len, ftnlen uplo_len) +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; @@ -3789,16 +3691,12 @@ logical lzeres_(char* type__, char* uplo, integer* m, integer* n, doublecomplex /* 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_offset = 1 + as_dim1; as -= as_offset; aa_dim1 = *lda; - aa_offset = 1 + aa_dim1 * 1; + aa_offset = 1 + aa_dim1; aa -= aa_offset; /* Function Body */ @@ -3850,7 +3748,7 @@ logical lzeres_(char* type__, char* uplo, integer* m, integer* n, doublecomplex } } -/* 60 CONTINUE */ +/* L60: */ ret_val = TRUE_; goto L80; L70: @@ -3883,11 +3781,6 @@ logical lzeres_(char* type__, char* uplo, integer* m, integer* n, doublecomplex /* 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; @@ -3939,8 +3832,6 @@ doublereal ddiff_(doublereal* x, doublereal* y) /* Jeremy Du Croz, Numerical Algorithms Group Ltd. */ /* Sven Hammarling, Numerical Algorithms Group Ltd. */ -/* .. Scalar Arguments .. */ -/* .. Executable Statements .. */ ret_val = *x - *y; return ret_val; @@ -3948,4 +3839,800 @@ doublereal ddiff_(doublereal* x, doublereal* y) } /* ddiff_ */ -/* Main program alias */ /*int zblat3_ () { MAIN__ (); }*/ +/* 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"; + + /* 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 */ + 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 *); + +/* 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) { + 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 *)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]) { + printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + } +/* 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) { + 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); + 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) +{ + /* Local variables */ + char crc[14], cta[14], ctb[14], cuplo[14]; + + 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); + } + printf("%d %s %s %s %s %s\n",*nc,sname,crc,cuplo,cta,ctb); + printf("%d %d %f,%f %d %d %f,%f %d\n",*n,*k,alpha->r,alpha->i,*lda,*ldb,beta->r,beta->i,*ldc); + return 0; +} /* zprcn8_ */ + +/* 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) +{ + /* 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; + +/* 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_; + printf(" ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HALF ACCURATE *******\n"); + printf(" EXPECTED RESULT COMPUTED RESULT\n"); + i__1 = istop; + for (i__ = istart; i__ <= i__1; ++i__) { + if (*mv) { + 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",j); + } + +L250: + return 0; + + +/* End of ZMMTCH. */ + +} /* zmmtch_ */ + diff --git a/ctest/c_zblat3c_3m.c b/ctest/c_zblat3c_3m.c index 0c76f11e76..1a7f512203 100644 --- a/ctest/c_zblat3c_3m.c +++ b/ctest/c_zblat3c_3m.c @@ -272,7 +272,7 @@ static logical c_false = FALSE_; { /* Initialized data */ - static char snames[9][13] = { "cblas_zgemm3m ", "cblas_zhemm ", "cblas_zsymm ", "cblas_ztrmm ", + static char snames[9][13] = { "cblas_zgemm3m", "cblas_zhemm ", "cblas_zsymm ", "cblas_ztrmm ", "cblas_ztrsm ", "cblas_zherk ", "cblas_zsyrk ", "cblas_zher2k", "cblas_zsyr2k"}; /* System generated locals */ diff --git a/ctest/cblas_test.h b/ctest/cblas_test.h index 502a2fee20..b9a75b3ee1 100644 --- a/ctest/cblas_test.h +++ b/ctest/cblas_test.h @@ -170,12 +170,14 @@ typedef struct { double real; double imag; } CBLAS_TEST_ZOMPLEX; #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_ @@ -183,6 +185,7 @@ typedef struct { double real; double imag; } CBLAS_TEST_ZOMPLEX; #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_ @@ -190,6 +193,7 @@ typedef struct { double real; double imag; } CBLAS_TEST_ZOMPLEX; #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_ @@ -332,12 +336,14 @@ typedef struct { double real; double imag; } CBLAS_TEST_ZOMPLEX; #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 @@ -345,6 +351,7 @@ typedef struct { double real; double imag; } CBLAS_TEST_ZOMPLEX; #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 @@ -352,6 +359,7 @@ typedef struct { double real; double imag; } CBLAS_TEST_ZOMPLEX; #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 @@ -494,12 +502,14 @@ typedef struct { double real; double imag; } CBLAS_TEST_ZOMPLEX; #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 @@ -507,6 +517,7 @@ typedef struct { double real; double imag; } CBLAS_TEST_ZOMPLEX; #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 @@ -514,6 +525,7 @@ typedef struct { double real; double imag; } CBLAS_TEST_ZOMPLEX; #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 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. diff --git a/interface/CMakeLists.txt b/interface/CMakeLists.txt index a3ee6559e9..3fc932746b 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") diff --git a/interface/Makefile b/interface/Makefile index f09a6f46b9..01c9cc9b13 100644 --- a/interface/Makefile +++ b/interface/Makefile @@ -1981,13 +1981,13 @@ cblas_sgemmt.$(SUFFIX) cblas_sgemmt.$(PSUFFIX) : gemmt.c ../param.h $(CC) -DCBLAS -c $(CFLAGS) $< -o $(@F) cblas_sgemmtr.$(SUFFIX) cblas_sgemmtr.$(PSUFFIX) : gemmt.c ../param.h - $(CC) -DCBLAS -c $(CFLAGS) $< -o $(@F) + $(CC) -DCBLAS -DRNAME -c $(CFLAGS) $< -o $(@F) ifeq ($(BUILD_BFLOAT16),1) cblas_sbgemmt.$(SUFFIX) cblas_sbgemmt.$(PSUFFIX) : sbgemmt.c ../param.h $(CC) -DCBLAS -c $(CFLAGS) $< -o $(@F) cblas_sbgemmtr.$(SUFFIX) cblas_sbgemmtr.$(PSUFFIX) : sbgemmt.c ../param.h - $(CC) -DCBLAS -c $(CFLAGS) $< -o $(@F) + $(CC) -DCBLAS -DRNAME -c $(CFLAGS) $< -o $(@F) endif cblas_dgemmt.$(SUFFIX) cblas_dgemmt.$(PSUFFIX) : gemmt.c ../param.h @@ -2000,13 +2000,13 @@ cblas_zgemmt.$(SUFFIX) cblas_zgemmt.$(PSUFFIX) : gemmt.c ../param.h $(CC) -DCBLAS -c $(CFLAGS) $< -o $(@F) cblas_dgemmtr.$(SUFFIX) cblas_dgemmtr.$(PSUFFIX) : gemmt.c ../param.h - $(CC) -DCBLAS -c $(CFLAGS) $< -o $(@F) + $(CC) -DCBLAS -DRNAME -c $(CFLAGS) $< -o $(@F) cblas_cgemmtr.$(SUFFIX) cblas_cgemmtr.$(PSUFFIX) : gemmt.c ../param.h - $(CC) -DCBLAS -c $(CFLAGS) $< -o $(@F) + $(CC) -DCBLAS -DRNAME -c $(CFLAGS) $< -o $(@F) cblas_zgemmtr.$(SUFFIX) cblas_zgemmtr.$(PSUFFIX) : gemmt.c ../param.h - $(CC) -DCBLAS -c $(CFLAGS) $< -o $(@F) + $(CC) -DCBLAS -DRNAME -c $(CFLAGS) $< -o $(@F) cblas_ssymm.$(SUFFIX) cblas_ssymm.$(PSUFFIX) : symm.c $(CC) -DCBLAS -c $(CFLAGS) $< -o $(@F)