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_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..1735e2a90b 100644 --- a/ctest/c_cblat3c.c +++ b/ctest/c_cblat3c.c @@ -236,13 +236,113 @@ 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 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} /* Common Block Declarations */ @@ -254,7 +354,7 @@ struct { #define infoc_1 infoc_ struct { - char srnamt[12]; + char srnamt[13]; } srnamc_; #define srnamc_1 srnamc_ @@ -263,27 +363,83 @@ struct { static complex c_b1 = {0.f,0.f}; static complex c_b2 = {1.f,0.f}; +static integer c__9 = 9; static integer c__1 = 1; +static integer c__3 = 3; +static integer c__8 = 8; +static integer c__4 = 4; static integer c__65 = 65; +static integer c__7 = 7; static integer c__6 = 6; +static integer c__2 = 2; static real c_b91 = 1.f; static logical c_true = TRUE_; static integer c__0 = 0; static logical c_false = FALSE_; -int /* Main program */ main(void) +/* Main program */ int 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[13*10] = "cblas_cgemm " "cblas_chemm " "cblas_csymm" + " " "cblas_ctrmm " "cblas_ctrsm " "cblas_cherk " "cblas_csyrk" + " " "cblas_cher2k " "cblas_csyr2k " "cblas_cgemmtr"; + + /* Format strings */ + static char fmt_9997[] = "(\002 NUMBER OF VALUES OF \002,a,\002 IS LESS " + "THAN 1 OR GREATER \002,\002THAN \002,i2)"; + static char fmt_9996[] = "(\002 VALUE OF N IS LESS THAN 0 OR GREATER THA" + "N \002,i2)"; + static char fmt_9995[] = "(\002 TESTS OF THE COMPLEX LEVEL 3 BL" + "AS\002,//\002 THE F\002,\002OLLOWING PARAMETER VALUES WILL BE US" + "ED:\002)"; + static char fmt_9994[] = "(\002 FOR N \002,9i6)"; + static char fmt_9993[] = "(\002 FOR ALPHA \002,7(\002(\002,f4" + ".1,\002,\002,f4.1,\002) \002,:))"; + static char fmt_9992[] = "(\002 FOR BETA \002,7(\002(\002,f4" + ".1,\002,\002,f4.1,\002) \002,:))"; + static char fmt_9984[] = "(\002 ERROR-CALL MYEXITS WILL NOT BE TESTED" + "\002)"; + static char fmt_9999[] = "(\002 ROUTINES PASS COMPUTATIONAL TESTS IF TES" + "T RATIO IS LES\002,\002S THAN\002,f8.2)"; + static char fmt_10002[] = "(\002 COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS" + " ARE TESTED\002)"; + static char fmt_10001[] = "(\002 ROW-MAJOR DATA LAYOUT IS TESTED\002)"; + static char fmt_10000[] = "(\002 COLUMN-MAJOR DATA LAYOUT IS TESTED\002)"; + static char fmt_9988[] = "(a13,l2)"; + static char fmt_9990[] = "(\002 SUBPROGRAM NAME \002,a13,\002 NOT RECOGN" + "IZED\002,/\002 ******* T\002,\002ESTS ABANDONED *******\002)"; + static char fmt_9998[] = "(\002 RELATIVE MACHINE PRECISION IS TAKEN TO" + " BE\002,1p,e9.1)"; + static char fmt_9989[] = "(\002 ERROR IN CMMCH - IN-LINE DOT PRODUCTS A" + "RE BEING EVALU\002,\002ATED WRONGLY.\002,/\002 CMMCH WAS CALLED " + "WITH TRANSA = \002,a1,\002AND TRANSB = \002,a1,/\002 AND RETURNE" + "D SAME = \002,l1,\002 AND \002,\002 ERR = \002,f12.3,\002.\002," + "/\002 THIS MAY BE DUE TO FAULTS IN THE \002,\002ARITHMETIC OR TH" + "E COMPILER.\002,/\002 ******* TESTS ABANDONED \002,\002******" + "*\002)"; + static char fmt_9987[] = "(1x,a13,\002 WAS NOT TESTED\002)"; + static char fmt_9986[] = "(/\002 END OF TESTS\002)"; + static char fmt_9985[] = "(/\002 ******* FATAL ERROR - TESTS ABANDONED *" + "******\002)"; + static char fmt_9991[] = "(\002 AMEND DATA FILE OR INCREASE ARRAY SIZES " + "IN PROGRAM\002,/\002 ******* TESTS ABANDONED *******\002)"; /* System generated locals */ integer i__1, i__2, i__3, i__4, i__5; real r__1; + olist o__1; + cllist cl__1; /* Local variables */ + complex c__[4225] /* was [65][65] */; + real g[65]; + integer i__, j, n; + complex w[130], aa[4225], ab[8450] /* was [65][130] */, bb[4225], cc[ + 4225], as[4225], bs[4225], cs[4225], ct[65], alf[7]; + extern logical lce_(complex *, complex *, integer *); + complex bet[7]; + real eps, err; integer nalf, idim[9]; logical same; integer nbet, ntra; @@ -310,12 +466,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 +482,68 @@ 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; + + /* Fortran I/O blocks */ + static cilist io___2 = { 0, 5, 0, 0, 0 }; + static cilist io___4 = { 0, 5, 0, 0, 0 }; + static cilist io___7 = { 0, 5, 0, 0, 0 }; + static cilist io___9 = { 0, 5, 0, 0, 0 }; + static cilist io___11 = { 0, 5, 0, 0, 0 }; + static cilist io___13 = { 0, 5, 0, 0, 0 }; + static cilist io___15 = { 0, 5, 0, 0, 0 }; + static cilist io___17 = { 0, 5, 0, 0, 0 }; + static cilist io___19 = { 0, 6, 0, fmt_9997, 0 }; + static cilist io___20 = { 0, 5, 0, 0, 0 }; + static cilist io___23 = { 0, 6, 0, fmt_9996, 0 }; + static cilist io___24 = { 0, 5, 0, 0, 0 }; + static cilist io___26 = { 0, 6, 0, fmt_9997, 0 }; + static cilist io___27 = { 0, 5, 0, 0, 0 }; + static cilist io___29 = { 0, 5, 0, 0, 0 }; + static cilist io___31 = { 0, 6, 0, fmt_9997, 0 }; + static cilist io___32 = { 0, 5, 0, 0, 0 }; + static cilist io___34 = { 0, 6, 0, fmt_9995, 0 }; + static cilist io___35 = { 0, 6, 0, fmt_9994, 0 }; + static cilist io___36 = { 0, 6, 0, fmt_9993, 0 }; + static cilist io___37 = { 0, 6, 0, fmt_9992, 0 }; + static cilist io___38 = { 0, 6, 0, 0, 0 }; + static cilist io___39 = { 0, 6, 0, fmt_9984, 0 }; + static cilist io___40 = { 0, 6, 0, 0, 0 }; + static cilist io___41 = { 0, 6, 0, fmt_9999, 0 }; + static cilist io___42 = { 0, 6, 0, 0, 0 }; + static cilist io___45 = { 0, 6, 0, fmt_10002, 0 }; + static cilist io___46 = { 0, 6, 0, fmt_10001, 0 }; + static cilist io___47 = { 0, 6, 0, fmt_10000, 0 }; + static cilist io___48 = { 0, 6, 0, 0, 0 }; + static cilist io___50 = { 0, 5, 1, fmt_9988, 0 }; + static cilist io___53 = { 0, 6, 0, fmt_9990, 0 }; + static cilist io___55 = { 0, 6, 0, fmt_9998, 0 }; + static cilist io___68 = { 0, 6, 0, fmt_9989, 0 }; + static cilist io___69 = { 0, 6, 0, fmt_9989, 0 }; + static cilist io___70 = { 0, 6, 0, fmt_9989, 0 }; + static cilist io___71 = { 0, 6, 0, fmt_9989, 0 }; + static cilist io___73 = { 0, 6, 0, 0, 0 }; + static cilist io___74 = { 0, 6, 0, fmt_9987, 0 }; + static cilist io___75 = { 0, 6, 0, 0, 0 }; + static cilist io___82 = { 0, 6, 0, fmt_9986, 0 }; + static cilist io___83 = { 0, 6, 0, fmt_9985, 0 }; + static cilist io___84 = { 0, 6, 0, fmt_9991, 0 }; + + /* Test program for the COMPLEX Level 3 Blas. */ /* The program must be driven by a short data file. The first 13 records */ -/* of the file are read using list-directed input, the last 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 +557,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,19 +587,16 @@ int /* Main program */ main(void) infoc_1.noutc = 6; /* Read name and unit number for snapshot output file and open file. */ - char line[80]; - - fgets(line,80,stdin); - sscanf(line,"'%s'",snaps); - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&ntra); -#else - sscanf(line,"%d",&ntra); -#endif + + s_rsle(&io___2); + do_lio(&c__9, &c__1, snaps, (ftnlen)32); + e_rsle(); + s_rsle(&io___4); + do_lio(&c__3, &c__1, (char *)&ntra, (ftnlen)sizeof(integer)); + e_rsle(); trace = ntra >= 0; if (trace) { -/* o__1.oerr = 0; + o__1.oerr = 0; o__1.ounit = ntra; o__1.ofnmlen = 32; o__1.ofnm = snaps; @@ -411,158 +605,192 @@ 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); - sscanf(line,"%d",&rewi); - rewi = rewi && trace; + s_rsle(&io___7); + do_lio(&c__8, &c__1, (char *)&rewi, (ftnlen)sizeof(logical)); + e_rsle(); + rewi = rewi && trace; /* Read the flag that directs stopping on any failure. */ - fgets(line,80,stdin); - sscanf(line,"%c",&tmpchar); - sfatal=FALSE_; - if (tmpchar=='T')sfatal=TRUE_; - fgets(line,80,stdin); - sscanf(line,"%c",&tmpchar); - tsterr=FALSE_; - if (tmpchar=='T')tsterr=TRUE_; - fgets(line,80,stdin); - sscanf(line,"%d",&layout); - fgets(line,80,stdin); - sscanf(line,"%f",&thresh); - + s_rsle(&io___9); + do_lio(&c__8, &c__1, (char *)&sfatal, (ftnlen)sizeof(logical)); + e_rsle(); +/* Read the flag that indicates whether error exits are to be tested. */ + s_rsle(&io___11); + do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical)); + e_rsle(); +/* Read the flag that indicates whether row-major data layout to be tested. */ + s_rsle(&io___13); + do_lio(&c__3, &c__1, (char *)&layout, (ftnlen)sizeof(integer)); + e_rsle(); +/* Read the threshold value of the test ratio */ + s_rsle(&io___15); + do_lio(&c__4, &c__1, (char *)&thresh, (ftnlen)sizeof(real)); + e_rsle(); /* Read and check the parameter values for the tests. */ /* Values of N */ - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&nidim); -#else - sscanf(line,"%d",&nidim); -#endif - + s_rsle(&io___17); + do_lio(&c__3, &c__1, (char *)&nidim, (ftnlen)sizeof(integer)); + e_rsle(); if (nidim < 1 || nidim > 9) { - fprintf(stderr,"NUMBER OF VALUES OF N IS LESS THAN 1 OR GREATER THAN 9"); + s_wsfe(&io___19); + do_fio(&c__1, "N", (ftnlen)1); + do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer)); + e_wsfe(); goto L220; } - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld %ld %ld %ld %ld %ld %ld %ld %ld",&idim[0],&idim[1],&idim[2], - &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]); -#else - sscanf(line,"%d %d %d %d %d %d %d %d %d",&idim[0],&idim[1],&idim[2], - &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]); -#endif + s_rsle(&io___20); + i__1 = nidim; + for (i__ = 1; i__ <= i__1; ++i__) { + do_lio(&c__3, &c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer)); + } + e_rsle(); i__1 = nidim; for (i__ = 1; i__ <= i__1; ++i__) { if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) { - fprintf(stderr,"VALUE OF N IS LESS THAN 0 OR GREATER THAN 65\n"); + s_wsfe(&io___23); + do_fio(&c__1, (char *)&c__65, (ftnlen)sizeof(integer)); + e_wsfe(); goto L220; } /* L10: */ } /* Values of ALPHA */ - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&nalf); -#else - sscanf(line,"%d",&nalf); -#endif + s_rsle(&io___24); + do_lio(&c__3, &c__1, (char *)&nalf, (ftnlen)sizeof(integer)); + e_rsle(); if (nalf < 1 || nalf > 7) { - fprintf(stderr,"VALUE OF ALPHA IS LESS THAN 0 OR GREATER THAN 7\n"); + s_wsfe(&io___26); + do_fio(&c__1, "ALPHA", (ftnlen)5); + do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer)); + e_wsfe(); goto L220; } - 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)); -// } + s_rsle(&io___27); + i__1 = nalf; + for (i__ = 1; i__ <= i__1; ++i__) { + do_lio(&c__6, &c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(complex)); + } + e_rsle(); /* Values of BETA */ - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&nbet); -#else - sscanf(line,"%d",&nbet); -#endif - if (nalf < 1 || nbet > 7) { - fprintf(stderr,"VALUE OF BETA IS LESS THAN 0 OR GREATER THAN 7\n"); + s_rsle(&io___29); + do_lio(&c__3, &c__1, (char *)&nbet, (ftnlen)sizeof(integer)); + e_rsle(); + if (nbet < 1 || nbet > 7) { + s_wsfe(&io___31); + do_fio(&c__1, "BETA", (ftnlen)4); + do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer)); + e_wsfe(); goto L220; } - fgets(line,80,stdin); - sscanf(line,"(%f,%f) (%f,%f) (%f,%f) (%f,%f) (%f,%f) (%f,%f) (%f,%f)",&bet[0].r,&bet[0].i,&bet[1].r,&bet[1].i,&bet[2].r,&bet[2].i,&bet[3].r,&bet[3].i, - &bet[4].r,&bet[4].i,&bet[5].r,&bet[5].i,&bet[6].r,&bet[6].i); - + s_rsle(&io___32); + i__1 = nbet; + for (i__ = 1; i__ <= i__1; ++i__) { + do_lio(&c__6, &c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(complex)); + } + e_rsle(); /* Report values of parameters. */ - printf("TESTS OF THE COMPLEX LEVEL 3 BLAS\nTHE FOLLOWING PARAMETER VALUES WILL BE USED:\n"); - printf(" FOR N"); - for (i__ =1; i__ <=nidim;++i__) printf(" %d",idim[i__-1]); - printf("\n"); - printf(" FOR ALPHA"); - for (i__ =1; i__ <=nalf;++i__) printf(" (%f,%f)",alf[i__-1].r,alf[i__-1].i); - printf("\n"); - printf(" FOR BETA"); - for (i__ =1; i__ <=nbet;++i__) printf(" (%f,%f)",bet[i__-1].r,bet[i__-1].i); - printf("\n"); - + s_wsfe(&io___34); + e_wsfe(); + s_wsfe(&io___35); + i__1 = nidim; + for (i__ = 1; i__ <= i__1; ++i__) { + do_fio(&c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer)); + } + e_wsfe(); + s_wsfe(&io___36); + i__1 = nalf; + for (i__ = 1; i__ <= i__1; ++i__) { + do_fio(&c__2, (char *)&alf[i__ - 1], (ftnlen)sizeof(real)); + } + e_wsfe(); + s_wsfe(&io___37); + i__1 = nbet; + for (i__ = 1; i__ <= i__1; ++i__) { + do_fio(&c__2, (char *)&bet[i__ - 1], (ftnlen)sizeof(real)); + } + e_wsfe(); if (! tsterr) { - printf(" ERROR-EXITS WILL NOT BE TESTED\n"); + s_wsle(&io___38); + e_wsle(); + s_wsfe(&io___39); + e_wsfe(); } - printf("ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LESS THAN %f\n",thresh); + s_wsle(&io___40); + e_wsle(); + s_wsfe(&io___41); + do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(real)); + e_wsfe(); + s_wsle(&io___42); + e_wsle(); rorder = FALSE_; corder = FALSE_; if (layout == 2) { rorder = TRUE_; corder = TRUE_; - printf("COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED\n"); + s_wsfe(&io___45); + e_wsfe(); } else if (layout == 1) { rorder = TRUE_; - printf("ROW-MAJOR DATA LAYOUT IS TESTED\n"); + s_wsfe(&io___46); + e_wsfe(); } else if (layout == 0) { corder = TRUE_; - printf("COLUMN-MAJOR DATA LAYOUT IS TESTED\n"); + s_wsfe(&io___47); + e_wsfe(); } + s_wsle(&io___48); + e_wsle(); /* Read names of subroutines and flags which indicate */ /* whether they are to be tested. */ - for (i__ = 1; i__ <= 9; ++i__) { + for (i__ = 1; i__ <= 10; ++i__) { ltest[i__ - 1] = FALSE_; /* L20: */ } L30: - if (! fgets(line,80,stdin)) { + i__1 = s_rsfe(&io___50); + if (i__1 != 0) { + goto L60; + } + i__1 = do_fio(&c__1, snamet, (ftnlen)13); + if (i__1 != 0) { + goto L60; + } + i__1 = do_fio(&c__1, (char *)<estt, (ftnlen)sizeof(logical)); + if (i__1 != 0) { goto L60; } - i__1 = sscanf(line,"%12c %c",snamet,&tmpchar); - ltestt=FALSE_; - if (tmpchar=='T')ltestt=TRUE_; - if (i__1 < 2) { + i__1 = e_rsfe(); + if (i__1 != 0) { 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) * 13, (ftnlen)13, (ftnlen)13) == 0) { goto L50; } /* L40: */ } - printf("SUBPROGRAM NAME %s NOT RECOGNIZED\n****** TESTS ABANDONED ******\n",snamet); - exit(1); + s_wsfe(&io___53); + do_fio(&c__1, snamet, (ftnlen)13); + e_wsfe(); + s_stop("", (ftnlen)0); L50: ltest[i__ - 1] = ltestt; goto L30; L60: -/* cl__1.cerr = 0; + cl__1.cerr = 0; cl__1.cunit = 5; cl__1.csta = 0; - f_clos(&cl__1);*/ + f_clos(&cl__1); /* Compute EPS (the machine precision). */ @@ -576,7 +804,9 @@ int /* Main program */ main(void) goto L70; L80: eps += eps; - printf("RELATIVE MACHINE PRECISION IS TAKEN TO BE %9.1g\n",eps); + s_wsfe(&io___55); + do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real)); + e_wsfe(); /* Check the reliability of CMMCH using exact data. */ @@ -616,12 +846,13 @@ int /* Main program */ main(void) &c__6, &c_true); same = lce_(cc, ct, &n); if (! same || err != 0.f) { - printf("ERROR IN CMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); - printf("CMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); - printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); - printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); - printf("****** TESTS ABANDONED ******\n"); - exit(1); + s_wsfe(&io___68); + do_fio(&c__1, transa, (ftnlen)1); + do_fio(&c__1, transb, (ftnlen)1); + do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical)); + do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real)); + e_wsfe(); + s_stop("", (ftnlen)0); } *(unsigned char *)transb = 'C'; cmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], & @@ -629,12 +860,13 @@ int /* Main program */ main(void) &c__6, &c_true); same = lce_(cc, ct, &n); if (! same || err != 0.f) { - printf("ERROR IN CMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); - printf("CMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); - printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); - printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); - printf("****** TESTS ABANDONED ******\n"); - exit(1); + s_wsfe(&io___69); + do_fio(&c__1, transa, (ftnlen)1); + do_fio(&c__1, transb, (ftnlen)1); + do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical)); + do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real)); + e_wsfe(); + s_stop("", (ftnlen)0); } i__1 = n; for (j = 1; j <= i__1; ++j) { @@ -660,12 +892,13 @@ int /* Main program */ main(void) &c__6, &c_true); same = lce_(cc, ct, &n); if (! same || err != 0.f) { - printf("ERROR IN CMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); - printf("CMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); - printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); - printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); - printf("****** TESTS ABANDONED ******\n"); - exit(1); + s_wsfe(&io___70); + do_fio(&c__1, transa, (ftnlen)1); + do_fio(&c__1, transb, (ftnlen)1); + do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical)); + do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real)); + e_wsfe(); + s_stop("", (ftnlen)0); } *(unsigned char *)transb = 'C'; cmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], & @@ -673,26 +906,33 @@ int /* Main program */ main(void) &c__6, &c_true); same = lce_(cc, ct, &n); if (! same || err != 0.f) { - printf("ERROR IN CMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n"); - printf("CMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); - printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); - printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); - printf("****** TESTS ABANDONED ******\n"); - exit(1); + s_wsfe(&io___71); + do_fio(&c__1, transa, (ftnlen)1); + do_fio(&c__1, transb, (ftnlen)1); + do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical)); + do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real)); + e_wsfe(); + s_stop("", (ftnlen)0); } /* Test each subroutine in turn. */ - for (isnum = 1; isnum <= 9; ++isnum) { + for (isnum = 1; isnum <= 10; ++isnum) { + s_wsle(&io___73); + e_wsle(); if (! ltest[isnum - 1]) { /* Subprogram is not to be tested. */ - printf("%12s WAS NOT TESTED\n",snames[isnum-1]); + s_wsfe(&io___74); + do_fio(&c__1, snames + (isnum - 1) * 13, (ftnlen)13); + e_wsfe(); } else { - s_copy(srnamc_1.srnamt, snames[isnum - 1], (ftnlen)12, ( - ftnlen)12); + s_copy(srnamc_1.srnamt, snames + (isnum - 1) * 13, (ftnlen)13, ( + ftnlen)13); /* Test error exits. */ if (tsterr) { - cc3chke_(snames[isnum - 1]); + cc3chke_(snames + (isnum - 1) * 13); + s_wsle(&io___75); + e_wsle(); } /* Test computations. */ infoc_1.infot = 0; @@ -708,17 +948,18 @@ 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: if (corder) { - cchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + cchk1_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, cc, cs, ct, g, &c__0); } if (rorder) { - cchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + cchk1_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, cc, cs, ct, g, &c__1); @@ -727,13 +968,13 @@ int /* Main program */ main(void) /* Test CHEMM, 02, CSYMM, 03. */ L150: if (corder) { - cchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + cchk2_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, cc, cs, ct, g, &c__0); } if (rorder) { - cchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + cchk2_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, cc, cs, ct, g, &c__1); @@ -742,13 +983,13 @@ int /* Main program */ main(void) /* Test CTRMM, 04, CTRSM, 05. */ L160: if (corder) { - cchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + cchk3_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, & c__0); } if (rorder) { - cchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + cchk3_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, & c__1); @@ -757,13 +998,13 @@ int /* Main program */ main(void) /* Test CHERK, 06, CSYRK, 07. */ L170: if (corder) { - cchk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + cchk4_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, cc, cs, ct, g, &c__0); } if (rorder) { - cchk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + cchk4_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, cc, cs, ct, g, &c__1); @@ -772,18 +1013,33 @@ int /* Main program */ main(void) /* Test CHER2K, 08, CSYR2K, 09. */ L180: if (corder) { - cchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + cchk5_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, ct, g, w, &c__0); } if (rorder) { - cchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + cchk5_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, ct, g, w, &c__1); } goto L190; +/* Test CGEMMTR, 10. */ +L185: + if (corder) { + cchk6_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__0); + } + if (rorder) { + cchk6_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__1); + } + goto L190; L190: if (fatal && sfatal) { @@ -792,29 +1048,32 @@ int /* Main program */ main(void) } /* L200: */ } - printf("\nEND OF TESTS\n"); + s_wsfe(&io___82); + e_wsfe(); goto L230; L210: - printf("\n****** FATAL ERROR - TESTS ABANDONED ******\n"); + s_wsfe(&io___83); + e_wsfe(); goto L230; L220: - printf("AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM\n"); - printf("****** TESTS ABANDONED ******\n"); + s_wsfe(&io___84); + e_wsfe(); + L230: if (trace) { -/* cl__1.cerr = 0; + cl__1.cerr = 0; cl__1.cunit = ntra; cl__1.csta = 0; - f_clos(&cl__1);*/ + f_clos(&cl__1); } -/* cl__1.cerr = 0; + cl__1.cerr = 0; cl__1.cunit = 6; cl__1.csta = 0; f_clos(&cl__1); - s_stop("", (ftnlen)0);*/ - exit(0); + s_stop("", (ftnlen)0); + /* End of CBLAT3. */ @@ -832,15 +1091,40 @@ int /* Main program */ main(void) static char ich[3] = "NTC"; + /* Format strings */ + static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT " + "TAKEN ON VALID CALL *******\002)"; + static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER" + " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)"; + static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO" + "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR " + " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM" + "BER:\002)"; + /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8; + alist al__1; /* Local variables */ + integer i__, k, m, n, ia, ib, ma, mb, na, nb, nc, ik, im, in, ks, ms, ns, + ica, icb, laa, lbb, lda, lcc, ldb, ldc; + extern logical lce_(complex *, complex *, integer *); + complex als, bls; + real err; complex beta; integer ldas, ldbs, ldcs; logical same, null; - integer i__, k, m, n; extern /* Subroutine */ int cmake_(char *, char *, char *, integer *, integer *, complex *, integer *, complex *, integer *, logical *, complex *); @@ -854,20 +1138,24 @@ int /* Main program */ main(void) logical reset; extern /* Subroutine */ int cprcn1_(integer *, integer *, char *, integer *, char *, char *, integer *, integer *, integer *, complex *, - integer *, integer *, complex *, integer *); - integer ia, ib, ma, mb, na, nb, nc, ik, im, in; - extern /* Subroutine */ int ccgemm_(integer *, char *, char *, integer *, - integer *, integer *, complex *, complex *, integer *, complex *, - integer *, complex *, complex *, integer *); - integer ks, ms, ns; + integer *, integer *, complex *, integer *), ccgemm_(integer *, char *, char *, integer *, integer *, + integer *, complex *, complex *, integer *, complex *, integer *, + complex *, complex *, integer *); extern logical lceres_(char *, char *, integer *, integer *, complex *, complex *, integer *); char tranas[1], tranbs[1], transa[1], transb[1]; real errmax; - integer ica, icb, laa, lbb, lda, lcc, ldb, ldc; - extern logical lce_(complex *, complex *, integer *); - complex als, bls; - real err; + + /* Fortran I/O blocks */ + static cilist io___128 = { 0, 0, 0, fmt_9994, 0 }; + static cilist io___131 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___133 = { 0, 0, 0, fmt_10000, 0 }; + static cilist io___134 = { 0, 0, 0, fmt_10001, 0 }; + static cilist io___135 = { 0, 0, 0, fmt_10002, 0 }; + static cilist io___136 = { 0, 0, 0, fmt_10003, 0 }; + static cilist io___137 = { 0, 0, 0, fmt_9996, 0 }; + + /* Tests CGEMM. */ @@ -888,17 +1176,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 */ @@ -1054,9 +1342,9 @@ int /* Main program */ main(void) &ldb, &beta, &ldc); } if (*rewi) { -/* al__1.aerr = 0; + al__1.aerr = 0; al__1.aunit = *ntra; - f_rew(&al__1); */ + f_rew(&al__1); } ccgemm_(iorder, transa, transb, &m, &n, &k, & alpha, &aa[1], &lda, &bb[1], &ldb, & @@ -1065,10 +1353,9 @@ 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"); + io___128.ciunit = *nout; + s_wsfe(&io___128); + e_wsfe(); *fatal = TRUE_; goto L120; } @@ -1106,7 +1393,11 @@ int /* Main program */ main(void) for (i__ = 1; i__ <= i__6; ++i__) { same = same && isame[i__ - 1]; if (! isame[i__ - 1]) { - printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__);; + io___131.ciunit = *nout; + s_wsfe(&io___131); + do_fio(&c__1, (char *)&i__, (ftnlen) + sizeof(integer)); + e_wsfe(); } /* L40: */ } @@ -1160,32 +1451,51 @@ int /* Main program */ main(void) if (errmax < *thresh) { if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___133.ciunit = *nout; + s_wsfe(&io___133); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___134.ciunit = *nout; + s_wsfe(&io___134); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } } else { if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___135.ciunit = *nout; + s_wsfe(&io___135); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real)); + e_wsfe(); } if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___136.ciunit = *nout; + s_wsfe(&io___136); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real)); + e_wsfe(); } } goto L130; L120: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + io___137.ciunit = *nout; + s_wsfe(&io___137); + do_fio(&c__1, sname, (ftnlen)13); + e_wsfe(); cprcn1_(nout, &nc, sname, iorder, transa, transb, &m, &n, &k, &alpha, & lda, &ldb, &beta, &ldc); L130: return 0; -/* 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',', */ +/* 9995 FORMAT( 1X, I6, ': ', A13,'(''', A1, ''',''', A1, ''',', */ /* $ 3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, */ /* $ ',(', F4.1, ',', F4.1, '), C,', I3, ').' ) */ @@ -1199,9 +1509,21 @@ int /* Main program */ main(void) k, complex *alpha, integer *lda, integer *ldb, complex *beta, integer *ldc) { + /* Format strings */ + static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002," + "a14,\002,\002,a14,\002,\002)"; + static char fmt_9994[] = "(10x,3(i3,\002,\002),\002 (\002,f4.1,\002,\002" + ",f4.1,\002) , A,\002,i3,\002, B,\002,i3,\002, (\002,f4.1,\002" + ",\002,f4.1,\002) , C,\002,i3,\002).\002)"; + /* Local variables */ char crc[14], cta[14], ctb[14]; + /* Fortran I/O blocks */ + static cilist io___141 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___142 = { 0, 0, 0, fmt_9994, 0 }; + + if (*(unsigned char *)transa == 'N') { s_copy(cta, " CblasNoTrans", (ftnlen)14, (ftnlen)14); } else if (*(unsigned char *)transa == 'T') { @@ -1221,8 +1543,25 @@ int /* Main program */ main(void) } else { s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cta,ctb); - printf("%d %d %d (%4.1f,%4.1f) , A, %d, B, %d, (%4.1f,%4.1f) , C, %d.\n",*m,*n,*k,alpha->r,alpha->i,*lda,*ldb,beta->r,beta->i,*ldc); + io___141.ciunit = *nout; + s_wsfe(&io___141); + do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer)); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, crc, (ftnlen)14); + do_fio(&c__1, cta, (ftnlen)14); + do_fio(&c__1, ctb, (ftnlen)14); + e_wsfe(); + io___142.ciunit = *nout; + s_wsfe(&io___142); + do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(real)); + do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(real)); + do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer)); + e_wsfe(); return 0; } /* cprcn1_ */ @@ -1239,18 +1578,45 @@ int /* Main program */ main(void) static char ichs[2] = "LR"; static char ichu[2] = "UL"; + /* Format strings */ + static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT " + "TAKEN ON VALID CALL *******\002)"; + static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER" + " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)"; + static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO" + "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR " + " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM" + "BER:\002)"; + /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7; + alist al__1; /* Local variables */ + integer i__, m, n, ia, ib, na, nc, im, in, ms, ns, laa, lbb, lda, lcc, + ldb, ldc; + extern logical lce_(complex *, complex *, integer *); + integer ics; + complex als, bls; + integer icu; + real err; complex beta; integer ldas, ldbs, ldcs; logical same; char side[1]; logical conj, left, null; char uplo[1]; - integer i__, m, n; extern /* Subroutine */ int cmake_(char *, char *, char *, integer *, integer *, complex *, integer *, complex *, integer *, logical *, complex *); @@ -1266,24 +1632,27 @@ int /* Main program */ main(void) char uplos[1]; extern /* Subroutine */ int cprcn2_(integer *, integer *, char *, integer *, char *, char *, integer *, integer *, complex *, integer *, - integer *, complex *, integer *); - integer ia, ib, na, nc, im, in; - extern /* Subroutine */ int cchemm_(integer *, char *, char *, integer *, - integer *, complex *, complex *, integer *, complex *, integer *, - complex *, complex *, integer *); - integer ms, ns; + integer *, complex *, integer *), cchemm_( + integer *, char *, char *, integer *, integer *, complex *, + complex *, integer *, complex *, integer *, complex *, complex *, + integer *); extern logical lceres_(char *, char *, integer *, integer *, complex *, complex *, integer *); extern /* Subroutine */ int ccsymm_(integer *, char *, char *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *); real errmax; - integer laa, lbb, lda, lcc, ldb, ldc; - extern logical lce_(complex *, complex *, integer *); - integer ics; - complex als, bls; - integer icu; - real err; + + /* Fortran I/O blocks */ + static cilist io___181 = { 0, 0, 0, fmt_9994, 0 }; + static cilist io___184 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___186 = { 0, 0, 0, fmt_10000, 0 }; + static cilist io___187 = { 0, 0, 0, fmt_10001, 0 }; + static cilist io___188 = { 0, 0, 0, fmt_10002, 0 }; + static cilist io___189 = { 0, 0, 0, fmt_10003, 0 }; + static cilist io___190 = { 0, 0, 0, fmt_9996, 0 }; + + /* Tests CHEMM and CSYMM. */ @@ -1304,17 +1673,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 */ @@ -1450,9 +1819,9 @@ int /* Main program */ main(void) ; } if (*rewi) { -/* al__1.aerr = 0; + al__1.aerr = 0; al__1.aunit = *ntra; - f_rew(&al__1);*/ + f_rew(&al__1); } if (conj) { cchemm_(iorder, side, uplo, &m, &n, &alpha, & @@ -1467,7 +1836,9 @@ int /* Main program */ main(void) /* Check if error-exit was taken incorrectly. */ if (! infoc_1.ok) { - printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + io___181.ciunit = *nout; + s_wsfe(&io___181); + e_wsfe(); *fatal = TRUE_; goto L110; } @@ -1502,7 +1873,11 @@ int /* Main program */ main(void) 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__); + io___184.ciunit = *nout; + s_wsfe(&io___184); + do_fio(&c__1, (char *)&i__, (ftnlen) + sizeof(integer)); + e_wsfe(); } /* L40: */ } @@ -1560,34 +1935,51 @@ int /* Main program */ main(void) if (errmax < *thresh) { if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___186.ciunit = *nout; + s_wsfe(&io___186); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___187.ciunit = *nout; + s_wsfe(&io___187); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } } else { if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___188.ciunit = *nout; + s_wsfe(&io___188); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real)); + e_wsfe(); } if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___189.ciunit = *nout; + s_wsfe(&io___189); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real)); + e_wsfe(); } } goto L120; L110: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + io___190.ciunit = *nout; + s_wsfe(&io___190); + do_fio(&c__1, sname, (ftnlen)13); + e_wsfe(); cprcn2_(nout, &nc, sname, iorder, side, uplo, &m, &n, &alpha, &lda, &ldb, &beta, &ldc); L120: return 0; -/* 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 CCHK2. */ @@ -1598,9 +1990,21 @@ int /* Main program */ main(void) *iorder, char *side, char *uplo, integer *m, integer *n, complex * alpha, integer *lda, integer *ldb, complex *beta, integer *ldc) { + /* Format strings */ + static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002," + "a14,\002,\002,a14,\002,\002)"; + static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002" + ",f4.1,\002), A,\002,i3,\002, B,\002,i3,\002, (\002,f4.1,\002," + "\002,f4.1,\002), \002,\002C,\002,i3,\002).\002)"; + /* Local variables */ char cs[14], cu[14], crc[14]; + /* Fortran I/O blocks */ + static cilist io___194 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___195 = { 0, 0, 0, fmt_9994, 0 }; + + if (*(unsigned char *)side == 'L') { s_copy(cs, " CblasLeft", (ftnlen)14, (ftnlen)14); } else { @@ -1616,8 +2020,24 @@ int /* Main program */ main(void) } else { s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cs,cu); - printf("%d %d (%4.1f,%4.1f) , A, %d, B, %d, (%4.1f,%4.1f) , C, %d.\n",*m,*n,alpha->r,alpha->i,*lda,*ldb,beta->r,beta->i,*ldc); + io___194.ciunit = *nout; + s_wsfe(&io___194); + do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer)); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, crc, (ftnlen)14); + do_fio(&c__1, cs, (ftnlen)14); + do_fio(&c__1, cu, (ftnlen)14); + e_wsfe(); + io___195.ciunit = *nout; + s_wsfe(&io___195); + do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(real)); + do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(real)); + do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer)); + e_wsfe(); return 0; } /* cprcn2_ */ @@ -1635,19 +2055,45 @@ int /* Main program */ main(void) static char ichd[2] = "UN"; static char ichs[2] = "LR"; + /* Format strings */ + static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT " + "TAKEN ON VALID CALL *******\002)"; + static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER" + " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)"; + static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO" + "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR " + " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM" + "BER:\002)"; + /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7; complex q__1; + alist al__1; /* Local variables */ + integer i__, j, m, n, ia, na, nc, im, in, ms, ns, laa, icd, lbb, lda, ldb; + extern logical lce_(complex *, complex *, integer *); + integer ics; + complex als; + integer ict, icu; + real err; char diag[1]; integer ldas, ldbs; logical same; char side[1]; logical left, null; char uplo[1]; - integer i__, j, m, n; extern /* Subroutine */ int cmake_(char *, char *, char *, integer *, integer *, complex *, integer *, complex *, integer *, logical *, complex *); @@ -1665,7 +2111,6 @@ int /* Main program */ main(void) extern /* Subroutine */ int cprcn3_(integer *, integer *, char *, integer *, char *, char *, char *, char *, integer *, integer *, complex * , integer *, integer *); - integer ia, na, nc, im, in, ms, ns; extern logical lceres_(char *, char *, integer *, integer *, complex *, complex *, integer *); extern /* Subroutine */ int cctrmm_(integer *, char *, char *, char *, @@ -1676,12 +2121,17 @@ int /* Main program */ main(void) char *, integer *, integer *, complex *, complex *, integer *, complex *, integer *); real errmax; - integer laa, icd, lbb, lda, ldb; - extern logical lce_(complex *, complex *, integer *); - integer ics; - complex als; - integer ict, icu; - real err; + + /* Fortran I/O blocks */ + static cilist io___236 = { 0, 0, 0, fmt_9994, 0 }; + static cilist io___239 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___241 = { 0, 0, 0, fmt_10000, 0 }; + static cilist io___242 = { 0, 0, 0, fmt_10001, 0 }; + static cilist io___243 = { 0, 0, 0, fmt_10002, 0 }; + static cilist io___244 = { 0, 0, 0, fmt_10003, 0 }; + static cilist io___245 = { 0, 0, 0, fmt_9996, 0 }; + + /* Tests CTRMM and CTRSM. */ @@ -1697,19 +2147,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 */ @@ -1837,14 +2287,14 @@ int /* Main program */ main(void) if (*trace) { cprcn3_(ntra, &nc, sname, iorder, side, uplo, transa, diag, &m, - &n, &alpha, &lda, &ldb/*, ( - ftnlen)12, (ftnlen)1, (ftnlen) - 1, (ftnlen)1, (ftnlen)1*/); + &n, &alpha, &lda, &ldb, ( + ftnlen)13, (ftnlen)1, (ftnlen) + 1, (ftnlen)1, (ftnlen)1); } if (*rewi) { -/* al__1.aerr = 0; + al__1.aerr = 0; al__1.aunit = *ntra; - f_rew(&al__1);*/ + f_rew(&al__1); } cctrmm_(iorder, side, uplo, transa, diag, &m, &n, &alpha, &aa[1], &lda, &bb[ @@ -1854,14 +2304,14 @@ int /* Main program */ main(void) if (*trace) { cprcn3_(ntra, &nc, sname, iorder, side, uplo, transa, diag, &m, - &n, &alpha, &lda, &ldb/*, ( - ftnlen)12, (ftnlen)1, (ftnlen) - 1, (ftnlen)1, (ftnlen)1*/); + &n, &alpha, &lda, &ldb, ( + ftnlen)13, (ftnlen)1, (ftnlen) + 1, (ftnlen)1, (ftnlen)1); } if (*rewi) { -/* al__1.aerr = 0; + al__1.aerr = 0; al__1.aunit = *ntra; - f_rew(&al__1);*/ + f_rew(&al__1); } cctrsm_(iorder, side, uplo, transa, diag, &m, &n, &alpha, &aa[1], &lda, &bb[ @@ -1871,7 +2321,9 @@ int /* Main program */ main(void) /* Check if error-exit was taken incorrectly. */ if (! infoc_1.ok) { - printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + io___236.ciunit = *nout; + s_wsfe(&io___236); + e_wsfe(); *fatal = TRUE_; goto L150; } @@ -1908,7 +2360,11 @@ int /* Main program */ main(void) for (i__ = 1; i__ <= i__4; ++i__) { same = same && isame[i__ - 1]; if (! isame[i__ - 1]) { - printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + io___239.ciunit = *nout; + s_wsfe(&io___239); + do_fio(&c__1, (char *)&i__, (ftnlen) + sizeof(integer)); + e_wsfe(); } /* L50: */ } @@ -1930,8 +2386,8 @@ int /* Main program */ main(void) c_b1, &c__[c_offset], nmax, &ct[1], &g[1], &bb[ 1], &ldb, eps, &err, - fatal, nout, &c_true/*, ( - ftnlen)1, (ftnlen)1*/); + fatal, nout, &c_true, ( + ftnlen)1, (ftnlen)1); } else { cmmch_("N", transa, &m, &n, &n, & alpha, &b[b_offset], nmax, @@ -2018,25 +2474,44 @@ int /* Main program */ main(void) if (errmax < *thresh) { if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___241.ciunit = *nout; + s_wsfe(&io___241); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___242.ciunit = *nout; + s_wsfe(&io___242); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } } else { if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___243.ciunit = *nout; + s_wsfe(&io___243); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real)); + e_wsfe(); } if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___244.ciunit = *nout; + s_wsfe(&io___244); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real)); + e_wsfe(); } } goto L160; L150: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + io___245.ciunit = *nout; + s_wsfe(&io___245); + do_fio(&c__1, sname, (ftnlen)13); + e_wsfe(); if (*trace) { cprcn3_(ntra, &nc, sname, iorder, side, uplo, transa, diag, &m, &n, & alpha, &lda, &ldb); @@ -2045,9 +2520,7 @@ int /* Main program */ main(void) L160: return 0; -/* 9995 FORMAT(1X, I6, ': ', A12,'(', 4( '''', A1, ''',' ), 2( I3, ',' ), */ -/* $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ') ', */ -/* $ ' .' ) */ +/* L9995: */ /* End of CCHK3. */ @@ -2058,9 +2531,21 @@ int /* Main program */ main(void) *iorder, char *side, char *uplo, char *transa, char *diag, integer *m, integer *n, complex *alpha, integer *lda, integer *ldb) { + /* Format strings */ + static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002," + "a14,\002,\002,a14,\002,\002)"; + static char fmt_9994[] = "(10x,2(a14,\002,\002),2(i3,\002,\002),\002 " + "(\002,f4.1,\002,\002,f4.1,\002), A,\002,i3,\002, B,\002,i3,\002)." + "\002)"; + /* Local variables */ char ca[14], cd[14], cs[14], cu[14], crc[14]; + /* Fortran I/O blocks */ + static cilist io___251 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___252 = { 0, 0, 0, fmt_9994, 0 }; + + if (*(unsigned char *)side == 'L') { s_copy(cs, " CblasLeft", (ftnlen)14, (ftnlen)14); } else { @@ -2088,9 +2573,24 @@ int /* Main program */ main(void) } else { s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cs,cu); - printf(" %s %s %d %d (%4.1f,%4.1f) A %d B %d\n",ca,cd,*m,*n,alpha->r,alpha->i,*lda,*ldb); - + io___251.ciunit = *nout; + s_wsfe(&io___251); + do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer)); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, crc, (ftnlen)14); + do_fio(&c__1, cs, (ftnlen)14); + do_fio(&c__1, cu, (ftnlen)14); + e_wsfe(); + io___252.ciunit = *nout; + s_wsfe(&io___252); + do_fio(&c__1, ca, (ftnlen)14); + do_fio(&c__1, cd, (ftnlen)14); + do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(real)); + do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer)); + e_wsfe(); return 0; } /* cprcn3_ */ @@ -2107,12 +2607,41 @@ int /* Main program */ main(void) static char icht[2] = "NC"; static char ichu[2] = "UL"; + /* Format strings */ + static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT " + "TAKEN ON VALID CALL *******\002)"; + static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER" + " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)"; + static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO" + "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR " + " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN" + " \002,i3)"; + static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM" + "BER:\002)"; + /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7; complex q__1; + alist al__1; /* Local variables */ + integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa, + lda, lcc, ldc; + extern logical lce_(complex *, complex *, integer *); + complex als; + integer ict, icu; + real err; complex beta; integer ldas, ldcs; logical same, conj; @@ -2120,7 +2649,6 @@ int /* Main program */ main(void) real rals; logical tran, null; char uplo[1]; - integer i__, j, k, n; extern /* Subroutine */ int cmake_(char *, char *, char *, integer *, integer *, complex *, integer *, complex *, integer *, logical *, complex *); @@ -2141,12 +2669,9 @@ int /* Main program */ main(void) *, char *, char *, integer *, integer *, complex *, integer *, complex *, integer *), cprcn6_(integer *, integer *, char *, integer *, char *, char *, integer *, integer * - , real *, integer *, real *, integer *); - integer ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks; - extern /* Subroutine */ int ccherk_(integer *, char *, char *, integer *, - integer *, real *, complex *, integer *, real *, complex *, - integer *); - integer ns; + , real *, integer *, real *, integer *), + ccherk_(integer *, char *, char *, integer *, integer *, real *, + complex *, integer *, real *, complex *, integer *); real ralpha; extern logical lceres_(char *, char *, integer *, integer *, complex *, complex *, integer *); @@ -2155,11 +2680,18 @@ int /* Main program */ main(void) integer *, complex *, complex *, integer *, complex *, complex *, integer *); char transs[1], transt[1]; - integer laa, lda, lcc, ldc; - extern logical lce_(complex *, complex *, integer *); - complex als; - integer ict, icu; - real err; + + /* Fortran I/O blocks */ + static cilist io___294 = { 0, 0, 0, fmt_9992, 0 }; + static cilist io___297 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___304 = { 0, 0, 0, fmt_10000, 0 }; + static cilist io___305 = { 0, 0, 0, fmt_10001, 0 }; + static cilist io___306 = { 0, 0, 0, fmt_10002, 0 }; + static cilist io___307 = { 0, 0, 0, fmt_10003, 0 }; + static cilist io___308 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___309 = { 0, 0, 0, fmt_9996, 0 }; + + /* Tests CHERK and CSYRK. */ @@ -2180,17 +2712,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 */ @@ -2200,8 +2732,6 @@ int /* Main program */ main(void) nc = 0; reset = TRUE_; errmax = 0.f; - rals = 1.f; - rbets = 1.f; i__1 = *nidim; for (in = 1; in <= i__1; ++in) { @@ -2275,8 +2805,8 @@ int /* Main program */ main(void) } null = n <= 0; if (conj) { - null = null || ((k <= 0 || ralpha == 0.f) && - rbeta == 1.f); + null = null || (k <= 0 || ralpha == 0.f) && + rbeta == 1.f; } /* Generate the matrix C. */ @@ -2332,9 +2862,9 @@ int /* Main program */ main(void) rbeta, &ldc); } if (*rewi) { -/* al__1.aerr = 0; + al__1.aerr = 0; al__1.aunit = *ntra; - f_rew(&al__1);*/ + f_rew(&al__1); } ccherk_(iorder, uplo, trans, &n, &k, &ralpha, &aa[1], &lda, &rbeta, &cc[1], &ldc); @@ -2345,9 +2875,9 @@ int /* Main program */ main(void) beta, &ldc); } if (*rewi) { -/* al__1.aerr = 0; + al__1.aerr = 0; al__1.aunit = *ntra; - f_rew(&al__1);*/ + f_rew(&al__1); } ccsyrk_(iorder, uplo, trans, &n, &k, &alpha, & aa[1], &lda, &beta, &cc[1], &ldc); @@ -2356,7 +2886,9 @@ int /* Main program */ main(void) /* Check if error-exit was taken incorrectly. */ if (! infoc_1.ok) { - printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + io___294.ciunit = *nout; + s_wsfe(&io___294); + e_wsfe(); *fatal = TRUE_; goto L120; } @@ -2399,7 +2931,11 @@ int /* Main program */ main(void) 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__); + io___297.ciunit = *nout; + s_wsfe(&io___297); + do_fio(&c__1, (char *)&i__, (ftnlen) + sizeof(integer)); + e_wsfe(); } /* L30: */ } @@ -2483,30 +3019,52 @@ int /* Main program */ main(void) if (errmax < *thresh) { if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___304.ciunit = *nout; + s_wsfe(&io___304); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___305.ciunit = *nout; + s_wsfe(&io___305); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } } else { if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___306.ciunit = *nout; + s_wsfe(&io___306); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real)); + e_wsfe(); } if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___307.ciunit = *nout; + s_wsfe(&io___307); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real)); + e_wsfe(); } } goto L130; L110: if (n > 1) { - printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j); + io___308.ciunit = *nout; + s_wsfe(&io___308); + do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer)); + e_wsfe(); } L120: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + io___309.ciunit = *nout; + s_wsfe(&io___309); + do_fio(&c__1, sname, (ftnlen)13); + e_wsfe(); if (conj) { cprcn6_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &ralpha, &lda, &rbeta, &ldc); @@ -2518,12 +3076,8 @@ int /* Main program */ main(void) 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. */ @@ -2534,9 +3088,21 @@ int /* Main program */ main(void) *iorder, char *uplo, char *transa, integer *n, integer *k, complex * alpha, integer *lda, complex *beta, integer *ldc) { + /* Format strings */ + static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002," + "\002))"; + static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002" + ",f4.1,\002), A,\002,i3,\002, (\002,f4.1,\002,\002,f4.1,\002), C" + ",\002,i3,\002).\002)"; + /* Local variables */ char ca[14], cu[14], crc[14]; + /* Fortran I/O blocks */ + static cilist io___313 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___314 = { 0, 0, 0, fmt_9994, 0 }; + + if (*(unsigned char *)uplo == 'U') { s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); } else { @@ -2554,8 +3120,23 @@ int /* Main program */ main(void) } else { s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); - printf("( %d %d (%4.1f,%4.1f) A %d (%4.1f,%4.1f) C %d\n",*n,*k,alpha->r,alpha->i,*lda,beta->r,beta->i,*ldc); + io___313.ciunit = *nout; + s_wsfe(&io___313); + do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer)); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, crc, (ftnlen)14); + do_fio(&c__1, cu, (ftnlen)14); + do_fio(&c__1, ca, (ftnlen)14); + e_wsfe(); + io___314.ciunit = *nout; + s_wsfe(&io___314); + do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(real)); + do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(real)); + do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer)); + e_wsfe(); return 0; } /* cprcn4_ */ @@ -2565,9 +3146,20 @@ int /* Main program */ main(void) *iorder, char *uplo, char *transa, integer *n, integer *k, real * alpha, integer *lda, real *beta, integer *ldc) { + /* Format strings */ + static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002," + "\002))"; + static char fmt_9994[] = "(10x,2(i3,\002,\002),f4.1,\002, A,\002,i3" + ",\002,\002,f4.1,\002, C,\002,i3,\002).\002)"; + /* Local variables */ char ca[14], cu[14], crc[14]; + /* Fortran I/O blocks */ + static cilist io___318 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___319 = { 0, 0, 0, fmt_9994, 0 }; + + if (*(unsigned char *)uplo == 'U') { s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); } else { @@ -2585,8 +3177,23 @@ int /* Main program */ main(void) } else { s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); - printf("( %d %d %4.1f A %d %4.1f C %d\n",*n,*k,*alpha,*lda,*beta,*ldc); + io___318.ciunit = *nout; + s_wsfe(&io___318); + do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer)); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, crc, (ftnlen)14); + do_fio(&c__1, cu, (ftnlen)14); + do_fio(&c__1, ca, (ftnlen)14); + e_wsfe(); + io___319.ciunit = *nout; + s_wsfe(&io___319); + do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(real)); + do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(real)); + do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer)); + e_wsfe(); return 0; } /* cprcn6_ */ @@ -2603,12 +3210,40 @@ int /* Main program */ main(void) static char icht[2] = "NC"; static char ichu[2] = "UL"; + /* Format strings */ + static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT " + "TAKEN ON VALID CALL *******\002)"; + static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER" + " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)"; + static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO" + "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR " + " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN" + " \002,i3)"; + static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM" + "BER:\002)"; /* System generated locals */ integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8; complex q__1, q__2; + alist al__1; /* Local variables */ + integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa, + lbb, lda, lcc, ldb, ldc; + extern logical lce_(complex *, complex *, integer *); + complex als; + integer ict, icu; + real err; integer jjab; complex beta; integer ldas, ldbs, ldcs; @@ -2616,7 +3251,6 @@ int /* Main program */ main(void) complex bets; logical tran, null; char uplo[1]; - integer i__, j, k, n; extern /* Subroutine */ int cmake_(char *, char *, char *, integer *, integer *, complex *, integer *, complex *, integer *, logical *, complex *); @@ -2638,22 +3272,27 @@ int /* Main program */ main(void) integer *, complex *, integer *), cprcn7_( integer *, integer *, char *, integer *, char *, char *, integer * , integer *, complex *, integer *, integer *, real *, integer *); - integer ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns; extern logical lceres_(char *, char *, integer *, integer *, complex *, complex *, integer *); real errmax; char transs[1], transt[1]; extern /* Subroutine */ int ccher2k_(integer *, char *, char *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, - real *, complex *, integer *); - integer laa, lbb, lda, lcc, ldb, ldc; - extern logical lce_(complex *, complex *, integer *); - extern /* Subroutine */ int ccsyr2k_(integer *, char *, char *, integer *, - integer *, complex *, complex *, integer *, complex *, integer *, - complex *, complex *, integer *); - complex als; - integer ict, icu; - real err; + real *, complex *, integer *), ccsyr2k_(integer * + , char *, char *, integer *, integer *, complex *, complex *, + integer *, complex *, integer *, complex *, complex *, integer *); + + /* Fortran I/O blocks */ + static cilist io___362 = { 0, 0, 0, fmt_9992, 0 }; + static cilist io___365 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___373 = { 0, 0, 0, fmt_10000, 0 }; + static cilist io___374 = { 0, 0, 0, fmt_10001, 0 }; + static cilist io___375 = { 0, 0, 0, fmt_10002, 0 }; + static cilist io___376 = { 0, 0, 0, fmt_10003, 0 }; + static cilist io___377 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___378 = { 0, 0, 0, fmt_9996, 0 }; + + /* Tests CHER2K and CSYR2K. */ @@ -2675,7 +3314,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; @@ -2777,8 +3416,8 @@ int /* Main program */ main(void) } null = n <= 0; if (conj) { - null = null || ((k <= 0 || (alpha.r == 0.f && - alpha.i == 0.f)) && rbeta == 1.f); + null = null || (k <= 0 || alpha.r == 0.f && + alpha.i == 0.f) && rbeta == 1.f; } /* Generate the matrix C. */ @@ -2839,9 +3478,9 @@ int /* Main program */ main(void) &rbeta, &ldc); } if (*rewi) { -/* al__1.aerr = 0; + al__1.aerr = 0; al__1.aunit = *ntra; - f_rew(&al__1);*/ + f_rew(&al__1); } ccher2k_(iorder, uplo, trans, &n, &k, &alpha, &aa[1], &lda, &bb[1], &ldb, &rbeta, & @@ -2853,9 +3492,9 @@ int /* Main program */ main(void) &beta, &ldc); } if (*rewi) { -/* al__1.aerr = 0; + al__1.aerr = 0; al__1.aunit = *ntra; - f_rew(&al__1);*/ + f_rew(&al__1); } ccsyr2k_(iorder, uplo, trans, &n, &k, &alpha, &aa[1], &lda, &bb[1], &ldb, &beta, & @@ -2865,7 +3504,9 @@ int /* Main program */ main(void) /* Check if error-exit was taken incorrectly. */ if (! infoc_1.ok) { - printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + io___362.ciunit = *nout; + s_wsfe(&io___362); + e_wsfe(); *fatal = TRUE_; goto L150; } @@ -2905,7 +3546,11 @@ int /* Main program */ main(void) 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__); + io___365.ciunit = *nout; + s_wsfe(&io___365); + do_fio(&c__1, (char *)&i__, (ftnlen) + sizeof(integer)); + e_wsfe(); } /* L40: */ } @@ -2938,7 +3583,7 @@ int /* Main program */ main(void) i__6 = k; for (i__ = 1; i__ <= i__6; ++i__) { i__7 = i__; - i__8 = ((j - 1) << 1) * *nmax + k + + i__8 = (j - 1 << 1) * *nmax + k + i__; q__1.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8].i, @@ -2950,14 +3595,14 @@ int /* Main program */ main(void) if (conj) { i__7 = k + i__; r_cnjg(&q__2, &alpha); - i__8 = ((j - 1) << 1) * *nmax + i__; + i__8 = (j - 1 << 1) * *nmax + i__; q__1.r = q__2.r * ab[i__8].r - q__2.i * ab[i__8].i, q__1.i = q__2.r * ab[i__8].i + q__2.i * ab[ i__8].r; w[i__7].r = q__1.r, w[i__7].i = q__1.i; } else { i__7 = k + i__; - i__8 = ((j - 1) << 1) * *nmax + i__; + i__8 = (j - 1 << 1) * *nmax + i__; q__1.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8] .i, q__1.i = alpha.r * ab[i__8].i + alpha.i * ab[i__8].r; @@ -3058,30 +3703,52 @@ int /* Main program */ main(void) if (errmax < *thresh) { if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___373.ciunit = *nout; + s_wsfe(&io___373); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___374.ciunit = *nout; + s_wsfe(&io___374); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } } else { if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___375.ciunit = *nout; + s_wsfe(&io___375); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real)); + e_wsfe(); } if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___376.ciunit = *nout; + s_wsfe(&io___376); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real)); + e_wsfe(); } } goto L160; L140: if (n > 1) { - printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j); + io___377.ciunit = *nout; + s_wsfe(&io___377); + do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer)); + e_wsfe(); } L150: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + io___378.ciunit = *nout; + s_wsfe(&io___378); + do_fio(&c__1, sname, (ftnlen)13); + e_wsfe(); if (conj) { cprcn7_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, & ldb, &rbeta, &ldc); @@ -3093,12 +3760,8 @@ int /* Main program */ main(void) 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 CCHK5. */ @@ -3109,10 +3772,21 @@ int /* Main program */ main(void) *iorder, char *uplo, char *transa, integer *n, integer *k, complex * alpha, integer *lda, integer *ldb, complex *beta, integer *ldc) { + /* Format strings */ + static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002," + "\002))"; + static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002" + ",f4.1,\002), A,\002,i3,\002, B\002,i3,\002, (\002,f4.1,\002,\002" + ",f4.1,\002), C,\002,i3,\002).\002)"; /* Local variables */ char ca[14], cu[14], crc[14]; + /* Fortran I/O blocks */ + static cilist io___382 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___383 = { 0, 0, 0, fmt_9994, 0 }; + + if (*(unsigned char *)uplo == 'U') { s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); } else { @@ -3130,8 +3804,24 @@ int /* Main program */ main(void) } else { s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); - printf("%d %d (%4.1f,%4.1f) , A, %d, B, %d, (%4.1f,%4.1f) , C, %d.\n",*n,*k,alpha->r,alpha->i,*lda,*ldb,beta->r,beta->i,*ldc); + io___382.ciunit = *nout; + s_wsfe(&io___382); + do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer)); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, crc, (ftnlen)14); + do_fio(&c__1, cu, (ftnlen)14); + do_fio(&c__1, ca, (ftnlen)14); + e_wsfe(); + io___383.ciunit = *nout; + s_wsfe(&io___383); + do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(real)); + do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(real)); + do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer)); + e_wsfe(); return 0; } /* cprcn5_ */ @@ -3141,10 +3831,21 @@ int /* Main program */ main(void) *iorder, char *uplo, char *transa, integer *n, integer *k, complex * alpha, integer *lda, integer *ldb, real *beta, integer *ldc) { + /* Format strings */ + static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002," + "\002))"; + static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002" + ",f4.1,\002), A,\002,i3,\002, B\002,i3,\002,\002,f4.1,\002, C," + "\002,i3,\002).\002)"; /* Local variables */ char ca[14], cu[14], crc[14]; + /* Fortran I/O blocks */ + static cilist io___387 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___388 = { 0, 0, 0, fmt_9994, 0 }; + + if (*(unsigned char *)uplo == 'U') { s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); } else { @@ -3162,8 +3863,24 @@ int /* Main program */ main(void) } else { s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); - printf("%d %d (%4.1f,%4.1f), A, %d, B, %d, %4.1f, C, %d.\n",*n,*k,alpha->r,alpha->i,*lda,*ldb,*beta,*ldc); + io___387.ciunit = *nout; + s_wsfe(&io___387); + do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer)); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, crc, (ftnlen)14); + do_fio(&c__1, cu, (ftnlen)14); + do_fio(&c__1, ca, (ftnlen)14); + e_wsfe(); + io___388.ciunit = *nout; + s_wsfe(&io___388); + do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(real)); + do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(real)); + do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer)); + e_wsfe(); return 0; } /* cprcn7_ */ @@ -3178,13 +3895,11 @@ int /* Main program */ main(void) complex q__1, q__2; /* Local variables */ + integer i__, j, jj; + logical gen, her, tri, sym; extern /* Complex */ VOID cbeg_(complex *, logical *); integer ibeg, iend; - logical unit; - integer i__, j; - logical lower, upper; - integer jj; - logical gen, her, tri, sym; + logical unit, lower, upper; /* Generates values for an M by N matrix A. */ @@ -3203,7 +3918,7 @@ int /* Main program */ main(void) /* Parameter adjustments */ a_dim1 = *nmax; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --aa; @@ -3222,7 +3937,7 @@ int /* Main program */ main(void) for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { - if (gen || (upper && i__ <= j) || (lower && i__ >= j)) { + if (gen || upper && i__ <= j || lower && i__ >= j) { i__3 = i__ + j * a_dim1; cbeg_(&q__2, reset); q__1.r = q__2.r + transl->r, q__1.i = q__2.i + transl->i; @@ -3351,6 +4066,15 @@ int /* Main program */ main(void) real *g, complex *cc, integer *ldcc, real *eps, real *err, logical * fatal, integer *nout, logical *mv) { + /* Format strings */ + static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS" + " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 " + " EXPECTED RE\002,\002SULT COMPUTED R" + "ESULT\002)"; + static char fmt_9998[] = "(1x,i7,2(\002 (\002,g15.6,\002,\002,g15.6," + "\002)\002))"; + static char fmt_9997[] = "(\002 THESE ARE THE RESULTS FOR COLUMN" + " \002,i3)"; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, cc_dim1, @@ -3359,10 +4083,18 @@ int /* Main program */ main(void) complex q__1, q__2, q__3, q__4; /* Local variables */ - real erri; integer i__, j, k; + real erri; logical trana, tranb, ctrana, ctranb; + /* Fortran I/O blocks */ + static cilist io___409 = { 0, 0, 0, fmt_9999, 0 }; + static cilist io___410 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___411 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___412 = { 0, 0, 0, fmt_9997, 0 }; + + + /* Checks the results of the computational tests. */ /* Auxiliary routine for test program for Level 3 Blas. */ @@ -3375,18 +4107,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 */ @@ -3699,19 +4431,35 @@ int /* Main program */ main(void) L230: *fatal = TRUE_; - printf(" ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HALF ACCURATE *******\n"); - printf(" EXPECTED RESULT COMPUTED RESULT\n"); + io___409.ciunit = *nout; + s_wsfe(&io___409); + e_wsfe(); i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { if (*mv) { - printf("%7d (%15.6g,%15.6g) (%15.6g,%15.6g)\n",i__,ct[i__].r,ct[i__].i,cc[i__+j*cc_dim1].r,cc[i__+j*cc_dim1].i); + io___410.ciunit = *nout; + s_wsfe(&io___410); + do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&ct[i__], (ftnlen)sizeof(real)); + do_fio(&c__2, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(real) + ); + e_wsfe(); } else { - 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); + io___411.ciunit = *nout; + s_wsfe(&io___411); + do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(real) + ); + do_fio(&c__2, (char *)&ct[i__], (ftnlen)sizeof(real)); + e_wsfe(); } /* L240: */ } if (*n > 1) { - printf(" THESE ARE THE RESULTS FOR COLUMN %d\n",j); + io___412.ciunit = *nout; + s_wsfe(&io___412); + do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer)); + e_wsfe(); } L250: @@ -3775,7 +4523,7 @@ logical lceres_(char *type__, char *uplo, integer *m, integer *n, complex *aa, logical ret_val; /* Local variables */ - integer ibeg, iend, i__, j; + integer i__, j, ibeg, iend; logical upper; @@ -3793,10 +4541,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 +4596,7 @@ logical lceres_(char *type__, char *uplo, integer *m, integer *n, complex *aa, } } -/* 60 CONTINUE */ +/* L60: */ ret_val = TRUE_; goto L80; L70: @@ -3939,4 +4687,913 @@ 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"; + + /* Format strings */ + static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT " + "TAKEN ON VALID CALL *******\002)"; + static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER" + " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)"; + static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO" + "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR " + " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM" + "BER:\002)"; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5, i__6, i__7; + alist al__1; + + /* Local variables */ + extern /* Subroutine */ int ccgemmtr_(integer *, char *, char *, char *, + integer *, integer *, complex *, complex *, integer *, complex *, + integer *, complex *, complex *, integer *); + integer i__, k, n, ia, ib, ma, mb, na, nb, nc, ik, in, is, ks, ns, ica, + icb, laa, lbb, lda, lcc, ldb, ldc; + extern logical lce_(complex *, complex *, integer *); + complex als, bls; + real err; + complex beta; + integer ldas, ldbs, ldcs; + logical same, null; + char uplo[1]; + extern /* Subroutine */ int cmake_(char *, char *, char *, integer *, + integer *, complex *, integer *, complex *, integer *, logical *, + complex *); + complex alpha; + logical isame[13], trana, tranb; + integer nargs; + logical reset; + char uplos[1]; + extern /* Subroutine */ int cprcn8_(integer *, integer *, char *, integer + *, char *, char *, char *, integer *, integer *, complex *, + integer *, integer *, complex *, integer *), cmmtch_(char *, char *, char *, integer *, + integer *, complex *, complex *, integer *, complex *, integer *, + complex *, complex *, integer *, complex *, real *, complex *, + integer *, real *, real *, logical *, integer *, logical *); + extern logical lceres_(char *, char *, integer *, integer *, complex *, + complex *, integer *); + char tranas[1], tranbs[1], transa[1], transb[1]; + real errmax; + + /* Fortran I/O blocks */ + static cilist io___468 = { 0, 0, 0, fmt_9994, 0 }; + static cilist io___471 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___473 = { 0, 0, 0, fmt_10000, 0 }; + static cilist io___474 = { 0, 0, 0, fmt_10001, 0 }; + static cilist io___475 = { 0, 0, 0, fmt_10002, 0 }; + static cilist io___476 = { 0, 0, 0, fmt_10003, 0 }; + static cilist io___477 = { 0, 0, 0, fmt_9996, 0 }; + + + +/* Tests CGEMMTR. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 24-June-2024. */ +/* Martin Koehler, Max Planck Institute Magdeburg */ + + /* Parameter adjustments */ + --idim; + --alf; + --bet; + --g; + --ct; + --cs; + --cc; + c_dim1 = *nmax; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --bs; + --bb; + b_dim1 = *nmax; + b_offset = 1 + b_dim1; + b -= b_offset; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + + nargs = 13; + nc = 0; + reset = TRUE_; + errmax = 0.f; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; +/* Set LDC to 1 more than minimum value if room. */ + ldc = n; + if (ldc < *nmax) { + ++ldc; + } +/* Skip tests if not enough room. */ + if (ldc > *nmax) { + goto L100; + } + lcc = ldc * n; + null = (real) n <= 0.f; + + i__2 = *nidim; + for (ik = 1; ik <= i__2; ++ik) { + k = idim[ik]; + + for (ica = 1; ica <= 3; ++ica) { + *(unsigned char *)transa = *(unsigned char *)&ich[ica - 1]; + trana = *(unsigned char *)transa == 'T' || *(unsigned char *) + transa == 'C'; + + if (trana) { + ma = k; + na = n; + } else { + ma = n; + na = k; + } +/* Set LDA to 1 more than minimum value if room. */ + lda = ma; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L80; + } + laa = lda * na; + +/* Generate the matrix A. */ + + cmake_("ge", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[1], & + lda, &reset, &c_b1); + + for (icb = 1; icb <= 3; ++icb) { + *(unsigned char *)transb = *(unsigned char *)&ich[icb - 1] + ; + tranb = *(unsigned char *)transb == 'T' || *(unsigned + char *)transb == 'C'; + + if (tranb) { + mb = n; + nb = k; + } else { + mb = k; + nb = n; + } +/* Set LDB to 1 more than minimum value if room. */ + ldb = mb; + if (ldb < *nmax) { + ++ldb; + } +/* Skip tests if not enough room. */ + if (ldb > *nmax) { + goto L70; + } + lbb = ldb * nb; + +/* Generate the matrix B. */ + + cmake_("ge", " ", " ", &mb, &nb, &b[b_offset], nmax, &bb[ + 1], &ldb, &reset, &c_b1); + + i__3 = *nalf; + for (ia = 1; ia <= i__3; ++ia) { + i__4 = ia; + alpha.r = alf[i__4].r, alpha.i = alf[i__4].i; + + i__4 = *nbet; + for (ib = 1; ib <= i__4; ++ib) { + i__5 = ib; + beta.r = bet[i__5].r, beta.i = bet[i__5].i; + for (is = 1; is <= 2; ++is) { + *(unsigned char *)uplo = *(unsigned char *)& + ishape[is - 1]; + +/* Generate the matrix C. */ + + cmake_("ge", uplo, " ", &n, &n, &c__[c_offset] + , nmax, &cc[1], &ldc, &reset, &c_b1); + + ++nc; + +/* Save every datum before calling the */ +/* subroutine. */ + + *(unsigned char *)uplos = *(unsigned char *) + uplo; + *(unsigned char *)tranas = *(unsigned char *) + transa; + *(unsigned char *)tranbs = *(unsigned char *) + transb; + ns = n; + ks = k; + als.r = alpha.r, als.i = alpha.i; + i__5 = laa; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + as[i__6].r = aa[i__7].r, as[i__6].i = aa[ + i__7].i; +/* L10: */ + } + ldas = lda; + i__5 = lbb; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + bs[i__6].r = bb[i__7].r, bs[i__6].i = bb[ + i__7].i; +/* L20: */ + } + ldbs = ldb; + bls.r = beta.r, bls.i = beta.i; + i__5 = lcc; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + cs[i__6].r = cc[i__7].r, cs[i__6].i = cc[ + i__7].i; +/* L30: */ + } + ldcs = ldc; + +/* Call the subroutine. */ + + if (*trace) { + cprcn8_(ntra, &nc, sname, iorder, uplo, + transa, transb, &n, &k, &alpha, & + lda, &ldb, &beta, &ldc); + } + if (*rewi) { + al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1); + } + ccgemmtr_(iorder, uplo, transa, transb, &n, & + k, &alpha, &aa[1], &lda, &bb[1], &ldb, + &beta, &cc[1], &ldc); + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + io___468.ciunit = *nout; + s_wsfe(&io___468); + e_wsfe(); + *fatal = TRUE_; + goto L120; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)uplo == *( + unsigned char *)uplos; + isame[1] = *(unsigned char *)transa == *( + unsigned char *)tranas; + isame[2] = *(unsigned char *)transb == *( + unsigned char *)tranbs; + isame[3] = ns == n; + isame[4] = ks == k; + isame[5] = als.r == alpha.r && als.i == + alpha.i; + isame[6] = lce_(&as[1], &aa[1], &laa); + isame[7] = ldas == lda; + isame[8] = lce_(&bs[1], &bb[1], &lbb); + isame[9] = ldbs == ldb; + isame[10] = bls.r == beta.r && bls.i == + beta.i; + if (null) { + isame[11] = lce_(&cs[1], &cc[1], &lcc); + } else { + isame[11] = lceres_("ge", " ", &n, &n, & + cs[1], &cc[1], &ldc); + } + isame[12] = ldcs == ldc; + +/* If data was incorrectly changed, report */ +/* and return. */ + + same = TRUE_; + i__5 = nargs; + for (i__ = 1; i__ <= i__5; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + io___471.ciunit = *nout; + s_wsfe(&io___471); + do_fio(&c__1, (char *)&i__, (ftnlen) + sizeof(integer)); + e_wsfe(); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L120; + } + + if (! null) { + +/* Check the result. */ + + cmmtch_(uplo, transa, transb, &n, &k, & + alpha, &a[a_offset], nmax, &b[ + b_offset], nmax, &beta, &c__[ + c_offset], nmax, &ct[1], &g[1], & + cc[1], &ldc, eps, &err, fatal, + nout, &c_true); + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L120; + } + } + +/* L45: */ + } + +/* L50: */ + } + +/* L60: */ + } + +L70: + ; + } + +L80: + ; + } + +/* L90: */ + } + +L100: + ; + } + + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + io___473.ciunit = *nout; + s_wsfe(&io___473); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); + } + if (*iorder == 1) { + io___474.ciunit = *nout; + s_wsfe(&io___474); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); + } + } else { + if (*iorder == 0) { + io___475.ciunit = *nout; + s_wsfe(&io___475); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real)); + e_wsfe(); + } + if (*iorder == 1) { + io___476.ciunit = *nout; + s_wsfe(&io___476); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real)); + e_wsfe(); + } + } + goto L130; + +L120: + io___477.ciunit = *nout; + s_wsfe(&io___477); + do_fio(&c__1, sname, (ftnlen)13); + e_wsfe(); + cprcn8_(nout, &nc, sname, iorder, uplo, transa, transb, &n, &k, &alpha, & + lda, &ldb, &beta, &ldc); + +L130: + return 0; + +/* L9995: */ + +/* End of CCHK6. */ + +} /* cchk6_ */ + +/* Subroutine */ int cprcn8_(integer *nout, integer *nc, char *sname, integer + *iorder, char *uplo, char *transa, char *transb, integer *n, integer * + k, complex *alpha, integer *lda, integer *ldb, complex *beta, integer + *ldc) +{ + /* Format strings */ + static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002," + "a14,\002,\002,a14,\002,\002,a14,\002,\002)"; + static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002" + ",f4.1,\002) , A,\002,i3,\002, B,\002,i3,\002, (\002,f4.1,\002" + ",\002,f4.1,\002) , C,\002,i3,\002).\002)"; + + /* Local variables */ + char crc[14], cta[14], ctb[14], cuplo[14]; + + /* Fortran I/O blocks */ + static cilist io___482 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___483 = { 0, 0, 0, fmt_9994, 0 }; + + + if (*(unsigned char *)uplo == 'U') { + s_copy(cuplo, "CblasUpper", (ftnlen)14, (ftnlen)10); + } else { + s_copy(cuplo, "CblasLower", (ftnlen)14, (ftnlen)10); + } + if (*(unsigned char *)transa == 'N') { + s_copy(cta, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transa == 'T') { + s_copy(cta, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cta, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)transb == 'N') { + s_copy(ctb, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transb == 'T') { + s_copy(ctb, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(ctb, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*iorder == 1) { + s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); + } else { + s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); + } + io___482.ciunit = *nout; + s_wsfe(&io___482); + do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer)); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, crc, (ftnlen)14); + do_fio(&c__1, cuplo, (ftnlen)14); + do_fio(&c__1, cta, (ftnlen)14); + do_fio(&c__1, ctb, (ftnlen)14); + e_wsfe(); + io___483.ciunit = *nout; + s_wsfe(&io___483); + do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(real)); + do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(real)); + do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer)); + e_wsfe(); + return 0; +} /* cprcn8_ */ + +/* Subroutine */ int cmmtch_(char *uplo, char *transa, char *transb, integer * + n, integer *kk, complex *alpha, complex *a, integer *lda, complex *b, + integer *ldb, complex *beta, complex *c__, integer *ldc, complex *ct, + real *g, complex *cc, integer *ldcc, real *eps, real *err, logical * + fatal, integer *nout, logical *mv) +{ + /* Format strings */ + static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS" + " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 " + " EXPECTED RE\002,\002SULT COMPUTED R" + "ESULT\002)"; + static char fmt_9998[] = "(1x,i7,2(\002 (\002,g15.6,\002,\002,g15.6," + "\002)\002))"; + static char fmt_9997[] = "(\002 THESE ARE THE RESULTS FOR COLUMN" + " \002,i3)"; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, cc_dim1, + cc_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7; + real r__1, r__2, r__3, r__4, r__5, r__6; + complex q__1, q__2, q__3, q__4; + + /* Local variables */ + integer i__, j, k; + real erri; + logical trana, tranb, upper; + integer istop; + logical ctrana, ctranb; + integer istart; + + /* Fortran I/O blocks */ + static cilist io___495 = { 0, 0, 0, fmt_9999, 0 }; + static cilist io___496 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___497 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___498 = { 0, 0, 0, fmt_9997, 0 }; + + + +/* Checks the results of the computational tests for GEMMTR. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 24-June-2024. */ +/* Martin Koehler, Max Planck Institute, Magdeburg */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --ct; + --g; + cc_dim1 = *ldcc; + cc_offset = 1 + cc_dim1; + cc -= cc_offset; + + /* Function Body */ + upper = *(unsigned char *)uplo == 'U'; + trana = *(unsigned char *)transa == 'T' || *(unsigned char *)transa == + 'C'; + tranb = *(unsigned char *)transb == 'T' || *(unsigned char *)transb == + 'C'; + ctrana = *(unsigned char *)transa == 'C'; + ctranb = *(unsigned char *)transb == 'C'; + istart = 1; + istop = *n; + +/* Compute expected result, one column at a time, in CT using data */ +/* in A, B and C. */ +/* Compute gauges in G. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + + if (upper) { + istart = 1; + istop = j; + } else { + istart = j; + istop = *n; + } + i__2 = istop; + for (i__ = istart; i__ <= i__2; ++i__) { + i__3 = i__; + ct[i__3].r = 0.f, ct[i__3].i = 0.f; + g[i__] = 0.f; +/* L10: */ + } + if (! trana && ! tranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = istop; + for (i__ = istart; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + i__6 = i__ + k * a_dim1; + i__7 = k + j * b_dim1; + q__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[i__7].i, + q__2.i = a[i__6].r * b[i__7].i + a[i__6].i * b[ + i__7].r; + q__1.r = ct[i__5].r + q__2.r, q__1.i = ct[i__5].i + + q__2.i; + ct[i__4].r = q__1.r, ct[i__4].i = q__1.i; + i__4 = i__ + k * a_dim1; + i__5 = k + j * b_dim1; + g[i__] += ((r__1 = a[i__4].r, abs(r__1)) + (r__2 = r_imag( + &a[i__ + k * a_dim1]), abs(r__2))) * ((r__3 = b[ + i__5].r, abs(r__3)) + (r__4 = r_imag(&b[k + j * + b_dim1]), abs(r__4))); +/* L20: */ + } +/* L30: */ + } + } else if (trana && ! tranb) { + if (ctrana) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = istop; + for (i__ = istart; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + r_cnjg(&q__3, &a[k + i__ * a_dim1]); + i__6 = k + j * b_dim1; + q__2.r = q__3.r * b[i__6].r - q__3.i * b[i__6].i, + q__2.i = q__3.r * b[i__6].i + q__3.i * b[i__6] + .r; + q__1.r = ct[i__5].r + q__2.r, q__1.i = ct[i__5].i + + q__2.i; + ct[i__4].r = q__1.r, ct[i__4].i = q__1.i; + i__4 = k + i__ * a_dim1; + i__5 = k + j * b_dim1; + g[i__] += ((r__1 = a[i__4].r, abs(r__1)) + (r__2 = + r_imag(&a[k + i__ * a_dim1]), abs(r__2))) * (( + r__3 = b[i__5].r, abs(r__3)) + (r__4 = r_imag( + &b[k + j * b_dim1]), abs(r__4))); +/* L40: */ + } +/* L50: */ + } + } else { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = istop; + for (i__ = istart; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + i__6 = k + i__ * a_dim1; + i__7 = k + j * b_dim1; + q__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[i__7] + .i, q__2.i = a[i__6].r * b[i__7].i + a[i__6] + .i * b[i__7].r; + q__1.r = ct[i__5].r + q__2.r, q__1.i = ct[i__5].i + + q__2.i; + ct[i__4].r = q__1.r, ct[i__4].i = q__1.i; + i__4 = k + i__ * a_dim1; + i__5 = k + j * b_dim1; + g[i__] += ((r__1 = a[i__4].r, abs(r__1)) + (r__2 = + r_imag(&a[k + i__ * a_dim1]), abs(r__2))) * (( + r__3 = b[i__5].r, abs(r__3)) + (r__4 = r_imag( + &b[k + j * b_dim1]), abs(r__4))); +/* L60: */ + } +/* L70: */ + } + } + } else if (! trana && tranb) { + if (ctranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = istop; + for (i__ = istart; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + i__6 = i__ + k * a_dim1; + r_cnjg(&q__3, &b[j + k * b_dim1]); + q__2.r = a[i__6].r * q__3.r - a[i__6].i * q__3.i, + q__2.i = a[i__6].r * q__3.i + a[i__6].i * + q__3.r; + q__1.r = ct[i__5].r + q__2.r, q__1.i = ct[i__5].i + + q__2.i; + ct[i__4].r = q__1.r, ct[i__4].i = q__1.i; + i__4 = i__ + k * a_dim1; + i__5 = j + k * b_dim1; + g[i__] += ((r__1 = a[i__4].r, abs(r__1)) + (r__2 = + r_imag(&a[i__ + k * a_dim1]), abs(r__2))) * (( + r__3 = b[i__5].r, abs(r__3)) + (r__4 = r_imag( + &b[j + k * b_dim1]), abs(r__4))); +/* L80: */ + } +/* L90: */ + } + } else { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = istop; + for (i__ = istart; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + i__6 = i__ + k * a_dim1; + i__7 = j + k * b_dim1; + q__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[i__7] + .i, q__2.i = a[i__6].r * b[i__7].i + a[i__6] + .i * b[i__7].r; + q__1.r = ct[i__5].r + q__2.r, q__1.i = ct[i__5].i + + q__2.i; + ct[i__4].r = q__1.r, ct[i__4].i = q__1.i; + i__4 = i__ + k * a_dim1; + i__5 = j + k * b_dim1; + g[i__] += ((r__1 = a[i__4].r, abs(r__1)) + (r__2 = + r_imag(&a[i__ + k * a_dim1]), abs(r__2))) * (( + r__3 = b[i__5].r, abs(r__3)) + (r__4 = r_imag( + &b[j + k * b_dim1]), abs(r__4))); +/* L100: */ + } +/* L110: */ + } + } + } else if (trana && tranb) { + if (ctrana) { + if (ctranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = istop; + for (i__ = istart; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + r_cnjg(&q__3, &a[k + i__ * a_dim1]); + r_cnjg(&q__4, &b[j + k * b_dim1]); + q__2.r = q__3.r * q__4.r - q__3.i * q__4.i, + q__2.i = q__3.r * q__4.i + q__3.i * + q__4.r; + q__1.r = ct[i__5].r + q__2.r, q__1.i = ct[i__5].i + + q__2.i; + ct[i__4].r = q__1.r, ct[i__4].i = q__1.i; + i__4 = k + i__ * a_dim1; + i__5 = j + k * b_dim1; + g[i__] += ((r__1 = a[i__4].r, abs(r__1)) + (r__2 = + r_imag(&a[k + i__ * a_dim1]), abs(r__2))) + * ((r__3 = b[i__5].r, abs(r__3)) + (r__4 + = r_imag(&b[j + k * b_dim1]), abs(r__4))); +/* L120: */ + } +/* L130: */ + } + } else { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = istop; + for (i__ = istart; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + r_cnjg(&q__3, &a[k + i__ * a_dim1]); + i__6 = j + k * b_dim1; + q__2.r = q__3.r * b[i__6].r - q__3.i * b[i__6].i, + q__2.i = q__3.r * b[i__6].i + q__3.i * b[ + i__6].r; + q__1.r = ct[i__5].r + q__2.r, q__1.i = ct[i__5].i + + q__2.i; + ct[i__4].r = q__1.r, ct[i__4].i = q__1.i; + i__4 = k + i__ * a_dim1; + i__5 = j + k * b_dim1; + g[i__] += ((r__1 = a[i__4].r, abs(r__1)) + (r__2 = + r_imag(&a[k + i__ * a_dim1]), abs(r__2))) + * ((r__3 = b[i__5].r, abs(r__3)) + (r__4 + = r_imag(&b[j + k * b_dim1]), abs(r__4))); +/* L140: */ + } +/* L150: */ + } + } + } else { + if (ctranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = istop; + for (i__ = istart; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + i__6 = k + i__ * a_dim1; + r_cnjg(&q__3, &b[j + k * b_dim1]); + q__2.r = a[i__6].r * q__3.r - a[i__6].i * q__3.i, + q__2.i = a[i__6].r * q__3.i + a[i__6].i * + q__3.r; + q__1.r = ct[i__5].r + q__2.r, q__1.i = ct[i__5].i + + q__2.i; + ct[i__4].r = q__1.r, ct[i__4].i = q__1.i; + i__4 = k + i__ * a_dim1; + i__5 = j + k * b_dim1; + g[i__] += ((r__1 = a[i__4].r, abs(r__1)) + (r__2 = + r_imag(&a[k + i__ * a_dim1]), abs(r__2))) + * ((r__3 = b[i__5].r, abs(r__3)) + (r__4 + = r_imag(&b[j + k * b_dim1]), abs(r__4))); +/* L160: */ + } +/* L170: */ + } + } else { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = istop; + for (i__ = istart; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + i__6 = k + i__ * a_dim1; + i__7 = j + k * b_dim1; + q__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[ + i__7].i, q__2.i = a[i__6].r * b[i__7].i + + a[i__6].i * b[i__7].r; + q__1.r = ct[i__5].r + q__2.r, q__1.i = ct[i__5].i + + q__2.i; + ct[i__4].r = q__1.r, ct[i__4].i = q__1.i; + i__4 = k + i__ * a_dim1; + i__5 = j + k * b_dim1; + g[i__] += ((r__1 = a[i__4].r, abs(r__1)) + (r__2 = + r_imag(&a[k + i__ * a_dim1]), abs(r__2))) + * ((r__3 = b[i__5].r, abs(r__3)) + (r__4 + = r_imag(&b[j + k * b_dim1]), abs(r__4))); +/* L180: */ + } +/* L190: */ + } + } + } + } + i__2 = istop; + for (i__ = istart; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + q__2.r = alpha->r * ct[i__4].r - alpha->i * ct[i__4].i, q__2.i = + alpha->r * ct[i__4].i + alpha->i * ct[i__4].r; + i__5 = i__ + j * c_dim1; + q__3.r = beta->r * c__[i__5].r - beta->i * c__[i__5].i, q__3.i = + beta->r * c__[i__5].i + beta->i * c__[i__5].r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + ct[i__3].r = q__1.r, ct[i__3].i = q__1.i; + i__3 = i__ + j * c_dim1; + g[i__] = ((r__1 = alpha->r, abs(r__1)) + (r__2 = r_imag(alpha), + abs(r__2))) * g[i__] + ((r__3 = beta->r, abs(r__3)) + ( + r__4 = r_imag(beta), abs(r__4))) * ((r__5 = c__[i__3].r, + abs(r__5)) + (r__6 = r_imag(&c__[i__ + j * c_dim1]), abs( + r__6))); +/* L200: */ + } + +/* Compute the error ratio for this result. */ + + *err = 0.f; + i__2 = istop; + for (i__ = istart; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__ + j * cc_dim1; + q__2.r = ct[i__3].r - cc[i__4].r, q__2.i = ct[i__3].i - cc[i__4] + .i; + q__1.r = q__2.r, q__1.i = q__2.i; + erri = ((r__1 = q__1.r, abs(r__1)) + (r__2 = r_imag(&q__1), abs( + r__2))) / *eps; + if (g[i__] != 0.f) { + erri /= g[i__]; + } + *err = f2cmax(*err,erri); + if (*err * sqrt(*eps) >= 1.f) { + goto L230; + } +/* L210: */ + } + +/* L220: */ + } + +/* If the loop completes, all results are at least half accurate. */ + goto L250; + +/* Report fatal error. */ + +L230: + *fatal = TRUE_; + io___495.ciunit = *nout; + s_wsfe(&io___495); + e_wsfe(); + i__1 = istop; + for (i__ = istart; i__ <= i__1; ++i__) { + if (*mv) { + io___496.ciunit = *nout; + s_wsfe(&io___496); + do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&ct[i__], (ftnlen)sizeof(real)); + do_fio(&c__2, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(real) + ); + e_wsfe(); + } else { + io___497.ciunit = *nout; + s_wsfe(&io___497); + do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(real) + ); + do_fio(&c__2, (char *)&ct[i__], (ftnlen)sizeof(real)); + e_wsfe(); + } +/* L240: */ + } + if (*n > 1) { + io___498.ciunit = *nout; + s_wsfe(&io___498); + do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer)); + e_wsfe(); + } + +L250: + return 0; + + +/* End of CMMTCH. */ + +} /* cmmtch_ */ + +/* Main program alias */ int cblat3_ () { MAIN__ (); return 0; } diff --git a/ctest/c_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..eeb65e675b 100644 --- a/ctest/c_dblat3c.c +++ b/ctest/c_dblat3c.c @@ -236,33 +236,145 @@ 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 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} /* Common Block Declarations */ -struct { - integer infot, noutc; - logical ok; +union { + struct { + integer infot, noutc; + logical ok; + } _1; + struct { + integer infot, noutc; + logical ok, lerr; + } _2; } infoc_; -#define infoc_1 infoc_ +#define infoc_1 (infoc_._1) +#define infoc_2 (infoc_._2) struct { - char srnamt[12]; + char srnamt[13]; } srnamc_; #define srnamc_1 srnamc_ /* Table of constant values */ +static integer c__9 = 9; static integer c__1 = 1; +static integer c__3 = 3; +static integer c__8 = 8; +static integer c__5 = 5; static integer c__65 = 65; +static integer c__7 = 7; static doublereal c_b90 = 1.; static doublereal c_b104 = 0.; static integer c__6 = 6; @@ -270,65 +382,179 @@ 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[13*7] = "cblas_dgemm " "cblas_dsymm " "cblas_dtrmm " + "cblas_dtrsm " "cblas_dsyrk " "cblas_dsyr2k " "cblas_dgemmtr"; + + /* Format strings */ + static char fmt_9997[] = "(\002 NUMBER OF VALUES OF \002,a,\002 IS LESS " + "THAN 1 OR GREATER \002,\002THAN \002,i2)"; + static char fmt_9996[] = "(\002 VALUE OF N IS LESS THAN 0 OR GREATER THA" + "N \002,i2)"; + static char fmt_9995[] = "(\002 TESTS OF THE DOUBLE PRECISION LEVEL 3 BL" + "AS\002,//\002 THE F\002,\002OLLOWING PARAMETER VALUES WILL BE US" + "ED:\002)"; + static char fmt_9994[] = "(\002 FOR N \002,9i6)"; + static char fmt_9993[] = "(\002 FOR ALPHA \002,7f6.1)"; + static char fmt_9992[] = "(\002 FOR BETA \002,7f6.1)"; + static char fmt_9984[] = "(\002 ERROR-CALL MYEXITS WILL NOT BE TESTED" + "\002)"; + static char fmt_9999[] = "(\002 ROUTINES PASS COMPUTATIONAL TESTS IF TES" + "T RATIO IS LES\002,\002S THAN\002,f8.2)"; + static char fmt_10002[] = "(\002 COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS" + " ARE TESTED\002)"; + static char fmt_10001[] = "(\002 ROW-MAJOR DATA LAYOUT IS TESTED\002)"; + static char fmt_10000[] = "(\002 COLUMN-MAJOR DATA LAYOUT IS TESTED\002)"; + static char fmt_9988[] = "(a13,l2)"; + static char fmt_9990[] = "(\002 SUBPROGRAM NAME \002,a13,\002 NOT RECOGN" + "IZED\002,/\002 ******* T\002,\002ESTS ABANDONED *******\002)"; + static char fmt_9998[] = "(\002 RELATIVE MACHINE PRECISION IS TAKEN TO" + " BE\002,1p,d9.1)"; + static char fmt_9989[] = "(\002 ERROR IN DMMCH - IN-LINE DOT PRODUCTS A" + "RE BEING EVALU\002,\002ATED WRONGLY.\002,/\002 DMMCH WAS CALLED " + "WITH TRANSA = \002,a1,\002 AND TRANSB = \002,a1,/\002 AND RETURN" + "ED SAME = \002,l1,\002 AND \002,\002ERR = \002,f12.3,\002.\002," + "/\002 THIS MAY BE DUE TO FAULTS IN THE \002,\002ARITHMETIC OR TH" + "E COMPILER.\002,/\002 ******* TESTS ABANDONED \002,\002******" + "*\002)"; + static char fmt_9987[] = "(1x,a13,\002 WAS NOT TESTED\002)"; + static char fmt_9986[] = "(/\002 END OF TESTS\002)"; + static char fmt_9985[] = "(/\002 ******* FATAL ERROR - TESTS ABANDONED *" + "******\002)"; + static char fmt_9991[] = "(\002 AMEND DATA FILE OR INCREASE ARRAY SIZES " + "IN PROGRAM\002,/\002 ******* TESTS ABANDONED *******\002)"; /* System generated locals */ integer i__1, i__2, i__3; doublereal d__1; - + olist o__1; + cllist cl__1; /* Local variables */ - static integer nalf, idim[9]; - static logical same; - static integer nbet, ntra; - static logical rewi; - extern /* Subroutine */ int dchk1_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, integer*, ftnlen); - extern /* Subroutine */ int dchk2_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, integer*, ftnlen); - extern /* Subroutine */ int dchk3_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, integer*, ftnlen); - extern /* Subroutine */ int dchk4_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, integer*, ftnlen); -/* Subroutine */ int dchk5_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublereal* alf, integer* nbet, doublereal* bet, integer* nmax, doublereal* ab, doublereal* aa, doublereal* as, doublereal* bb, doublereal* bs, doublereal* c__, doublereal* cc, doublereal* cs, doublereal* ct, doublereal* g, doublereal* w, integer* iorder, ftnlen sname_len); - static doublereal c__[4225] /* was [65][65] */, g[65]; - static integer i__, j; - extern doublereal ddiff_(doublereal*, doublereal*); - static integer n; - static logical fatal; - static doublereal w[130]; - extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); - static logical trace; - static integer nidim; - static char snaps[32]; - static integer isnum; - static logical ltest[6]; - static doublereal aa[4225], ab[8450] /* was [65][130] */, bb[4225], - cc[4225], as[4225], bs[4225], cs[4225], ct[65]; - static logical sfatal, corder; - static char snamet[12], transa[1], transb[1]; - static doublereal thresh; - static logical rorder; - extern /* Subroutine */ void cd3chke_(char*, ftnlen); - static integer layout; - static logical ltestt, tsterr; - static doublereal alf[7]; - extern logical lde_(doublereal*, doublereal*, integer*); - static doublereal bet[7], eps, err; - char tmpchar; + doublereal c__[4225] /* was [65][65] */, g[65]; + integer i__, j, n; + doublereal w[130], aa[4225], ab[8450] /* was [65][130] */, bb[4225], + cc[4225], as[4225], bs[4225], cs[4225], ct[65], alf[7]; + extern logical lde_(doublereal *, doublereal *, integer *); + doublereal bet[7], eps, err; + integer nalf, idim[9]; + logical same; + integer nbet, ntra; + logical rewi; + extern /* Subroutine */ int dchk1_(char *, doublereal *, doublereal *, + integer *, integer *, logical *, logical *, logical *, integer *, + integer *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *), + dchk2_(char *, doublereal *, doublereal *, integer *, integer *, + logical *, logical *, logical *, integer *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, integer *), dchk3_(char *, + doublereal *, doublereal *, integer *, integer *, logical *, + logical *, logical *, integer *, integer *, integer *, doublereal + *, integer *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, integer *), dchk4_(char *, + doublereal *, doublereal *, integer *, integer *, logical *, + logical *, logical *, integer *, integer *, integer *, doublereal + *, integer *, doublereal *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *), dchk5_(char *, doublereal *, + doublereal *, integer *, integer *, logical *, logical *, logical + *, integer *, integer *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *), dchk6_(char *, doublereal *, doublereal *, integer *, + integer *, logical *, logical *, logical *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *); + extern doublereal ddiff_(doublereal *, doublereal *); + logical fatal; + extern /* Subroutine */ int dmmch_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, doublereal *, + logical *, integer *, logical *); + logical trace; + integer nidim; + char snaps[32]; + integer isnum; + logical ltest[7], sfatal, corder; + char snamet[13], transa[1], transb[1]; + doublereal thresh; + logical rorder; + extern /* Subroutine */ int cd3chke_(char *); + integer layout; + logical ltestt, tsterr; + + /* Fortran I/O blocks */ + static cilist io___2 = { 0, 5, 0, 0, 0 }; + static cilist io___4 = { 0, 5, 0, 0, 0 }; + static cilist io___7 = { 0, 5, 0, 0, 0 }; + static cilist io___9 = { 0, 5, 0, 0, 0 }; + static cilist io___11 = { 0, 5, 0, 0, 0 }; + static cilist io___13 = { 0, 5, 0, 0, 0 }; + static cilist io___15 = { 0, 5, 0, 0, 0 }; + static cilist io___17 = { 0, 5, 0, 0, 0 }; + static cilist io___19 = { 0, 6, 0, fmt_9997, 0 }; + static cilist io___20 = { 0, 5, 0, 0, 0 }; + static cilist io___23 = { 0, 6, 0, fmt_9996, 0 }; + static cilist io___24 = { 0, 5, 0, 0, 0 }; + static cilist io___26 = { 0, 6, 0, fmt_9997, 0 }; + static cilist io___27 = { 0, 5, 0, 0, 0 }; + static cilist io___29 = { 0, 5, 0, 0, 0 }; + static cilist io___31 = { 0, 6, 0, fmt_9997, 0 }; + static cilist io___32 = { 0, 5, 0, 0, 0 }; + static cilist io___34 = { 0, 6, 0, fmt_9995, 0 }; + static cilist io___35 = { 0, 6, 0, fmt_9994, 0 }; + static cilist io___36 = { 0, 6, 0, fmt_9993, 0 }; + static cilist io___37 = { 0, 6, 0, fmt_9992, 0 }; + static cilist io___38 = { 0, 6, 0, 0, 0 }; + static cilist io___39 = { 0, 6, 0, fmt_9984, 0 }; + static cilist io___40 = { 0, 6, 0, 0, 0 }; + static cilist io___41 = { 0, 6, 0, fmt_9999, 0 }; + static cilist io___42 = { 0, 6, 0, 0, 0 }; + static cilist io___45 = { 0, 6, 0, fmt_10002, 0 }; + static cilist io___46 = { 0, 6, 0, fmt_10001, 0 }; + static cilist io___47 = { 0, 6, 0, fmt_10000, 0 }; + static cilist io___48 = { 0, 6, 0, 0, 0 }; + static cilist io___50 = { 0, 5, 1, fmt_9988, 0 }; + static cilist io___53 = { 0, 6, 0, fmt_9990, 0 }; + static cilist io___55 = { 0, 6, 0, fmt_9998, 0 }; + static cilist io___68 = { 0, 6, 0, fmt_9989, 0 }; + static cilist io___69 = { 0, 6, 0, fmt_9989, 0 }; + static cilist io___70 = { 0, 6, 0, fmt_9989, 0 }; + static cilist io___71 = { 0, 6, 0, fmt_9989, 0 }; + static cilist io___73 = { 0, 6, 0, 0, 0 }; + static cilist io___74 = { 0, 6, 0, fmt_9987, 0 }; + static cilist io___75 = { 0, 6, 0, 0, 0 }; + static cilist io___82 = { 0, 6, 0, fmt_9986, 0 }; + static cilist io___83 = { 0, 6, 0, fmt_9985, 0 }; + static cilist io___84 = { 0, 6, 0, fmt_9991, 0 }; + + /* Test program for the DOUBLE PRECISION Level 3 Blas. */ /* The program must be driven by a short data file. The first 13 records */ /* of the file are read using list-directed input, the last 6 records */ -/* are read using the format ( 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 +563,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,35 +586,21 @@ 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. */ infoc_1.noutc = 6; /* Read name and unit number for snapshot output file and open file. */ - char line[80]; - - fgets(line,80,stdin); - sscanf(line,"'%s'",snaps); - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&ntra); -#else - sscanf(line,"%d",&ntra); -#endif + s_rsle(&io___2); + do_lio(&c__9, &c__1, snaps, (ftnlen)32); + e_rsle(); + s_rsle(&io___4); + do_lio(&c__3, &c__1, (char *)&ntra, (ftnlen)sizeof(integer)); + e_rsle(); trace = ntra >= 0; if (trace) { -/* o__1.oerr = 0; + o__1.oerr = 0; o__1.ounit = ntra; o__1.ofnmlen = 32; o__1.ofnm = snaps; @@ -396,156 +609,194 @@ static logical c_false = FALSE_; o__1.oacc = 0; o__1.ofm = 0; o__1.oblnk = 0; - f_open(&o__1);*/ + f_open(&o__1); } /* Read the flag that directs rewinding of the snapshot file. */ - fgets(line,80,stdin); - sscanf(line,"%d",&rewi); - rewi = rewi && trace; + s_rsle(&io___7); + do_lio(&c__8, &c__1, (char *)&rewi, (ftnlen)sizeof(logical)); + e_rsle(); + rewi = rewi && trace; /* Read the flag that directs stopping on any failure. */ - fgets(line,80,stdin); - sscanf(line,"%c",&tmpchar); -/* Read the flag that indicates whether error exits are to be tested. */ - sfatal=FALSE_; - if (tmpchar=='T')sfatal=TRUE_; - fgets(line,80,stdin); - sscanf(line,"%c",&tmpchar); + s_rsle(&io___9); + do_lio(&c__8, &c__1, (char *)&sfatal, (ftnlen)sizeof(logical)); + e_rsle(); /* Read the flag that indicates whether error exits are to be tested. */ - tsterr=FALSE_; - if (tmpchar=='T')tsterr=TRUE_; + s_rsle(&io___11); + do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical)); + e_rsle(); /* Read the flag that indicates whether row-major data layout to be tested. */ - fgets(line,80,stdin); - sscanf(line,"%d",&layout); + s_rsle(&io___13); + do_lio(&c__3, &c__1, (char *)&layout, (ftnlen)sizeof(integer)); + e_rsle(); /* Read the threshold value of the test ratio */ - fgets(line,80,stdin); - sscanf(line,"%lf",&thresh); + s_rsle(&io___15); + do_lio(&c__5, &c__1, (char *)&thresh, (ftnlen)sizeof(doublereal)); + e_rsle(); + /* Read and check the parameter values for the tests. */ /* Values of N */ - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&nidim); -#else - sscanf(line,"%d",&nidim); -#endif - + s_rsle(&io___17); + do_lio(&c__3, &c__1, (char *)&nidim, (ftnlen)sizeof(integer)); + e_rsle(); if (nidim < 1 || nidim > 9) { - fprintf(stderr,"NUMBER OF VALUES OF N IS LESS THAN 1 OR GREATER THAN 9"); - goto L220; + s_wsfe(&io___19); + do_fio(&c__1, "N", (ftnlen)1); + do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer)); + e_wsfe(); + goto L220; } - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld %ld %ld %ld %ld %ld %ld %ld %ld",&idim[0],&idim[1],&idim[2], - &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]); -#else - sscanf(line,"%d %d %d %d %d %d %d %d %d",&idim[0],&idim[1],&idim[2], - &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]); -#endif + s_rsle(&io___20); 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; - } + do_lio(&c__3, &c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer)); + } + e_rsle(); + i__1 = nidim; + for (i__ = 1; i__ <= i__1; ++i__) { + if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) { + s_wsfe(&io___23); + do_fio(&c__1, (char *)&c__65, (ftnlen)sizeof(integer)); + e_wsfe(); + goto L220; + } /* L10: */ } /* Values of ALPHA */ - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&nalf); -#else - sscanf(line,"%d",&nalf); -#endif + s_rsle(&io___24); + do_lio(&c__3, &c__1, (char *)&nalf, (ftnlen)sizeof(integer)); + e_rsle(); if (nalf < 1 || nalf > 7) { - fprintf(stderr,"VALUE OF ALPHA IS LESS THAN 0 OR GREATER THAN 7\n"); - goto L220; + s_wsfe(&io___26); + do_fio(&c__1, "ALPHA", (ftnlen)5); + do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer)); + e_wsfe(); + goto L220; } - fgets(line,80,stdin); - sscanf(line,"%lf %lf %lf %lf %lf %lf %lf",&alf[0],&alf[1],&alf[2],&alf[3],&alf[4],&alf[5],&alf[6]); - + s_rsle(&io___27); + i__1 = nalf; + for (i__ = 1; i__ <= i__1; ++i__) { + do_lio(&c__5, &c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(doublereal) + ); + } + e_rsle(); /* Values of BETA */ - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&nbet); -#else - sscanf(line,"%d",&nbet); -#endif - if (nalf < 1 || nbet > 7) { - fprintf(stderr,"VALUE OF BETA IS LESS THAN 0 OR GREATER THAN 7\n"); - goto L220; + s_rsle(&io___29); + do_lio(&c__3, &c__1, (char *)&nbet, (ftnlen)sizeof(integer)); + e_rsle(); + if (nbet < 1 || nbet > 7) { + s_wsfe(&io___31); + do_fio(&c__1, "BETA", (ftnlen)4); + do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer)); + e_wsfe(); + goto L220; + } + s_rsle(&io___32); + i__1 = nbet; + for (i__ = 1; i__ <= i__1; ++i__) { + do_lio(&c__5, &c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(doublereal) + ); } - fgets(line,80,stdin); - sscanf(line,"%lf %lf %lf %lf %lf %lf %lf",&bet[0],&bet[1],&bet[2],&bet[3],&bet[4],&bet[5],&bet[6]); + e_rsle(); /* Report values of parameters. */ - printf("TESTS OF THE DOUBLE PRECISION LEVEL 3 BLAS\nTHE FOLLOWING PARAMETER VALUES WILL BE USED:\n"); - printf(" FOR N"); - for (i__ =1; i__ <=nidim;++i__) printf(" %d",idim[i__-1]); - printf("\n"); - printf(" FOR ALPHA"); - for (i__ =1; i__ <=nalf;++i__) printf(" %f",alf[i__-1]); - printf("\n"); - printf(" FOR BETA"); - for (i__ =1; i__ <=nbet;++i__) printf(" %f",bet[i__-1]); - printf("\n"); - + s_wsfe(&io___34); + e_wsfe(); + s_wsfe(&io___35); + i__1 = nidim; + for (i__ = 1; i__ <= i__1; ++i__) { + do_fio(&c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer)); + } + e_wsfe(); + s_wsfe(&io___36); + i__1 = nalf; + for (i__ = 1; i__ <= i__1; ++i__) { + do_fio(&c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(doublereal)); + } + e_wsfe(); + s_wsfe(&io___37); + i__1 = nbet; + for (i__ = 1; i__ <= i__1; ++i__) { + do_fio(&c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(doublereal)); + } + e_wsfe(); if (! tsterr) { - printf(" ERROR-EXITS WILL NOT BE TESTED\n"); + s_wsle(&io___38); + e_wsle(); + s_wsfe(&io___39); + e_wsfe(); } - printf("ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LESS THAN %f\n",thresh); - + s_wsle(&io___40); + e_wsle(); + s_wsfe(&io___41); + do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(doublereal)); + e_wsfe(); + s_wsle(&io___42); + e_wsle(); rorder = FALSE_; corder = FALSE_; if (layout == 2) { rorder = TRUE_; corder = TRUE_; - printf("COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED\n"); + s_wsfe(&io___45); + e_wsfe(); } else if (layout == 1) { rorder = TRUE_; - printf("ROW-MAJOR DATA LAYOUT IS TESTED\n"); + s_wsfe(&io___46); + e_wsfe(); } else if (layout == 0) { corder = TRUE_; - printf("COLUMN-MAJOR DATA LAYOUT IS TESTED\n"); + s_wsfe(&io___47); + e_wsfe(); } + s_wsle(&io___48); + e_wsle(); /* Read names of subroutines and flags which indicate */ /* whether they are to be tested. */ - for (i__ = 1; i__ <= 6; ++i__) { + for (i__ = 1; i__ <= 7; ++i__) { ltest[i__ - 1] = FALSE_; /* L20: */ } L30: - if (! fgets(line,80,stdin)) { - goto L60; - } - i__1 = sscanf(line,"%12c %c",snamet,&tmpchar); - ltestt=FALSE_; - if (tmpchar=='T')ltestt=TRUE_; - if (i__1 < 2) { - goto L60; - } - for (i__ = 1; i__ <= 6; ++i__) { - if (s_cmp(snamet, snames[i__ - 1] , (ftnlen)12, (ftnlen)12) == - 0) { - goto L50; - } + i__1 = s_rsfe(&io___50); + if (i__1 != 0) { + goto L60; + } + i__1 = do_fio(&c__1, snamet, (ftnlen)13); + if (i__1 != 0) { + goto L60; + } + i__1 = do_fio(&c__1, (char *)<estt, (ftnlen)sizeof(logical)); + if (i__1 != 0) { + goto L60; + } + i__1 = e_rsfe(); + if (i__1 != 0) { + goto L60; + } + for (i__ = 1; i__ <= 7; ++i__) { + if (s_cmp(snamet, snames + (i__ - 1) * 13, (ftnlen)13, (ftnlen)13) == + 0) { + goto L50; + } /* L40: */ } - printf("SUBPROGRAM NAME %s NOT RECOGNIZED\n****** TESTS ABANDONED ******\n",snamet); - exit(1); - - + s_wsfe(&io___53); + do_fio(&c__1, snamet, (ftnlen)13); + e_wsfe(); + s_stop("", (ftnlen)0); L50: ltest[i__ - 1] = ltestt; goto L30; L60: -/* cl__1.cerr = 0; + cl__1.cerr = 0; cl__1.cunit = 5; cl__1.csta = 0; - f_clos(&cl__1);*/ + f_clos(&cl__1); /* Compute EPS (the machine precision). */ @@ -559,7 +810,9 @@ static logical c_false = FALSE_; goto L70; L80: eps += eps; - printf("RELATIVE MACHINE PRECISION IS TAKEN TO BE %9.1g\n",eps); + s_wsfe(&io___55); + do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal)); + e_wsfe(); /* Check the reliability of DMMCH using exact data. */ @@ -590,28 +843,30 @@ 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"); - 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); + s_wsfe(&io___68); + do_fio(&c__1, transa, (ftnlen)1); + do_fio(&c__1, transb, (ftnlen)1); + do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical)); + do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal)); + e_wsfe(); + s_stop("", (ftnlen)0); } *(unsigned char *)transb = 'T'; dmmch_(transa, transb, &n, &c__1, &n, &c_b90, ab, &c__65, &ab[4225], & c__65, &c_b104, c__, &c__65, ct, g, cc, &c__65, &eps, &err, & - fatal, &c__6, &c_true, (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); + s_wsfe(&io___69); + do_fio(&c__1, transa, (ftnlen)1); + do_fio(&c__1, transb, (ftnlen)1); + do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical)); + do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal)); + e_wsfe(); + s_stop("", (ftnlen)0); } i__1 = n; for (j = 1; j <= i__1; ++j) { @@ -629,122 +884,152 @@ 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"); - 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); + s_wsfe(&io___70); + do_fio(&c__1, transa, (ftnlen)1); + do_fio(&c__1, transb, (ftnlen)1); + do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical)); + do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal)); + e_wsfe(); + s_stop("", (ftnlen)0); } *(unsigned char *)transb = 'T'; dmmch_(transa, transb, &n, &c__1, &n, &c_b90, ab, &c__65, &ab[4225], & c__65, &c_b104, c__, &c__65, ct, g, cc, &c__65, &eps, &err, & - fatal, &c__6, &c_true, (ftnlen)1, (ftnlen)1); + fatal, &c__6, &c_true); same = lde_(cc, ct, &n); if (! same || err != 0.) { + s_wsfe(&io___71); + do_fio(&c__1, transa, (ftnlen)1); + do_fio(&c__1, transb, (ftnlen)1); + do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical)); + do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal)); + e_wsfe(); + s_stop("", (ftnlen)0); } /* Test each subroutine in turn. */ - for (isnum = 1; isnum <= 6; ++isnum) { + for (isnum = 1; isnum <= 7; ++isnum) { + s_wsle(&io___73); + e_wsle(); if (! ltest[isnum - 1]) { /* Subprogram is not to be tested. */ - printf("%12s WAS NOT TESTED\n",snames[isnum-1]); + s_wsfe(&io___74); + do_fio(&c__1, snames + (isnum - 1) * 13, (ftnlen)13); + e_wsfe(); } else { - s_copy(srnamc_1.srnamt, snames[isnum - 1], (ftnlen)12, ( - ftnlen)12); + s_copy(srnamc_1.srnamt, snames + (isnum - 1) * 13, (ftnlen)13, ( + ftnlen)13); /* Test error exits. */ if (tsterr) { - cd3chke_(snames[isnum - 1], (ftnlen)12); + cd3chke_(snames + (isnum - 1) * 13); + s_wsle(&io___75); + e_wsle(); } /* Test computations. */ infoc_1.infot = 0; infoc_1.ok = TRUE_; fatal = FALSE_; - switch ((int)isnum) { + switch (isnum) { case 1: goto L140; case 2: goto L150; case 3: goto L160; case 4: goto L160; case 5: goto L170; case 6: goto L180; + case 7: goto L185; } /* Test DGEMM, 01. */ L140: if (corder) { - dchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + dchk1_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__0, (ftnlen)12); + cc, cs, ct, g, &c__0); } if (rorder) { - dchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + dchk1_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__1, (ftnlen)12); + cc, cs, ct, g, &c__1); } goto L190; /* Test DSYMM, 02. */ L150: if (corder) { - dchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + dchk2_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__0, (ftnlen)12); + cc, cs, ct, g, &c__0); } if (rorder) { - dchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + dchk2_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__1, (ftnlen)12); + cc, cs, ct, g, &c__1); } goto L190; /* Test DTRMM, 03, DTRSM, 04. */ L160: if (corder) { - dchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + dchk3_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, & - c__0, (ftnlen)12); + c__0); } if (rorder) { - dchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + dchk3_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, & - c__1, (ftnlen)12); + c__1); } goto L190; /* Test DSYRK, 05. */ L170: if (corder) { - dchk4_(snames[isnum -1], &eps, &thresh, &c__6, &ntra, + dchk4_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__0, (ftnlen)12); + cc, cs, ct, g, &c__0); } if (rorder) { - dchk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + dchk4_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__1, (ftnlen)12); + cc, cs, ct, g, &c__1); } goto L190; /* Test DSYR2K, 06. */ L180: if (corder) { - dchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + dchk5_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, + ct, g, w, &c__0); + } + if (rorder) { + dchk5_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, + ct, g, w, &c__1); + } + goto L190; +/* Test DGEMMTR, 07. */ +L185: + if (corder) { + dchk6_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, - ct, g, w, &c__0, (ftnlen)12); + ct, g, w, &c__0); } if (rorder) { - dchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + dchk6_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, - ct, g, w, &c__1, (ftnlen)12); + ct, g, w, &c__1); } goto L190; @@ -755,66 +1040,114 @@ static logical c_false = FALSE_; } /* L200: */ } - printf("\nEND OF TESTS\n"); + s_wsfe(&io___82); + e_wsfe(); goto L230; L210: - printf("\n****** FATAL ERROR - TESTS ABANDONED ******\n"); + s_wsfe(&io___83); + e_wsfe(); goto L230; L220: - printf("AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM\n"); - printf("****** TESTS ABANDONED ******\n"); + s_wsfe(&io___84); + e_wsfe(); L230: if (trace) { -/* cl__1.cerr = 0; + cl__1.cerr = 0; cl__1.cunit = ntra; cl__1.csta = 0; - f_clos(&cl__1);*/ + f_clos(&cl__1); } -/* cl__1.cerr = 0; + cl__1.cerr = 0; cl__1.cunit = 6; cl__1.csta = 0; - f_clos(&cl__1);*/ - exit(0); + f_clos(&cl__1); + s_stop("", (ftnlen)0); + /* End of DBLAT3. */ + return 0; } /* MAIN__ */ -/* Subroutine */ int dchk1_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublereal* alf, integer* nbet, doublereal* bet, integer* nmax, doublereal* a, doublereal* aa, doublereal* as, doublereal* b, doublereal* bb, doublereal* bs, doublereal* c__, doublereal* cc, doublereal* cs, doublereal* ct, doublereal* g, integer* iorder, 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 */ - static char ich[3+1] = "NTC"; + static char ich[3] = "NTC"; + + /* Format strings */ + static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT " + "TAKEN ON VALID CALL *******\002)"; + static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER" + " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)"; + static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO" + "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR " + " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM" + "BER:\002)"; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6; - + alist al__1; /* Local variables */ - static doublereal beta; - static integer ldas, ldbs, ldcs; - static logical same, null; - static integer i__, k, m, n; - extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*, ftnlen, ftnlen, ftnlen); - static doublereal alpha; - extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); - static logical isame[13], trana, tranb; - static integer nargs; - static logical reset; - extern /* Subroutine */ void dprcn1_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, integer*, doublereal*, integer*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen); - static integer ia, ib, ma, mb, na, nb, nc, ik, im, in; - extern /* Subroutine */ void cdgemm_(integer*, char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen); - static integer ks, ms, ns; - extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen); - static char tranas[1], tranbs[1], transa[1], transb[1]; - static doublereal errmax; - static integer ica, icb, laa, lbb, lda, lcc, ldb, ldc; - extern logical lde_(doublereal*, doublereal*, integer*); - static doublereal als, bls, err; + integer i__, k, m, n, ia, ib, ma, mb, na, nb, nc, ik, im, in, ks, ms, ns, + ica, icb, laa, lbb, lda, lcc, ldb, ldc; + extern logical lde_(doublereal *, doublereal *, integer *); + doublereal als, bls, err, beta; + integer ldas, ldbs, ldcs; + logical same, null; + extern /* Subroutine */ int dmake_(char *, char *, char *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + logical *, doublereal *); + doublereal alpha; + extern /* Subroutine */ int dmmch_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, doublereal *, + logical *, integer *, logical *); + logical isame[13], trana, tranb; + integer nargs; + logical reset; + extern /* Subroutine */ int dprcn1_(integer *, integer *, char *, integer + *, char *, char *, integer *, integer *, integer *, doublereal *, + integer *, integer *, doublereal *, integer *), cdgemm_(integer *, char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *); + extern logical lderes_(char *, char *, integer *, integer *, doublereal *, + doublereal *, integer *); + char tranas[1], tranbs[1], transa[1], transb[1]; + doublereal errmax; + + /* Fortran I/O blocks */ + static cilist io___128 = { 0, 0, 0, fmt_9994, 0 }; + static cilist io___131 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___133 = { 0, 0, 0, fmt_10000, 0 }; + static cilist io___134 = { 0, 0, 0, fmt_10001, 0 }; + static cilist io___135 = { 0, 0, 0, fmt_10002, 0 }; + static cilist io___136 = { 0, 0, 0, fmt_10003, 0 }; + static cilist io___137 = { 0, 0, 0, fmt_9996, 0 }; + + /* Tests DGEMM. */ @@ -826,17 +1159,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 +1168,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 +1238,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 +1267,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 +1280,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,23 +1320,23 @@ 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; + al__1.aerr = 0; al__1.aunit = *ntra; - f_rew(&al__1);*/ + f_rew(&al__1); } cdgemm_(iorder, transa, transb, &m, &n, &k, & alpha, &aa[1], &lda, &bb[1], &ldb, & - beta, &cc[1], &ldc, (ftnlen)1, ( - ftnlen)1); + 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"); + io___128.ciunit = *nout; + s_wsfe(&io___128); + e_wsfe(); *fatal = TRUE_; goto L120; } @@ -1042,8 +1360,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; @@ -1055,7 +1372,11 @@ static logical c_false = FALSE_; for (i__ = 1; i__ <= i__6; ++i__) { same = same && isame[i__ - 1]; if (! isame[i__ - 1]) { - printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + io___131.ciunit = *nout; + s_wsfe(&io___131); + do_fio(&c__1, (char *)&i__, (ftnlen) + sizeof(integer)); + e_wsfe(); } /* L40: */ } @@ -1072,8 +1393,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. */ @@ -1110,44 +1430,74 @@ static logical c_false = FALSE_; if (errmax < *thresh) { if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___133.ciunit = *nout; + s_wsfe(&io___133); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___134.ciunit = *nout; + s_wsfe(&io___134); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } } else { if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___135.ciunit = *nout; + s_wsfe(&io___135); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal)); + e_wsfe(); } if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___136.ciunit = *nout; + s_wsfe(&io___136); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal)); + e_wsfe(); } } goto L130; L120: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + io___137.ciunit = *nout; + s_wsfe(&io___137); + do_fio(&c__1, sname, (ftnlen)13); + e_wsfe(); dprcn1_(nout, &nc, sname, iorder, transa, transb, &m, &n, &k, &alpha, & - lda, &ldb, &beta, &ldc, (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 */ int dprcn1_(integer *nout, integer *nc, char *sname, integer + *iorder, char *transa, char *transb, integer *m, integer *n, integer * + k, doublereal *alpha, integer *lda, integer *ldb, doublereal *beta, + integer *ldc) { + /* Format strings */ + static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002," + "a14,\002,\002,a14,\002,\002)"; + static char fmt_9994[] = "(20x,3(i3,\002,\002),f4.1,\002, A,\002,i3,\002" + ", B,\002,i3,\002,\002,f4.1,\002, \002,\002C,\002,i3,\002).\002)"; /* Local variables */ - static char crc[14], cta[14], ctb[14]; + char crc[14], cta[14], ctb[14]; + + /* Fortran I/O blocks */ + static cilist io___141 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___142 = { 0, 0, 0, fmt_9994, 0 }; + if (*(unsigned char *)transa == 'N') { s_copy(cta, " CblasNoTrans", (ftnlen)14, (ftnlen)14); @@ -1168,50 +1518,114 @@ static logical c_false = FALSE_; } else { s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cta,ctb); - printf("%d %d %d %4.1f A, %d, B, %d, %4.1f, C, %d.\n",*m,*n,*k,*alpha,*lda,*ldb,*beta,*ldc); + io___141.ciunit = *nout; + s_wsfe(&io___141); + do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer)); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, crc, (ftnlen)14); + do_fio(&c__1, cta, (ftnlen)14); + do_fio(&c__1, ctb, (ftnlen)14); + e_wsfe(); + io___142.ciunit = *nout; + s_wsfe(&io___142); + do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(doublereal)); + do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(doublereal)); + do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer)); + e_wsfe(); + return 0; } /* dprcn1_ */ -/* Subroutine */ int dchk2_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublereal* alf, integer* nbet, doublereal* bet, integer* nmax, doublereal* a, doublereal* aa, doublereal* as, doublereal* b, doublereal* bb, doublereal* bs, doublereal* c__, doublereal* cc, doublereal* cs, doublereal* ct, doublereal* g, integer* iorder, 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 */ - static char ichs[2+1] = "LR"; - static char ichu[2+1] = "UL"; + static char ichs[2] = "LR"; + static char ichu[2] = "UL"; + + /* Format strings */ + static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT " + "TAKEN ON VALID CALL *******\002)"; + static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER" + " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)"; + static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO" + "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR " + " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM" + "BER:\002)"; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5; - + alist al__1; /* Local variables */ - static doublereal beta; - static integer ldas, ldbs, ldcs; - static logical same; - static char side[1]; - static logical left, null; - static char uplo[1]; - static integer i__, m, n; - extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*, ftnlen, ftnlen, ftnlen); - static doublereal alpha; - extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); - static logical isame[13]; - static char sides[1]; - static integer nargs; - static logical reset; - static char uplos[1]; - extern /* Subroutine */ void dprcn2_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublereal*, integer*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen); - static integer ia, ib, na, nc, im, in, ms, ns; - extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen); - extern /* Subroutine */ void cdsymm_(integer*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen); - static doublereal errmax; - static integer laa, lbb, lda, lcc, ldb, ldc; - extern logical lde_(doublereal*, doublereal*, integer*); - static integer ics; - static doublereal als, bls; - static integer icu; - static doublereal err; + integer i__, m, n, ia, ib, na, nc, im, in, ms, ns, laa, lbb, lda, lcc, + ldb, ldc; + extern logical lde_(doublereal *, doublereal *, integer *); + integer ics; + doublereal als, bls; + integer icu; + doublereal err, beta; + integer ldas, ldbs, ldcs; + logical same; + char side[1]; + logical left, null; + char uplo[1]; + extern /* Subroutine */ int dmake_(char *, char *, char *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + logical *, doublereal *); + doublereal alpha; + extern /* Subroutine */ int dmmch_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, doublereal *, + logical *, integer *, logical *); + logical isame[13]; + char sides[1]; + integer nargs; + logical reset; + char uplos[1]; + extern /* Subroutine */ int dprcn2_(integer *, integer *, char *, integer + *, char *, char *, integer *, integer *, doublereal *, integer *, + integer *, doublereal *, integer *); + extern logical lderes_(char *, char *, integer *, integer *, doublereal *, + doublereal *, integer *); + extern /* Subroutine */ int cdsymm_(integer *, char *, char *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *); + doublereal errmax; + + /* Fortran I/O blocks */ + static cilist io___180 = { 0, 0, 0, fmt_9994, 0 }; + static cilist io___183 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___185 = { 0, 0, 0, fmt_10000, 0 }; + static cilist io___186 = { 0, 0, 0, fmt_10001, 0 }; + static cilist io___187 = { 0, 0, 0, fmt_10002, 0 }; + static cilist io___188 = { 0, 0, 0, fmt_10003, 0 }; + static cilist io___189 = { 0, 0, 0, fmt_9996, 0 }; + + /* Tests DSYMM. */ @@ -1223,17 +1637,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 +1646,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 +1699,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 +1727,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 +1740,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,22 +1777,23 @@ 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) { -/* al__1.aerr = 0; + al__1.aerr = 0; al__1.aunit = *ntra; - f_rew(&al__1);*/ + f_rew(&al__1); } cdsymm_(iorder, side, uplo, &m, &n, &alpha, &aa[1] - , &lda, &bb[1], &ldb, &beta, &cc[1], &ldc, - (ftnlen)1, (ftnlen)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"); + io___180.ciunit = *nout; + s_wsfe(&io___180); + e_wsfe(); *fatal = TRUE_; goto L110; } @@ -1415,7 +1816,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; @@ -1427,7 +1828,11 @@ static logical c_false = FALSE_; 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__); + io___183.ciunit = *nout; + s_wsfe(&io___183); + do_fio(&c__1, (char *)&i__, (ftnlen) + sizeof(integer)); + e_wsfe(); } /* L40: */ } @@ -1445,15 +1850,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 */ @@ -1487,45 +1890,74 @@ static logical c_false = FALSE_; if (errmax < *thresh) { if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___185.ciunit = *nout; + s_wsfe(&io___185); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___186.ciunit = *nout; + s_wsfe(&io___186); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } } else { if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___187.ciunit = *nout; + s_wsfe(&io___187); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal)); + e_wsfe(); } if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___188.ciunit = *nout; + s_wsfe(&io___188); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal)); + e_wsfe(); } } goto L120; L110: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + io___189.ciunit = *nout; + s_wsfe(&io___189); + do_fio(&c__1, sname, (ftnlen)13); + e_wsfe(); dprcn2_(nout, &nc, sname, iorder, side, uplo, &m, &n, &alpha, &lda, &ldb, - &beta, &ldc, (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 */ int dprcn2_(integer *nout, integer *nc, char *sname, integer + *iorder, char *side, char *uplo, integer *m, integer *n, doublereal * + alpha, integer *lda, integer *ldb, doublereal *beta, integer *ldc) { + /* Format strings */ + static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002," + "a14,\002,\002,a14,\002,\002)"; + static char fmt_9994[] = "(20x,2(i3,\002,\002),f4.1,\002, A,\002,i3,\002" + ", B,\002,i3,\002,\002,f4.1,\002, \002,\002C,\002,i3,\002).\002)"; /* Local variables */ - static char cs[14], cu[14], crc[14]; + char cs[14], cu[14], crc[14]; + + /* Fortran I/O blocks */ + static cilist io___193 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___194 = { 0, 0, 0, fmt_9994, 0 }; + if (*(unsigned char *)side == 'L') { s_copy(cs, " CblasLeft", (ftnlen)14, (ftnlen)14); @@ -1542,54 +1974,119 @@ static logical c_false = FALSE_; } else { s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cs,cu); - printf("%d %d %4.1f A, %d, B, %d, %4.1f C, %d.\n",*m,*n,*alpha,*lda,*ldb,*beta,*ldc); + io___193.ciunit = *nout; + s_wsfe(&io___193); + do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer)); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, crc, (ftnlen)14); + do_fio(&c__1, cs, (ftnlen)14); + do_fio(&c__1, cu, (ftnlen)14); + e_wsfe(); + io___194.ciunit = *nout; + s_wsfe(&io___194); + do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(doublereal)); + do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(doublereal)); + do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer)); + e_wsfe(); + return 0; } /* dprcn2_ */ -/* Subroutine */ int dchk3_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublereal* alf, integer* nmax, doublereal* a, doublereal* aa, doublereal* as, doublereal* b, doublereal* bb, doublereal* bs, doublereal* ct, doublereal* g, doublereal* c__, integer* iorder, 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 */ - static char ichu[2+1] = "UL"; - static char icht[3+1] = "NTC"; - static char ichd[2+1] = "UN"; - static char ichs[2+1] = "LR"; + static char ichu[2] = "UL"; + static char icht[3] = "NTC"; + static char ichd[2] = "UN"; + static char ichs[2] = "LR"; + + /* Format strings */ + static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT " + "TAKEN ON VALID CALL *******\002)"; + static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER" + " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)"; + static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO" + "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR " + " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM" + "BER:\002)"; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5; + alist al__1; /* Local variables */ - static char diag[1]; - static integer ldas, ldbs; - static logical same; - static char side[1]; - static logical left, null; - static char uplo[1]; - static integer i__, j, m, n; - extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*, ftnlen, ftnlen, ftnlen); - static doublereal alpha; - static char diags[1]; - extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); - static logical isame[13]; - static char sides[1]; - static integer nargs; - static logical reset; - static char uplos[1]; - extern /* Subroutine */ void dprcn3_(integer*, integer*, char*, integer*, char*, char*, char*, char*, integer*, integer*, doublereal*, integer*, integer*, ftnlen, ftnlen, ftnlen, ftnlen, ftnlen); - static integer ia, na, nc, im, in, ms, ns; - extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen); - extern /* Subroutine */ void cdtrmm_(integer*, char*, char*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen, ftnlen); - static char tranas[1], transa[1]; - extern /* Subroutine */ void cdtrsm_(integer*, char*, char*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen, ftnlen); - static doublereal errmax; - static integer laa, icd, lbb, lda, ldb; - extern logical lde_(doublereal*, doublereal*, integer*); - static integer ics; - static doublereal als; - static integer ict, icu; - static doublereal err; + integer i__, j, m, n, ia, na, nc, im, in, ms, ns, laa, icd, lbb, lda, ldb; + extern logical lde_(doublereal *, doublereal *, integer *); + integer ics; + doublereal als; + integer ict, icu; + doublereal err; + char diag[1]; + integer ldas, ldbs; + logical same; + char side[1]; + logical left, null; + char uplo[1]; + extern /* Subroutine */ int dmake_(char *, char *, char *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + logical *, doublereal *); + doublereal alpha; + char diags[1]; + extern /* Subroutine */ int dmmch_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, doublereal *, + logical *, integer *, logical *); + logical isame[13]; + char sides[1]; + integer nargs; + logical reset; + char uplos[1]; + extern /* Subroutine */ int dprcn3_(integer *, integer *, char *, integer + *, char *, char *, char *, char *, integer *, integer *, + doublereal *, integer *, integer *); + extern logical lderes_(char *, char *, integer *, integer *, doublereal *, + doublereal *, integer *); + extern /* Subroutine */ int cdtrmm_(integer *, char *, char *, char *, + char *, integer *, integer *, doublereal *, doublereal *, integer + *, doublereal *, integer *); + char tranas[1], transa[1]; + extern /* Subroutine */ int cdtrsm_(integer *, char *, char *, char *, + char *, integer *, integer *, doublereal *, doublereal *, integer + *, doublereal *, integer *); + doublereal errmax; + + /* Fortran I/O blocks */ + static cilist io___235 = { 0, 0, 0, fmt_9994, 0 }; + static cilist io___238 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___240 = { 0, 0, 0, fmt_10000, 0 }; + static cilist io___241 = { 0, 0, 0, fmt_10001, 0 }; + static cilist io___242 = { 0, 0, 0, fmt_10002, 0 }; + static cilist io___243 = { 0, 0, 0, fmt_10003, 0 }; + static cilist io___244 = { 0, 0, 0, fmt_9996, 0 }; + + /* Tests DTRMM and DTRSM. */ @@ -1601,38 +2098,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 +2191,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; @@ -1752,42 +2235,42 @@ static logical c_false = FALSE_; dprcn3_(ntra, &nc, sname, iorder, side, uplo, transa, diag, &m, &n, &alpha, &lda, &ldb, ( - ftnlen)12, (ftnlen)1, (ftnlen) + ftnlen)13, (ftnlen)1, (ftnlen) 1, (ftnlen)1, (ftnlen)1); } if (*rewi) { -/* al__1.aerr = 0; + al__1.aerr = 0; al__1.aunit = *ntra; - f_rew(&al__1);*/ + f_rew(&al__1); } 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) + ftnlen)13, (ftnlen)1, (ftnlen) 1, (ftnlen)1, (ftnlen)1); } if (*rewi) { -/* al__1.aerr = 0; + al__1.aerr = 0; al__1.aunit = *ntra; - f_rew(&al__1);*/ + f_rew(&al__1); } 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. */ if (! infoc_1.ok) { - printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + io___235.ciunit = *nout; + s_wsfe(&io___235); + e_wsfe(); *fatal = TRUE_; goto L150; } @@ -1811,8 +2294,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; @@ -1824,7 +2306,11 @@ static logical c_false = FALSE_; for (i__ = 1; i__ <= i__4; ++i__) { same = same && isame[i__ - 1]; if (! isame[i__ - 1]) { - printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + io___238.ciunit = *nout; + s_wsfe(&io___238); + do_fio(&c__1, (char *)&i__, (ftnlen) + sizeof(integer)); + e_wsfe(); } /* L50: */ } @@ -1855,8 +2341,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 +2369,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 +2377,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); @@ -1931,47 +2414,76 @@ static logical c_false = FALSE_; if (errmax < *thresh) { if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___240.ciunit = *nout; + s_wsfe(&io___240); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___241.ciunit = *nout; + s_wsfe(&io___241); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } } else { if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___242.ciunit = *nout; + s_wsfe(&io___242); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal)); + e_wsfe(); } if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___243.ciunit = *nout; + s_wsfe(&io___243); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal)); + e_wsfe(); } } goto L160; L150: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + io___244.ciunit = *nout; + s_wsfe(&io___244); + do_fio(&c__1, sname, (ftnlen)13); + e_wsfe(); if (*trace) { dprcn3_(ntra, &nc, sname, iorder, side, uplo, transa, diag, &m, &n, & - alpha, &lda, &ldb, (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 */ int dprcn3_(integer *nout, integer *nc, char *sname, integer + *iorder, char *side, char *uplo, char *transa, char *diag, integer *m, + integer *n, doublereal *alpha, integer *lda, integer *ldb) { + /* Format strings */ + static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002," + "a14,\002,\002,a14,\002,\002)"; + static char fmt_9994[] = "(22x,2(a14,\002,\002),2(i3,\002,\002),f4.1," + "\002, A,\002,i3,\002, B,\002,i3,\002).\002)"; /* Local variables */ - static char ca[14], cd[14], cs[14], cu[14], crc[14]; + char ca[14], cd[14], cs[14], cu[14], crc[14]; + + /* Fortran I/O blocks */ + static cilist io___250 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___251 = { 0, 0, 0, fmt_9994, 0 }; + if (*(unsigned char *)side == 'L') { s_copy(cs, " CblasLeft", (ftnlen)14, (ftnlen)14); @@ -2000,51 +2512,117 @@ static logical c_false = FALSE_; } else { s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cs,cu); - printf(" %s %s %d %d %4.1f A %d B %d\n",ca,cd,*m,*n,*alpha,*lda,*ldb); + io___250.ciunit = *nout; + s_wsfe(&io___250); + do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer)); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, crc, (ftnlen)14); + do_fio(&c__1, cs, (ftnlen)14); + do_fio(&c__1, cu, (ftnlen)14); + e_wsfe(); + io___251.ciunit = *nout; + s_wsfe(&io___251); + do_fio(&c__1, ca, (ftnlen)14); + do_fio(&c__1, cd, (ftnlen)14); + do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(doublereal)); + do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer)); + e_wsfe(); + return 0; } /* dprcn3_ */ -/* Subroutine */ int dchk4_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublereal* alf, integer* nbet, doublereal* bet, integer* nmax, doublereal* a, doublereal* aa, doublereal* as, doublereal* b, doublereal* bb, doublereal* bs, doublereal* c__, doublereal* cc, doublereal* cs, doublereal* ct, doublereal* g, integer* iorder, 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 */ - static char icht[3+1] = "NTC"; - static char ichu[2+1] = "UL"; + static char icht[3] = "NTC"; + static char ichu[2] = "UL"; + + /* Format strings */ + static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT " + "TAKEN ON VALID CALL *******\002)"; + static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER" + " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)"; + static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO" + "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR " + " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN" + " \002,i3)"; + static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM" + "BER:\002)"; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5; - + alist al__1; /* Local variables */ - static doublereal beta; - static integer ldas, ldcs; - static logical same; - static doublereal bets; - static logical tran, null; - static char uplo[1]; - static integer i__, j, k, n; - extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*, ftnlen, ftnlen, ftnlen); - static doublereal alpha; - extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); - static logical isame[13]; - static integer nargs; - static logical reset; - static char trans[1]; - static logical upper; - static char uplos[1]; - extern /* Subroutine */ void dprcn4_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen); - static integer ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns; - extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen); - static doublereal errmax; - extern /* Subroutine */ void cdsyrk_(integer*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen); - static char transs[1]; - static integer laa, lda, lcc, ldc; - extern logical lde_(doublereal*, doublereal*, integer*); - static doublereal als; - static integer ict, icu; - static doublereal err; + integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa, + lda, lcc, ldc; + extern logical lde_(doublereal *, doublereal *, integer *); + doublereal als; + integer ict, icu; + doublereal err, beta; + integer ldas, ldcs; + logical same; + doublereal bets; + logical tran, null; + char uplo[1]; + extern /* Subroutine */ int dmake_(char *, char *, char *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + logical *, doublereal *); + doublereal alpha; + extern /* Subroutine */ int dmmch_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, doublereal *, + logical *, integer *, logical *); + logical isame[13]; + integer nargs; + logical reset; + char trans[1]; + logical upper; + char uplos[1]; + extern /* Subroutine */ int dprcn4_(integer *, integer *, char *, integer + *, char *, char *, integer *, integer *, doublereal *, integer *, + doublereal *, integer *); + extern logical lderes_(char *, char *, integer *, integer *, doublereal *, + doublereal *, integer *); + doublereal errmax; + extern /* Subroutine */ int cdsyrk_(integer *, char *, char *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + doublereal *, integer *); + char transs[1]; + + /* Fortran I/O blocks */ + static cilist io___288 = { 0, 0, 0, fmt_9993, 0 }; + static cilist io___291 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___297 = { 0, 0, 0, fmt_10000, 0 }; + static cilist io___298 = { 0, 0, 0, fmt_10001, 0 }; + static cilist io___299 = { 0, 0, 0, fmt_10002, 0 }; + static cilist io___300 = { 0, 0, 0, fmt_10003, 0 }; + static cilist io___301 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___302 = { 0, 0, 0, fmt_9996, 0 }; + + /* Tests DSYRK. */ @@ -2056,17 +2634,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 +2643,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 +2707,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 +2725,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,22 +2755,22 @@ 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; + al__1.aerr = 0; al__1.aunit = *ntra; - f_rew(&al__1);*/ + f_rew(&al__1); } cdsyrk_(iorder, uplo, trans, &n, &k, &alpha, &aa[ - 1], &lda, &beta, &cc[1], &ldc, (ftnlen)1, - (ftnlen)1); + 1], &lda, &beta, &cc[1], &ldc); /* Check if error-exit was taken incorrectly. */ if (! infoc_1.ok) { - printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + io___288.ciunit = *nout; + s_wsfe(&io___288); + e_wsfe(); *fatal = TRUE_; goto L120; } @@ -2226,7 +2791,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; @@ -2238,8 +2803,12 @@ static logical c_false = FALSE_; 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__); - } + io___291.ciunit = *nout; + s_wsfe(&io___291); + do_fio(&c__1, (char *)&i__, (ftnlen) + sizeof(integer)); + e_wsfe(); + } /* L30: */ } if (! same) { @@ -2268,8 +2837,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 +2845,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; @@ -2318,49 +2886,82 @@ static logical c_false = FALSE_; if (errmax < *thresh) { if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___297.ciunit = *nout; + s_wsfe(&io___297); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___298.ciunit = *nout; + s_wsfe(&io___298); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } } else { if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___299.ciunit = *nout; + s_wsfe(&io___299); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal)); + e_wsfe(); } if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___300.ciunit = *nout; + s_wsfe(&io___300); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal)); + e_wsfe(); } } goto L130; L110: if (n > 1) { - printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j); + io___301.ciunit = *nout; + s_wsfe(&io___301); + do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer)); + e_wsfe(); } L120: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + io___302.ciunit = *nout; + s_wsfe(&io___302); + do_fio(&c__1, sname, (ftnlen)13); + e_wsfe(); dprcn4_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, & - beta, &ldc, (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 */ int dprcn4_(integer *nout, integer *nc, char *sname, integer + *iorder, char *uplo, char *transa, integer *n, integer *k, doublereal + *alpha, integer *lda, doublereal *beta, integer *ldc) { + /* Format strings */ + static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002," + "\002))"; + static char fmt_9994[] = "(20x,2(i3,\002,\002),f4.1,\002, A,\002,i3" + ",\002,\002,f4.1,\002, C,\002,i3,\002).\002)"; /* Local variables */ - static char ca[14], cu[14], crc[14]; + char ca[14], cu[14], crc[14]; + + /* Fortran I/O blocks */ + static cilist io___306 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___307 = { 0, 0, 0, fmt_9994, 0 }; + if (*(unsigned char *)uplo == 'U') { s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); @@ -2379,51 +2980,117 @@ static logical c_false = FALSE_; } else { s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); - printf("( %d %d %4.1f A %d %4.1f C %d\n",*n,*k,*alpha,*lda,*beta,*ldc); + io___306.ciunit = *nout; + s_wsfe(&io___306); + do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer)); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, crc, (ftnlen)14); + do_fio(&c__1, cu, (ftnlen)14); + do_fio(&c__1, ca, (ftnlen)14); + e_wsfe(); + io___307.ciunit = *nout; + s_wsfe(&io___307); + do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(doublereal)); + do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(doublereal)); + do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer)); + e_wsfe(); + return 0; } /* dprcn4_ */ -/* Subroutine */ int dchk5_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublereal* alf, integer* nbet, doublereal* bet, integer* nmax, doublereal* ab, doublereal* aa, doublereal* as, doublereal* bb, doublereal* bs, doublereal* c__, doublereal* cc, doublereal* cs, doublereal* ct, doublereal* g, doublereal* w, integer* iorder, 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 */ - static char icht[3+1] = "NTC"; - static char ichu[2+1] = "UL"; + static char icht[3] = "NTC"; + static char ichu[2] = "UL"; + + /* Format strings */ + static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT " + "TAKEN ON VALID CALL *******\002)"; + static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER" + " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)"; + static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO" + "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR " + " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN" + " \002,i3)"; + static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM" + "BER:\002)"; /* System generated locals */ integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8; - + alist al__1; /* Local variables */ - static integer jjab; - static doublereal beta; - static integer ldas, ldbs, ldcs; - static logical same; - static doublereal bets; - static logical tran, null; - static char uplo[1]; - static integer i__, j, k, n; - extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*, ftnlen, ftnlen, ftnlen); - static doublereal alpha; - extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); - static logical isame[13]; - static integer nargs; - static logical reset; - static char trans[1]; - static logical upper; - static char uplos[1]; - extern /* Subroutine */ void dprcn5_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublereal*, integer*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen); - static integer ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns; - extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen); - static doublereal errmax; - static char transs[1]; - static integer laa, lbb, lda, lcc, ldb, ldc; - extern logical lde_(doublereal*, doublereal*, integer*); - extern /* Subroutine */ void cdsyr2k_(integer*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen); - static doublereal als; - static integer ict, icu; - static doublereal err; + integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa, + lbb, lda, lcc, ldb, ldc; + extern logical lde_(doublereal *, doublereal *, integer *); + doublereal als; + integer ict, icu; + doublereal err; + integer jjab; + doublereal beta; + integer ldas, ldbs, ldcs; + logical same; + doublereal bets; + logical tran, null; + char uplo[1]; + extern /* Subroutine */ int dmake_(char *, char *, char *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + logical *, doublereal *); + doublereal alpha; + extern /* Subroutine */ int dmmch_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, doublereal *, + logical *, integer *, logical *); + logical isame[13]; + integer nargs; + logical reset; + char trans[1]; + logical upper; + char uplos[1]; + extern /* Subroutine */ int dprcn5_(integer *, integer *, char *, integer + *, char *, char *, integer *, integer *, doublereal *, integer *, + integer *, doublereal *, integer *); + extern logical lderes_(char *, char *, integer *, integer *, doublereal *, + doublereal *, integer *); + doublereal errmax; + char transs[1]; + extern /* Subroutine */ int cdsyr2k_(integer *, char *, char *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *); + + /* Fortran I/O blocks */ + static cilist io___347 = { 0, 0, 0, fmt_9993, 0 }; + static cilist io___350 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___357 = { 0, 0, 0, fmt_10000, 0 }; + static cilist io___358 = { 0, 0, 0, fmt_10001, 0 }; + static cilist io___359 = { 0, 0, 0, fmt_10002, 0 }; + static cilist io___360 = { 0, 0, 0, fmt_10003, 0 }; + static cilist io___361 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___362 = { 0, 0, 0, fmt_9996, 0 }; + + /* Tests DSYR2K. */ @@ -2435,17 +3102,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 +3112,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 +3121,6 @@ static logical c_false = FALSE_; --ab; /* Function Body */ -/* .. Executable Statements .. */ nargs = 12; nc = 0; @@ -2518,12 +3173,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 +3186,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 +3207,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,22 +3244,24 @@ 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) { -/* al__1.aerr = 0; + al__1.aerr = 0; al__1.aunit = *ntra; - f_rew(&al__1);*/ + f_rew(&al__1); } cdsyr2k_(iorder, uplo, trans, &n, &k, &alpha, &aa[ 1], &lda, &bb[1], &ldb, &beta, &cc[1], & - ldc, (ftnlen)1, (ftnlen)1); + ldc); /* Check if error-exit was taken incorrectly. */ if (! infoc_1.ok) { - printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + io___347.ciunit = *nout; + s_wsfe(&io___347); + e_wsfe(); *fatal = TRUE_; goto L150; } @@ -2632,7 +3284,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; @@ -2644,7 +3296,11 @@ static logical c_false = FALSE_; 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__); + io___350.ciunit = *nout; + s_wsfe(&io___350); + do_fio(&c__1, (char *)&i__, (ftnlen) + sizeof(integer)); + e_wsfe(); } /* L40: */ } @@ -2671,9 +3327,9 @@ static logical c_false = FALSE_; if (tran) { i__6 = k; for (i__ = 1; i__ <= i__6; ++i__) { - w[i__] = ab[((j - 1) << 1) * *nmax + w[i__] = ab[(j - 1 << 1) * *nmax + k + i__]; - w[k + i__] = ab[((j - 1) << 1) * * + w[k + i__] = ab[(j - 1 << 1) * * nmax + i__]; /* L50: */ } @@ -2685,8 +3341,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 +3358,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; @@ -2748,50 +3402,82 @@ static logical c_false = FALSE_; if (errmax < *thresh) { if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___357.ciunit = *nout; + s_wsfe(&io___357); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___358.ciunit = *nout; + s_wsfe(&io___358); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } } else { if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___359.ciunit = *nout; + s_wsfe(&io___359); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal)); + e_wsfe(); } if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___360.ciunit = *nout; + s_wsfe(&io___360); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal)); + e_wsfe(); } } goto L160; L140: if (n > 1) { - printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j); + io___361.ciunit = *nout; + s_wsfe(&io___361); + do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer)); + e_wsfe(); } L150: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + io___362.ciunit = *nout; + s_wsfe(&io___362); + do_fio(&c__1, sname, (ftnlen)13); + e_wsfe(); dprcn5_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &ldb, - &beta, &ldc, (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 */ int dprcn5_(integer *nout, integer *nc, char *sname, integer + *iorder, char *uplo, char *transa, integer *n, integer *k, doublereal + *alpha, integer *lda, integer *ldb, doublereal *beta, integer *ldc) { + /* Format strings */ + static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002," + "\002))"; + static char fmt_9994[] = "(20x,2(i3,\002,\002),f4.1,\002, A,\002,i3,\002" + ", B\002,i3,\002,\002,f4.1,\002, C,\002,i3,\002).\002)"; /* Local variables */ - static char ca[14], cu[14], crc[14]; + char ca[14], cu[14], crc[14]; + + /* Fortran I/O blocks */ + static cilist io___366 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___367 = { 0, 0, 0, fmt_9994, 0 }; + if (*(unsigned char *)uplo == 'U') { s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); @@ -2810,22 +3496,41 @@ static logical c_false = FALSE_; } else { s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); - printf("%d %d %4.1f , A, %d, B, %d, %4.1f , C, %d.\n",*n,*k,*alpha,*lda,*ldb,*beta,*ldc); + io___366.ciunit = *nout; + s_wsfe(&io___366); + do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer)); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, crc, (ftnlen)14); + do_fio(&c__1, cu, (ftnlen)14); + do_fio(&c__1, ca, (ftnlen)14); + e_wsfe(); + io___367.ciunit = *nout; + s_wsfe(&io___367); + do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(doublereal)); + do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(doublereal)); + do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer)); + e_wsfe(); + return 0; } /* dprcn5_ */ -/* Subroutine */ int dmake_(char* type__, char* uplo, char* diag, integer* m, integer* n, doublereal* a, integer* nmax, doublereal* aa, integer* lda, logical* reset, doublereal* transl, 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; /* Local variables */ - extern doublereal dbeg_(logical*); - static integer ibeg, iend; - static logical unit; - static integer i__, j; - static logical lower, upper, gen, tri, sym; + integer i__, j; + logical gen, tri, sym; + extern doublereal dbeg_(logical *); + integer ibeg, iend; + logical unit, lower, upper; /* Generates values for an M by N matrix A. */ @@ -2842,15 +3547,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; @@ -2868,7 +3567,7 @@ static logical c_false = FALSE_; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { - if (gen || (upper && i__ <= j) || (lower && i__ >= j)) { + if (gen || upper && i__ <= j || lower && i__ >= j) { a[i__ + j * a_dim1] = dbeg_(reset) + *transl; if (i__ != j) { /* Set some elements to zero */ @@ -2953,20 +3652,38 @@ 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) { + /* Format strings */ + static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS" + " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 EX" + "PECTED RESULT COMPU\002,\002TED RESULT\002)"; + static char fmt_9998[] = "(1x,i7,2g18.6)"; + static char fmt_9997[] = "(\002 THESE ARE THE RESULTS FOR COLUMN" + " \002,i3)"; + /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, cc_dim1, cc_offset, i__1, i__2, i__3; doublereal d__1, d__2; - /* Builtin functions */ - double sqrt(double); - /* Local variables */ - static doublereal erri; - static integer i__, j, k; - static logical trana, tranb; + integer i__, j, k; + doublereal erri; + logical trana, tranb; + + /* Fortran I/O blocks */ + static cilist io___384 = { 0, 0, 0, fmt_9999, 0 }; + static cilist io___385 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___386 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___387 = { 0, 0, 0, fmt_9997, 0 }; + + /* Checks the results of the computational tests. */ @@ -2978,26 +3695,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 */ @@ -3102,19 +3813,35 @@ static logical c_false = FALSE_; L130: *fatal = TRUE_; - printf(" ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HALF ACCURATE *******\n"); - printf(" EXPECTED RESULT COMPUTED RESULT\n"); + io___384.ciunit = *nout; + s_wsfe(&io___384); + e_wsfe(); i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { if (*mv) { - printf("%7d %15.6g %15.6g\n",i__,ct[i__],cc[i__+j*cc_dim1]); + io___385.ciunit = *nout; + s_wsfe(&io___385); + do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&ct[i__], (ftnlen)sizeof(doublereal)); + do_fio(&c__1, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof( + doublereal)); + e_wsfe(); } else { - printf("%7d %15.6g %15.6g\n",i__,cc[i__+j*cc_dim1],ct[i__]); + io___386.ciunit = *nout; + s_wsfe(&io___386); + do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof( + doublereal)); + do_fio(&c__1, (char *)&ct[i__], (ftnlen)sizeof(doublereal)); + e_wsfe(); } /* L140: */ } if (*n > 1) { - printf(" THESE ARE THE RESULTS FOR COLUMN %d\n",j); + io___387.ciunit = *nout; + s_wsfe(&io___387); + do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer)); + e_wsfe(); } L150: @@ -3125,14 +3852,14 @@ static logical c_false = FALSE_; } /* dmmch_ */ -logical lde_(doublereal* ri, doublereal* rj, integer* lr) +logical lde_(doublereal *ri, doublereal *rj, integer *lr) { /* System generated locals */ integer i__1; logical ret_val; /* Local variables */ - static integer i__; + integer i__; /* Tests if two arrays are identical. */ @@ -3145,10 +3872,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,15 +3895,16 @@ 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; logical ret_val; /* Local variables */ - static integer ibeg, iend, i__, j; - static logical upper; + integer i__, j, ibeg, iend; + logical upper; /* Tests if selected elements in two arrays are equal. */ @@ -3195,16 +3919,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 +3969,7 @@ logical lderes_(char* type__, char* uplo, integer* m, integer* n, doublereal* aa } } -/* 60 CONTINUE */ +/* L60: */ ret_val = TRUE_; goto L80; L70: @@ -3261,7 +3981,7 @@ logical lderes_(char* type__, char* uplo, integer* m, integer* n, doublereal* aa } /* lderes_ */ -doublereal dbeg_(logical* reset) +doublereal dbeg_(logical *reset) { /* System generated locals */ doublereal ret_val; @@ -3280,10 +4000,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; @@ -3313,7 +4029,7 @@ doublereal dbeg_(logical* reset) } /* dbeg_ */ -doublereal ddiff_(doublereal* x, doublereal* y) +doublereal ddiff_(doublereal *x, doublereal *y) { /* System generated locals */ doublereal ret_val; @@ -3327,8 +4043,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 +4050,690 @@ 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"; + + /* Format strings */ + static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT " + "TAKEN ON VALID CALL *******\002)"; + static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER" + " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)"; + static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO" + "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR " + " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM" + "BER:\002)"; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5; + alist al__1; + + /* Local variables */ + extern /* Subroutine */ int cdgemmtr_(integer *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *); + integer i__, k, n, ia, ib, ma, mb, na, nb, nc, ik, in, is, ks, ns, ica, + icb, laa, lbb, lda, lcc, ldb, ldc; + extern logical lde_(doublereal *, doublereal *, integer *); + doublereal als, bls, err, beta; + integer ldas, ldbs, ldcs; + logical same, null; + char uplo[1]; + extern /* Subroutine */ int dmake_(char *, char *, char *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + logical *, doublereal *); + doublereal alpha; + logical isame[13], trana, tranb; + integer nargs; + logical reset; + char uplos[1]; + extern /* Subroutine */ int dprcn8_(integer *, integer *, char *, integer + *, char *, char *, char *, integer *, integer *, doublereal *, + integer *, integer *, doublereal *, integer *), dmmtch_(char *, char *, char *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, doublereal *, + logical *, integer *, logical *); + extern logical lderes_(char *, char *, integer *, integer *, doublereal *, + doublereal *, integer *); + char tranas[1], tranbs[1], transa[1], transb[1]; + doublereal errmax; + + /* Fortran I/O blocks */ + static cilist io___441 = { 0, 0, 0, fmt_9994, 0 }; + static cilist io___444 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___446 = { 0, 0, 0, fmt_10000, 0 }; + static cilist io___447 = { 0, 0, 0, fmt_10001, 0 }; + static cilist io___448 = { 0, 0, 0, fmt_10002, 0 }; + static cilist io___449 = { 0, 0, 0, fmt_10003, 0 }; + static cilist io___450 = { 0, 0, 0, fmt_9996, 0 }; + + + +/* Tests DGEMMTR. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 19-July-2023. */ +/* Martin Koehler, MPI Magdeburg */ + + /* Parameter adjustments */ + --idim; + --alf; + --bet; + --g; + --ct; + --cs; + --cc; + c_dim1 = *nmax; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --bs; + --bb; + b_dim1 = *nmax; + b_offset = 1 + b_dim1; + b -= b_offset; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + + nargs = 13; + nc = 0; + reset = TRUE_; + errmax = 0.; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; +/* Set LDC to 1 more than minimum value if room. */ + ldc = n; + if (ldc < *nmax) { + ++ldc; + } +/* Skip tests if not enough room. */ + if (ldc > *nmax) { + goto L100; + } + lcc = ldc * n; + null = n <= 0; + + i__2 = *nidim; + for (ik = 1; ik <= i__2; ++ik) { + k = idim[ik]; + + for (ica = 1; ica <= 3; ++ica) { + *(unsigned char *)transa = *(unsigned char *)&ich[ica - 1]; + trana = *(unsigned char *)transa == 'T' || *(unsigned char *) + transa == 'C'; + + if (trana) { + ma = k; + na = n; + } else { + ma = n; + na = k; + } +/* Set LDA to 1 more than minimum value if room. */ + lda = ma; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L80; + } + laa = lda * na; + +/* Generate the matrix A. */ + + dmake_("GE", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[1], & + lda, &reset, &c_b104) + ; + + for (icb = 1; icb <= 3; ++icb) { + *(unsigned char *)transb = *(unsigned char *)&ich[icb - 1] + ; + tranb = *(unsigned char *)transb == 'T' || *(unsigned + char *)transb == 'C'; + + if (tranb) { + mb = n; + nb = k; + } else { + mb = k; + nb = n; + } +/* Set LDB to 1 more than minimum value if room. */ + ldb = mb; + if (ldb < *nmax) { + ++ldb; + } +/* Skip tests if not enough room. */ + if (ldb > *nmax) { + goto L70; + } + lbb = ldb * nb; + +/* Generate the matrix B. */ + + dmake_("GE", " ", " ", &mb, &nb, &b[b_offset], nmax, &bb[ + 1], &ldb, &reset, &c_b104); + + i__3 = *nalf; + for (ia = 1; ia <= i__3; ++ia) { + alpha = alf[ia]; + + i__4 = *nbet; + for (ib = 1; ib <= i__4; ++ib) { + beta = bet[ib]; + for (is = 1; is <= 2; ++is) { + *(unsigned char *)uplo = *(unsigned char *)& + ishape[is - 1]; + +/* Generate the matrix C. */ + + dmake_("GE", uplo, " ", &n, &n, &c__[c_offset] + , nmax, &cc[1], &ldc, &reset, &c_b104); + + ++nc; + +/* Save every datum before calling the */ +/* subroutine. */ + + *(unsigned char *)uplos = *(unsigned char *) + uplo; + *(unsigned char *)tranas = *(unsigned char *) + transa; + *(unsigned char *)tranbs = *(unsigned char *) + transb; + ns = n; + ks = k; + als = alpha; + i__5 = laa; + for (i__ = 1; i__ <= i__5; ++i__) { + as[i__] = aa[i__]; +/* L10: */ + } + ldas = lda; + i__5 = lbb; + for (i__ = 1; i__ <= i__5; ++i__) { + bs[i__] = bb[i__]; +/* L20: */ + } + ldbs = ldb; + bls = beta; + i__5 = lcc; + for (i__ = 1; i__ <= i__5; ++i__) { + cs[i__] = cc[i__]; +/* L30: */ + } + ldcs = ldc; + +/* Call the subroutine. */ + + if (*trace) { + dprcn8_(ntra, &nc, sname, iorder, uplo, + transa, transb, &n, &k, &alpha, & + lda, &ldb, &beta, &ldc); + } + if (*rewi) { + al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1); + } + cdgemmtr_(iorder, uplo, transa, transb, &n, & + k, &alpha, &aa[1], &lda, &bb[1], &ldb, + &beta, &cc[1], &ldc); + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_2.ok) { + io___441.ciunit = *nout; + s_wsfe(&io___441); + e_wsfe(); + *fatal = TRUE_; + goto L120; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)uplo == *( + unsigned char *)uplos; + isame[1] = *(unsigned char *)transa == *( + unsigned char *)tranas; + isame[2] = *(unsigned char *)transb == *( + unsigned char *)tranbs; + isame[3] = ns == n; + isame[4] = ks == k; + isame[5] = als == alpha; + isame[6] = lde_(&as[1], &aa[1], &laa); + isame[7] = ldas == lda; + isame[8] = lde_(&bs[1], &bb[1], &lbb); + isame[9] = ldbs == ldb; + isame[10] = bls == beta; + if (null) { + isame[11] = lde_(&cs[1], &cc[1], &lcc); + } else { + isame[11] = lderes_("GE", " ", &n, &n, & + cs[1], &cc[1], &ldc); + } + isame[12] = ldcs == ldc; + +/* If data was incorrectly changed, report */ +/* and return. */ + + same = TRUE_; + i__5 = nargs; + for (i__ = 1; i__ <= i__5; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + io___444.ciunit = *nout; + s_wsfe(&io___444); + do_fio(&c__1, (char *)&i__, (ftnlen) + sizeof(integer)); + e_wsfe(); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L120; + } + + if (! null) { + +/* Check the result. */ + + dmmtch_(uplo, transa, transb, &n, &k, & + alpha, &a[a_offset], nmax, &b[ + b_offset], nmax, &beta, &c__[ + c_offset], nmax, &ct[1], &g[1], & + cc[1], &ldc, eps, &err, fatal, + nout, &c_true); + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L120; + } + } + +/* L45: */ + } + +/* L50: */ + } + +/* L60: */ + } + +L70: + ; + } + +L80: + ; + } + +/* L90: */ + } + +L100: + ; + } + + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + io___446.ciunit = *nout; + s_wsfe(&io___446); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); + } + if (*iorder == 1) { + io___447.ciunit = *nout; + s_wsfe(&io___447); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); + } + } else { + if (*iorder == 0) { + io___448.ciunit = *nout; + s_wsfe(&io___448); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal)); + e_wsfe(); + } + if (*iorder == 1) { + io___449.ciunit = *nout; + s_wsfe(&io___449); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal)); + e_wsfe(); + } + } + goto L130; + +L120: + io___450.ciunit = *nout; + s_wsfe(&io___450); + do_fio(&c__1, sname, (ftnlen)13); + e_wsfe(); + dprcn8_(nout, &nc, sname, iorder, uplo, transa, transb, &n, &k, &alpha, & + lda, &ldb, &beta, &ldc); + +L130: + return 0; + +/* L9997: */ +/* L9995: */ + +/* End of DCHK6 */ + +} /* dchk6_ */ + +/* Subroutine */ int dprcn8_(integer *nout, integer *nc, char *sname, integer + *iorder, char *uplo, char *transa, char *transb, integer *n, integer * + k, doublereal *alpha, integer *lda, integer *ldb, doublereal *beta, + integer *ldc) +{ + /* Format strings */ + static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002," + "a14,\002,\002,a14,\002,\002,a14,\002,\002)"; + static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 \002,f4.1,\002 , A" + ",\002,i3,\002, B,\002,i3,\002, \002,f4.1,\002 , C,\002,i3,\002)" + ".\002)"; + + /* Local variables */ + char crc[14], cta[14], ctb[14], cuplo[14]; + + /* Fortran I/O blocks */ + static cilist io___455 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___456 = { 0, 0, 0, fmt_9994, 0 }; + + + if (*(unsigned char *)uplo == 'U') { + s_copy(cuplo, "CblasUpper", (ftnlen)14, (ftnlen)10); + } else { + s_copy(cuplo, "CblasLower", (ftnlen)14, (ftnlen)10); + } + if (*(unsigned char *)transa == 'N') { + s_copy(cta, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transa == 'T') { + s_copy(cta, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cta, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)transb == 'N') { + s_copy(ctb, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transb == 'T') { + s_copy(ctb, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(ctb, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*iorder == 1) { + s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); + } else { + s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); + } + io___455.ciunit = *nout; + s_wsfe(&io___455); + do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer)); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, crc, (ftnlen)14); + do_fio(&c__1, cuplo, (ftnlen)14); + do_fio(&c__1, cta, (ftnlen)14); + do_fio(&c__1, ctb, (ftnlen)14); + e_wsfe(); + io___456.ciunit = *nout; + s_wsfe(&io___456); + do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(doublereal)); + do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(doublereal)); + do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer)); + e_wsfe(); + return 0; +} /* dprcn8_ */ + +/* Subroutine */ int dmmtch_(char *uplo, char *transa, char *transb, integer * + n, integer *kk, doublereal *alpha, doublereal *a, integer *lda, + doublereal *b, integer *ldb, doublereal *beta, doublereal *c__, + integer *ldc, doublereal *ct, doublereal *g, doublereal *cc, integer * + ldcc, doublereal *eps, doublereal *err, logical *fatal, integer *nout, + logical *mv) +{ + /* Format strings */ + static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS" + " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 EX" + "PECTED RESULT COMPU\002,\002TED RESULT\002)"; + static char fmt_9998[] = "(1x,i7,2g18.6)"; + static char fmt_9997[] = "(\002 THESE ARE THE RESULTS FOR COLUMN" + " \002,i3)"; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, cc_dim1, + cc_offset, i__1, i__2, i__3; + doublereal d__1, d__2; + + /* Local variables */ + integer i__, j, k; + doublereal erri; + logical trana, tranb, upper; + integer istop, istart; + + /* Fortran I/O blocks */ + static cilist io___466 = { 0, 0, 0, fmt_9999, 0 }; + static cilist io___467 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___468 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___469 = { 0, 0, 0, fmt_9997, 0 }; + + + +/* Checks the results of the computational tests. */ + +/* Auxiliary routine for test program for Level 3 Blas. (DGEMMTR) */ + +/* -- Written on 19-July-2023. */ +/* Martin Koehler, MPI Magdeburg */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --ct; + --g; + cc_dim1 = *ldcc; + cc_offset = 1 + cc_dim1; + cc -= cc_offset; + + /* Function Body */ + upper = *(unsigned char *)uplo == 'U'; + trana = *(unsigned char *)transa == 'T' || *(unsigned char *)transa == + 'C'; + tranb = *(unsigned char *)transb == 'T' || *(unsigned char *)transb == + 'C'; + +/* Compute expected result, one column at a time, in CT using data */ +/* in A, B and C. */ +/* Compute gauges in G. */ + + istart = 1; + istop = *n; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + + if (upper) { + istart = 1; + istop = j; + } else { + istart = j; + istop = *n; + } + i__2 = istop; + for (i__ = istart; i__ <= i__2; ++i__) { + ct[i__] = 0.; + g[i__] = 0.; +/* L10: */ + } + if (! trana && ! tranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = istop; + for (i__ = istart; i__ <= i__3; ++i__) { + ct[i__] += a[i__ + k * a_dim1] * b[k + j * b_dim1]; + g[i__] += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (d__2 + = b[k + j * b_dim1], abs(d__2)); +/* L20: */ + } +/* L30: */ + } + } else if (trana && ! tranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = istop; + for (i__ = istart; i__ <= i__3; ++i__) { + ct[i__] += a[k + i__ * a_dim1] * b[k + j * b_dim1]; + g[i__] += (d__1 = a[k + i__ * a_dim1], abs(d__1)) * (d__2 + = b[k + j * b_dim1], abs(d__2)); +/* L40: */ + } +/* L50: */ + } + } else if (! trana && tranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = istop; + for (i__ = istart; i__ <= i__3; ++i__) { + ct[i__] += a[i__ + k * a_dim1] * b[j + k * b_dim1]; + g[i__] += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (d__2 + = b[j + k * b_dim1], abs(d__2)); +/* L60: */ + } +/* L70: */ + } + } else if (trana && tranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = istop; + for (i__ = istart; i__ <= i__3; ++i__) { + ct[i__] += a[k + i__ * a_dim1] * b[j + k * b_dim1]; + g[i__] += (d__1 = a[k + i__ * a_dim1], abs(d__1)) * (d__2 + = b[j + k * b_dim1], abs(d__2)); +/* L80: */ + } +/* L90: */ + } + } + i__2 = istop; + for (i__ = istart; i__ <= i__2; ++i__) { + ct[i__] = *alpha * ct[i__] + *beta * c__[i__ + j * c_dim1]; + g[i__] = abs(*alpha) * g[i__] + abs(*beta) * (d__1 = c__[i__ + j * + c_dim1], abs(d__1)); +/* L100: */ + } + +/* Compute the error ratio for this result. */ + + *err = 0.; + i__2 = istop; + for (i__ = istart; i__ <= i__2; ++i__) { + erri = (d__1 = ct[i__] - cc[i__ + j * cc_dim1], abs(d__1)) / *eps; + if (g[i__] != 0.) { + erri /= g[i__]; + } + *err = f2cmax(*err,erri); + if (*err * sqrt(*eps) >= 1.) { + goto L130; + } +/* L110: */ + } + +/* L120: */ + } + +/* If the loop completes, all results are at least half accurate. */ + goto L150; + +/* Report fatal error. */ + +L130: + *fatal = TRUE_; + io___466.ciunit = *nout; + s_wsfe(&io___466); + e_wsfe(); + i__1 = istop; + for (i__ = istart; i__ <= i__1; ++i__) { + if (*mv) { + io___467.ciunit = *nout; + s_wsfe(&io___467); + do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&ct[i__], (ftnlen)sizeof(doublereal)); + do_fio(&c__1, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof( + doublereal)); + e_wsfe(); + } else { + io___468.ciunit = *nout; + s_wsfe(&io___468); + do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof( + doublereal)); + do_fio(&c__1, (char *)&ct[i__], (ftnlen)sizeof(doublereal)); + e_wsfe(); + } +/* L140: */ + } + if (*n > 1) { + io___469.ciunit = *nout; + s_wsfe(&io___469); + do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer)); + e_wsfe(); + } + +L150: + return 0; + + +/* End of DMMTCH */ + +} /* dmmtch_ */ + +/* Main program alias */ int dblat3_ () { MAIN__ (); return 0; } diff --git a/ctest/c_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..83b253585f 100644 --- a/ctest/c_sblat3c.c +++ b/ctest/c_sblat3c.c @@ -236,97 +236,315 @@ 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 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} /* Common Block Declarations */ -struct { - integer infot, noutc; - logical ok; +union { + struct { + integer infot, noutc; + logical ok; + } _1; + struct { + integer infot, noutc; + logical ok, lerr; + } _2; } infoc_; -#define infoc_1 infoc_ +#define infoc_1 (infoc_._1) +#define infoc_2 (infoc_._2) struct { - char srnamt[12]; + char srnamt[13]; } srnamc_; #define srnamc_1 srnamc_ /* Table of constant values */ +static integer c__9 = 9; static integer c__1 = 1; +static integer c__3 = 3; +static integer c__8 = 8; +static integer c__4 = 4; static integer c__65 = 65; -static real c_b89 = (float)1.; -static real c_b103 = (float)0.; +static integer c__7 = 7; +static real c_b89 = 1.f; +static real c_b103 = 0.f; static integer c__6 = 6; static logical c_true = TRUE_; static integer c__0 = 0; static logical c_false = FALSE_; -/* Main program 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[13*7] = "cblas_sgemm " "cblas_ssymm " "cblas_strmm " + "cblas_strsm " "cblas_ssyrk " "cblas_ssyr2k " "cblas_sgemmtr"; + + /* Format strings */ + static char fmt_9997[] = "(\002 NUMBER OF VALUES OF \002,a,\002 IS LESS " + "THAN 1 OR GREATER \002,\002THAN \002,i2)"; + static char fmt_9996[] = "(\002 VALUE OF N IS LESS THAN 0 OR GREATER THA" + "N \002,i2)"; + static char fmt_9995[] = "(\002 TESTS OF THE REAL LEVEL 3 BL" + "AS\002,//\002 THE F\002,\002OLLOWING PARAMETER VALUES WILL BE US" + "ED:\002)"; + static char fmt_9994[] = "(\002 FOR N \002,9i6)"; + static char fmt_9993[] = "(\002 FOR ALPHA \002,7f6.1)"; + static char fmt_9992[] = "(\002 FOR BETA \002,7f6.1)"; + static char fmt_9984[] = "(\002 ERROR-CALL MYEXITS WILL NOT BE TESTED" + "\002)"; + static char fmt_9999[] = "(\002 ROUTINES PASS COMPUTATIONAL TESTS IF TES" + "T RATIO IS LES\002,\002S THAN\002,f8.2)"; + static char fmt_10002[] = "(\002 COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS" + " ARE TESTED\002)"; + static char fmt_10001[] = "(\002 ROW-MAJOR DATA LAYOUT IS TESTED\002)"; + static char fmt_10000[] = "(\002 COLUMN-MAJOR DATA LAYOUT IS TESTED\002)"; + static char fmt_9988[] = "(a13,l2)"; + static char fmt_9990[] = "(\002 SUBPROGRAM NAME \002,a13,\002 NOT RECOGN" + "IZED\002,/\002 ******* \002,\002TESTS ABANDONED *******\002)"; + static char fmt_9998[] = "(\002 RELATIVE MACHINE PRECISION IS TAKEN TO" + " BE\002,1p,e9.1)"; + static char fmt_9989[] = "(\002 ERROR IN SMMCH - IN-LINE DOT PRODUCTS A" + "RE BEING EVALU\002,\002ATED WRONGLY.\002,/\002 SMMCH WAS CALLED " + "WITH TRANSA = \002,a1,\002 AND TRANSB = \002,a1,/\002 AND RETURN" + "ED SAME = \002,l1,\002 AND \002,\002ERR = \002,f12.3,\002.\002," + "/\002 THIS MAY BE DUE TO FAULTS IN THE \002,\002ARITHMETIC OR TH" + "E COMPILER.\002,/\002 ******* TESTS ABANDONED \002,\002******" + "*\002)"; + static char fmt_9987[] = "(1x,a13,\002 WAS NOT TESTED\002)"; + static char fmt_9986[] = "(/\002 END OF TESTS\002)"; + static char fmt_9985[] = "(/\002 ******* FATAL ERROR - TESTS ABANDONED *" + "******\002)"; + static char fmt_9991[] = "(\002 AMEND DATA FILE OR INCREASE ARRAY SIZES " + "IN PROGRAM\002,/\002 ******* TESTS ABANDONED *******\002)"; /* System generated locals */ integer i__1, i__2, i__3; real r__1; + olist o__1; + cllist cl__1; /* Local variables */ - static integer nalf, idim[9]; - static logical same; - static integer nbet, ntra; - static logical rewi; - extern /* Subroutine */ int schk1_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, real*, integer*, real*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*, ftnlen); - extern /* Subroutine */ int schk2_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, real*, integer*, real*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*, ftnlen); - extern /* Subroutine */ int schk3_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, real*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*, ftnlen); - extern /* Subroutine */ int schk4_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, real*, integer*, real*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*, ftnlen); - extern /* Subroutine */ int schk5_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, real*, integer*, real*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*, ftnlen); - static real c__[4225] /* was [65][65] */, g[65]; - static integer i__, j, n; - static logical fatal; - static real w[130]; - extern doublereal sdiff_(real*, real*); - static logical trace; - static integer nidim; - extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*, ftnlen, ftnlen); - static char snaps[32]; - static integer isnum; - static logical ltest[6]; - static real aa[4225], ab[8450] /* was [65][130] */, bb[4225], cc[ - 4225], as[4225], bs[4225], cs[4225], ct[65]; - static logical sfatal, corder; - static char snamet[12], transa[1], transb[1]; - static real thresh; - static logical rorder; - static integer layout; - static logical ltestt, tsterr; - extern /* Subroutine */ void cs3chke_(char*, ftnlen); - static real alf[7], bet[7]; - extern logical lse_(real*, real*, integer*); - static real eps, err; - char tmpchar; + real c__[4225] /* was [65][65] */, g[65]; + integer i__, j, n; + real w[130], aa[4225], ab[8450] /* was [65][130] */, bb[4225], cc[ + 4225], as[4225], bs[4225], cs[4225], ct[65], alf[7], bet[7]; + extern logical lse_(real *, real *, integer *); + real eps, err; + integer nalf, idim[9]; + logical same; + integer nbet, ntra; + logical rewi; + extern /* Subroutine */ int schk1_(char *, real *, real *, integer *, + integer *, logical *, logical *, logical *, integer *, integer *, + integer *, real *, integer *, real *, integer *, real *, real *, + real *, real *, real *, real *, real *, real *, real *, real *, + real *, integer *), schk2_(char *, real *, real *, + integer *, integer *, logical *, logical *, logical *, integer *, + integer *, integer *, real *, integer *, real *, integer *, real * + , real *, real *, real *, real *, real *, real *, real *, real *, + real *, real *, integer *), schk3_(char *, real *, real *, + integer *, integer *, logical *, logical *, logical *, integer *, + integer *, integer *, real *, integer *, real *, real *, real *, + real *, real *, real *, real *, real *, real *, integer *) + , schk4_(char *, real *, real *, integer *, integer *, logical *, + logical *, logical *, integer *, integer *, integer *, real *, + integer *, real *, integer *, real *, real *, real *, real *, + real *, real *, real *, real *, real *, real *, real *, integer *), schk5_(char *, real *, real *, integer *, integer *, + logical *, logical *, logical *, integer *, integer *, integer *, + real *, integer *, real *, integer *, real *, real *, real *, + real *, real *, real *, real *, real *, real *, real *, real *, + integer *), schk6_(char *, real *, real *, integer *, + integer *, logical *, logical *, logical *, integer *, integer *, + integer *, real *, integer *, real *, integer *, real *, real *, + real *, real *, real *, real *, real *, real *, real *, real *, + real *, integer *); + logical fatal; + extern real sdiff_(real *, real *); + logical trace; + integer nidim; + extern /* Subroutine */ int smmch_(char *, char *, integer *, integer *, + integer *, real *, real *, integer *, real *, integer *, real *, + real *, integer *, real *, real *, real *, integer *, real *, + real *, logical *, integer *, logical *); + char snaps[32]; + integer isnum; + logical ltest[7], sfatal, corder; + char snamet[13], transa[1], transb[1]; + real thresh; + logical rorder; + integer layout; + logical ltestt, tsterr; + extern /* Subroutine */ int cs3chke_(char *); + + /* Fortran I/O blocks */ + static cilist io___2 = { 0, 5, 0, 0, 0 }; + static cilist io___4 = { 0, 5, 0, 0, 0 }; + static cilist io___7 = { 0, 5, 0, 0, 0 }; + static cilist io___9 = { 0, 5, 0, 0, 0 }; + static cilist io___11 = { 0, 5, 0, 0, 0 }; + static cilist io___13 = { 0, 5, 0, 0, 0 }; + static cilist io___15 = { 0, 5, 0, 0, 0 }; + static cilist io___17 = { 0, 5, 0, 0, 0 }; + static cilist io___19 = { 0, 6, 0, fmt_9997, 0 }; + static cilist io___20 = { 0, 5, 0, 0, 0 }; + static cilist io___23 = { 0, 6, 0, fmt_9996, 0 }; + static cilist io___24 = { 0, 5, 0, 0, 0 }; + static cilist io___26 = { 0, 6, 0, fmt_9997, 0 }; + static cilist io___27 = { 0, 5, 0, 0, 0 }; + static cilist io___29 = { 0, 5, 0, 0, 0 }; + static cilist io___31 = { 0, 6, 0, fmt_9997, 0 }; + static cilist io___32 = { 0, 5, 0, 0, 0 }; + static cilist io___34 = { 0, 6, 0, fmt_9995, 0 }; + static cilist io___35 = { 0, 6, 0, fmt_9994, 0 }; + static cilist io___36 = { 0, 6, 0, fmt_9993, 0 }; + static cilist io___37 = { 0, 6, 0, fmt_9992, 0 }; + static cilist io___38 = { 0, 6, 0, 0, 0 }; + static cilist io___39 = { 0, 6, 0, fmt_9984, 0 }; + static cilist io___40 = { 0, 6, 0, 0, 0 }; + static cilist io___41 = { 0, 6, 0, fmt_9999, 0 }; + static cilist io___42 = { 0, 6, 0, 0, 0 }; + static cilist io___45 = { 0, 6, 0, fmt_10002, 0 }; + static cilist io___46 = { 0, 6, 0, fmt_10001, 0 }; + static cilist io___47 = { 0, 6, 0, fmt_10000, 0 }; + static cilist io___48 = { 0, 6, 0, 0, 0 }; + static cilist io___50 = { 0, 5, 1, fmt_9988, 0 }; + static cilist io___53 = { 0, 6, 0, fmt_9990, 0 }; + static cilist io___55 = { 0, 6, 0, fmt_9998, 0 }; + static cilist io___68 = { 0, 6, 0, fmt_9989, 0 }; + static cilist io___69 = { 0, 6, 0, fmt_9989, 0 }; + static cilist io___70 = { 0, 6, 0, fmt_9989, 0 }; + static cilist io___71 = { 0, 6, 0, fmt_9989, 0 }; + static cilist io___73 = { 0, 6, 0, 0, 0 }; + static cilist io___74 = { 0, 6, 0, fmt_9987, 0 }; + static cilist io___75 = { 0, 6, 0, 0, 0 }; + static cilist io___82 = { 0, 6, 0, fmt_9986, 0 }; + static cilist io___83 = { 0, 6, 0, fmt_9985, 0 }; + static cilist io___84 = { 0, 6, 0, fmt_9991, 0 }; + + /* Test program for the REAL Level 3 Blas. */ /* The program must be driven by a short data file. The first 13 records */ /* of the file are read using list-directed input, the last 6 records */ -/* are read using the format ( 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 +553,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,34 +576,21 @@ 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. */ - char line[80]; - - fgets(line,80,stdin); - sscanf(line,"'%s'",snaps); - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&ntra); -#else - sscanf(line,"%d",&ntra); -#endif + s_rsle(&io___2); + do_lio(&c__9, &c__1, snaps, (ftnlen)32); + e_rsle(); + s_rsle(&io___4); + do_lio(&c__3, &c__1, (char *)&ntra, (ftnlen)sizeof(integer)); + e_rsle(); trace = ntra >= 0; if (trace) { /* OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' ) */ -/* o__1.ounit = ntra; + o__1.oerr = 0; + o__1.ounit = ntra; o__1.ofnmlen = 32; o__1.ofnm = snaps; o__1.orl = 0; @@ -392,166 +598,208 @@ static logical c_false = FALSE_; o__1.oacc = 0; o__1.ofm = 0; o__1.oblnk = 0; - f_open(&o__1);*/ + f_open(&o__1); } /* Read the flag that directs rewinding of the snapshot file. */ - fgets(line,80,stdin); - sscanf(line,"%d",&rewi); - rewi = rewi && trace; + s_rsle(&io___7); + do_lio(&c__8, &c__1, (char *)&rewi, (ftnlen)sizeof(logical)); + e_rsle(); + rewi = rewi && trace; /* Read the flag that directs stopping on any failure. */ - fgets(line,80,stdin); - sscanf(line,"%c",&tmpchar); + s_rsle(&io___9); + do_lio(&c__8, &c__1, (char *)&sfatal, (ftnlen)sizeof(logical)); + e_rsle(); /* Read the flag that indicates whether error exits are to be tested. */ - sfatal=FALSE_; - if (tmpchar=='T')sfatal=TRUE_; - fgets(line,80,stdin); - sscanf(line,"%c",&tmpchar); -/* Read the flag that indicates whether error exits are to be tested. */ - tsterr=FALSE_; - if (tmpchar=='T')tsterr=TRUE_; + s_rsle(&io___11); + do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical)); + e_rsle(); /* Read the flag that indicates whether row-major data layout to be tested. */ - fgets(line,80,stdin); - sscanf(line,"%d",&layout); + s_rsle(&io___13); + do_lio(&c__3, &c__1, (char *)&layout, (ftnlen)sizeof(integer)); + e_rsle(); /* Read the threshold value of the test ratio */ - fgets(line,80,stdin); - sscanf(line,"%f",&thresh); + s_rsle(&io___15); + do_lio(&c__4, &c__1, (char *)&thresh, (ftnlen)sizeof(real)); + e_rsle(); /* Read and check the parameter values for the tests. */ /* Values of N */ - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&nidim); -#else - sscanf(line,"%d",&nidim); -#endif - + s_rsle(&io___17); + do_lio(&c__3, &c__1, (char *)&nidim, (ftnlen)sizeof(integer)); + e_rsle(); if (nidim < 1 || nidim > 9) { - fprintf(stderr,"NUMBER OF VALUES OF N IS LESS THAN 1 OR GREATER THAN 9"); - goto L220; + s_wsfe(&io___19); + do_fio(&c__1, "N", (ftnlen)1); + do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer)); + e_wsfe(); + goto L220; } - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld %ld %ld %ld %ld %ld %ld %ld %ld",&idim[0],&idim[1],&idim[2], - &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]); -#else - sscanf(line,"%d %d %d %d %d %d %d %d %d",&idim[0],&idim[1],&idim[2], - &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]); -#endif + s_rsle(&io___20); + i__1 = nidim; + for (i__ = 1; i__ <= i__1; ++i__) { + do_lio(&c__3, &c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer)); + } + e_rsle(); i__1 = nidim; for (i__ = 1; i__ <= i__1; ++i__) { - if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) { - fprintf(stderr,"VALUE OF N IS LESS THAN 0 OR GREATER THAN 65\n"); - goto L220; - } -/* L10: */ + if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) { + s_wsfe(&io___23); + do_fio(&c__1, (char *)&c__65, (ftnlen)sizeof(integer)); + e_wsfe(); + goto L220; + } +/* L10: */ } /* Values of ALPHA */ - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&nalf); -#else - sscanf(line,"%d",&nalf); -#endif + s_rsle(&io___24); + do_lio(&c__3, &c__1, (char *)&nalf, (ftnlen)sizeof(integer)); + e_rsle(); if (nalf < 1 || nalf > 7) { - fprintf(stderr,"VALUE OF ALPHA IS LESS THAN 0 OR GREATER THAN 7\n"); - goto L220; + s_wsfe(&io___26); + do_fio(&c__1, "ALPHA", (ftnlen)5); + do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer)); + e_wsfe(); + goto L220; } - fgets(line,80,stdin); - sscanf(line,"%f %f %f %f %f %f %f",&alf[0],&alf[1],&alf[2],&alf[3],&alf[4],&alf[5],&alf[6]); - + s_rsle(&io___27); + i__1 = nalf; + for (i__ = 1; i__ <= i__1; ++i__) { + do_lio(&c__4, &c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(real)); + } + e_rsle(); /* Values of BETA */ - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&nbet); -#else - sscanf(line,"%d",&nbet); -#endif - if (nalf < 1 || nbet > 7) { - fprintf(stderr,"VALUE OF BETA IS LESS THAN 0 OR GREATER THAN 7\n"); - goto L220; + s_rsle(&io___29); + do_lio(&c__3, &c__1, (char *)&nbet, (ftnlen)sizeof(integer)); + e_rsle(); + if (nbet < 1 || nbet > 7) { + s_wsfe(&io___31); + do_fio(&c__1, "BETA", (ftnlen)4); + do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer)); + e_wsfe(); + goto L220; + } + s_rsle(&io___32); + i__1 = nbet; + for (i__ = 1; i__ <= i__1; ++i__) { + do_lio(&c__4, &c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(real)); } - fgets(line,80,stdin); - sscanf(line,"%f %f %f %f %f %f %f",&bet[0],&bet[1],&bet[2],&bet[3],&bet[4],&bet[5],&bet[6]); + e_rsle(); /* Report values of parameters. */ - printf("TESTS OF THE REAL LEVEL 3 BLAS\nTHE FOLLOWING PARAMETER VALUES WILL BE USED:\n"); - printf(" FOR N"); - for (i__ =1; i__ <=nidim;++i__) printf(" %d",idim[i__-1]); - printf("\n"); - printf(" FOR ALPHA"); - for (i__ =1; i__ <=nalf;++i__) printf(" %f",alf[i__-1]); - printf("\n"); - printf(" FOR BETA"); - for (i__ =1; i__ <=nbet;++i__) printf(" %f",bet[i__-1]); - printf("\n"); + s_wsfe(&io___34); + e_wsfe(); + s_wsfe(&io___35); + i__1 = nidim; + for (i__ = 1; i__ <= i__1; ++i__) { + do_fio(&c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer)); + } + e_wsfe(); + s_wsfe(&io___36); + i__1 = nalf; + for (i__ = 1; i__ <= i__1; ++i__) { + do_fio(&c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(real)); + } + e_wsfe(); + s_wsfe(&io___37); + i__1 = nbet; + for (i__ = 1; i__ <= i__1; ++i__) { + do_fio(&c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(real)); + } + e_wsfe(); if (! tsterr) { - printf(" ERROR-EXITS WILL NOT BE TESTED\n"); + s_wsle(&io___38); + e_wsle(); + s_wsfe(&io___39); + e_wsfe(); } - printf("ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LESS THAN %f\n",thresh); + s_wsle(&io___40); + e_wsle(); + s_wsfe(&io___41); + do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(real)); + e_wsfe(); + s_wsle(&io___42); + e_wsle(); rorder = FALSE_; corder = FALSE_; if (layout == 2) { - rorder = TRUE_; - corder = TRUE_; - printf("COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED\n"); + rorder = TRUE_; + corder = TRUE_; + s_wsfe(&io___45); + e_wsfe(); } else if (layout == 1) { - rorder = TRUE_; - printf("ROW-MAJOR DATA LAYOUT IS TESTED\n"); + rorder = TRUE_; + s_wsfe(&io___46); + e_wsfe(); } else if (layout == 0) { - corder = TRUE_; - printf("COLUMN-MAJOR DATA LAYOUT IS TESTED\n"); + corder = TRUE_; + s_wsfe(&io___47); + e_wsfe(); } - + s_wsle(&io___48); + e_wsle(); /* Read names of subroutines and flags which indicate */ /* whether they are to be tested. */ - for (i__ = 1; i__ <= 6; ++i__) { + for (i__ = 1; i__ <= 7; ++i__) { ltest[i__ - 1] = FALSE_; /* L20: */ } L30: - if (! fgets(line,80,stdin)) { - goto L60; - } - i__1 = sscanf(line,"%12c %c",snamet,&tmpchar); - ltestt=FALSE_; - if (tmpchar=='T')ltestt=TRUE_; - if (i__1 < 2) { - goto L60; - } - for (i__ = 1; i__ <= 9; ++i__) { - if (s_cmp(snamet, snames[i__ - 1] , (ftnlen)12, (ftnlen)12) == - 0) { - goto L50; - } + i__1 = s_rsfe(&io___50); + if (i__1 != 0) { + goto L60; + } + i__1 = do_fio(&c__1, snamet, (ftnlen)13); + if (i__1 != 0) { + goto L60; + } + i__1 = do_fio(&c__1, (char *)<estt, (ftnlen)sizeof(logical)); + if (i__1 != 0) { + goto L60; + } + i__1 = e_rsfe(); + if (i__1 != 0) { + goto L60; + } + for (i__ = 1; i__ <= 7; ++i__) { + if (s_cmp(snamet, snames + (i__ - 1) * 13, (ftnlen)13, (ftnlen)13) == + 0) { + goto L50; + } /* L40: */ } - printf("SUBPROGRAM NAME %s NOT RECOGNIZED\n****** TESTS ABANDONED ******\n",snamet); - exit(1); - + s_wsfe(&io___53); + do_fio(&c__1, snamet, (ftnlen)13); + e_wsfe(); + s_stop("", (ftnlen)0); L50: ltest[i__ - 1] = ltestt; goto L30; L60: -// f_clos(&cl__1); + cl__1.cerr = 0; + cl__1.cunit = 5; + cl__1.csta = 0; + f_clos(&cl__1); /* Compute EPS (the machine precision). */ - eps = (float)1.; + eps = 1.f; L70: - r__1 = eps + (float)1.; - if (sdiff_(&r__1, &c_b89) == (float)0.) { + r__1 = eps + 1.f; + if (sdiff_(&r__1, &c_b89) == 0.f) { goto L80; } - eps *= (float).5; + eps *= .5f; goto L70; L80: eps += eps; - printf("RELATIVE MACHINE PRECISION IS TAKEN TO BE %9.1g\n",eps); + s_wsfe(&io___55); + do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real)); + e_wsfe(); /* Check the reliability of SMMCH using exact data. */ @@ -567,7 +815,7 @@ static logical c_false = FALSE_; } ab[j + 4224] = (real) j; ab[(j + 65) * 65 - 65] = (real) j; - c__[j - 1] = (float)0.; + c__[j - 1] = 0.f; /* L100: */ } i__1 = n; @@ -582,28 +830,30 @@ 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"); - printf("SMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); - printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); - printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); - printf("****** TESTS ABANDONED ******\n"); - exit(1); + if (! same || err != 0.f) { + s_wsfe(&io___68); + do_fio(&c__1, transa, (ftnlen)1); + do_fio(&c__1, transb, (ftnlen)1); + do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical)); + do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real)); + e_wsfe(); + s_stop("", (ftnlen)0); } *(unsigned char *)transb = 'T'; smmch_(transa, transb, &n, &c__1, &n, &c_b89, ab, &c__65, &ab[4225], & c__65, &c_b103, c__, &c__65, ct, g, cc, &c__65, &eps, &err, & - fatal, &c__6, &c_true, (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"); - printf("SMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); - printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); - printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); - printf("****** TESTS ABANDONED ******\n"); - exit(1); + if (! same || err != 0.f) { + s_wsfe(&io___69); + do_fio(&c__1, transa, (ftnlen)1); + do_fio(&c__1, transb, (ftnlen)1); + do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical)); + do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real)); + e_wsfe(); + s_stop("", (ftnlen)0); } i__1 = n; for (j = 1; j <= i__1; ++j) { @@ -621,128 +871,152 @@ 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"); - printf("SMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); - printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); - printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); - printf("****** TESTS ABANDONED ******\n"); - exit(1); + if (! same || err != 0.f) { + s_wsfe(&io___70); + do_fio(&c__1, transa, (ftnlen)1); + do_fio(&c__1, transb, (ftnlen)1); + do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical)); + do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real)); + e_wsfe(); + s_stop("", (ftnlen)0); } *(unsigned char *)transb = 'T'; smmch_(transa, transb, &n, &c__1, &n, &c_b89, ab, &c__65, &ab[4225], & c__65, &c_b103, c__, &c__65, ct, g, cc, &c__65, &eps, &err, & - fatal, &c__6, &c_true, (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"); - printf("SMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); - printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); - printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); - printf("****** TESTS ABANDONED ******\n"); - exit(1); + if (! same || err != 0.f) { + s_wsfe(&io___71); + do_fio(&c__1, transa, (ftnlen)1); + do_fio(&c__1, transb, (ftnlen)1); + do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical)); + do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real)); + e_wsfe(); + s_stop("", (ftnlen)0); } /* Test each subroutine in turn. */ - for (isnum = 1; isnum <= 6; ++isnum) { + for (isnum = 1; isnum <= 7; ++isnum) { + s_wsle(&io___73); + e_wsle(); if (! ltest[isnum - 1]) { /* Subprogram is not to be tested. */ - printf("%12s WAS NOT TESTED\n",snames[isnum-1]); + s_wsfe(&io___74); + do_fio(&c__1, snames + (isnum - 1) * 13, (ftnlen)13); + e_wsfe(); } else { - s_copy(srnamc_1.srnamt, snames[isnum - 1], (ftnlen)12, ( - ftnlen)12); + s_copy(srnamc_1.srnamt, snames + (isnum - 1) * 13, (ftnlen)13, ( + ftnlen)13); /* Test error exits. */ if (tsterr) { - cs3chke_(snames[isnum - 1], (ftnlen)12); + cs3chke_(snames + (isnum - 1) * 13); + s_wsle(&io___75); + e_wsle(); } /* Test computations. */ infoc_1.infot = 0; infoc_1.ok = TRUE_; fatal = FALSE_; - switch ((int)isnum) { + switch (isnum) { case 1: goto L140; case 2: goto L150; case 3: goto L160; case 4: goto L160; case 5: goto L170; case 6: goto L180; + case 7: goto L185; } /* Test SGEMM, 01. */ L140: if (corder) { - schk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + schk1_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__0, (ftnlen)12); + cc, cs, ct, g, &c__0); } if (rorder) { - schk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + schk1_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__1, (ftnlen)12); + cc, cs, ct, g, &c__1); } goto L190; /* Test SSYMM, 02. */ L150: if (corder) { - schk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + schk2_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__0, (ftnlen)12); + cc, cs, ct, g, &c__0); } if (rorder) { - schk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + schk2_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__1, (ftnlen)12); + cc, cs, ct, g, &c__1); } goto L190; /* Test STRMM, 03, STRSM, 04. */ L160: if (corder) { - schk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + schk3_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, & - c__0, (ftnlen)12); + c__0); } if (rorder) { - schk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + schk3_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, & - c__1, (ftnlen)12); + c__1); } goto L190; /* Test SSYRK, 05. */ L170: if (corder) { - schk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + schk4_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__0, (ftnlen)12); + cc, cs, ct, g, &c__0); } if (rorder) { - schk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + schk4_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__1, (ftnlen)12); + cc, cs, ct, g, &c__1); } goto L190; /* Test SSYR2K, 06. */ L180: if (corder) { - schk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + schk5_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, + ct, g, w, &c__0); + } + if (rorder) { + schk5_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, + ct, g, w, &c__1); + } + goto L190; +/* Test SGEMMTR, 07. */ +L185: + if (corder) { + schk6_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, - ct, g, w, &c__0, (ftnlen)12); + ct, g, w, &c__0); } if (rorder) { - schk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + schk6_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, - ct, g, w, &c__1, (ftnlen)12); + ct, g, w, &c__1); } goto L190; @@ -753,61 +1027,115 @@ static logical c_false = FALSE_; } /* L200: */ } - printf("\nEND OF TESTS\n"); + s_wsfe(&io___82); + e_wsfe(); goto L230; L210: - printf("\n****** FATAL ERROR - TESTS ABANDONED ******\n"); + s_wsfe(&io___83); + e_wsfe(); goto L230; L220: - printf("AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM\n"); - printf("****** TESTS ABANDONED ******\n"); + s_wsfe(&io___84); + e_wsfe(); L230: if (trace) { -// f_clos(&cl__1); + cl__1.cerr = 0; + cl__1.cunit = ntra; + cl__1.csta = 0; + f_clos(&cl__1); } -// f_clos(&cl__1); - exit(0); + cl__1.cerr = 0; + cl__1.cunit = 6; + cl__1.csta = 0; + f_clos(&cl__1); + s_stop("", (ftnlen)0); + /* End of SBLAT3. */ + return 0; } /* MAIN__ */ -/* Subroutine */ int schk1_(char* sname, real* eps, real* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, real* alf, integer* nbet, real* bet, integer* nmax, real* a, real* aa, real* as, real* b, real* bb, real* bs, real* c__, real* cc, real* cs, real* ct, real* g, integer* iorder, 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 */ - static char ich[3+1] = "NTC"; + static char ich[3] = "NTC"; + + /* Format strings */ + static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT " + "TAKEN ON VALID CALL *******\002)"; + static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER" + " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)"; + static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO" + "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR " + " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM" + "BER:\002)"; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, - i__3, i__4, i__5, i__6; - + i__3, i__4, i__5, i__6, i__7; + alist al__1; /* Local variables */ - static real beta; - static integer ldas, ldbs, ldcs; - static logical same, null; - static integer i__, k, m, n; - static real alpha; - static logical isame[13]; - static logical trana, tranb; - static integer nargs; - static logical reset; - extern /* Subroutine */ void sprcn1_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, integer*, real*, integer*, integer*, real*, integer*, ftnlen, ftnlen, ftnlen); - extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, logical*, real*, ftnlen, ftnlen, ftnlen); - extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*, ftnlen, ftnlen); - static integer ia, ib, ma, mb, na, nb, nc, ik, im, in, ks, ms, ns; - extern /* Subroutine */ void csgemm_(integer*, char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, ftnlen, ftnlen); - static char tranas[1], tranbs[1], transa[1], transb[1]; - static real errmax; - extern logical lseres_(char*, char*, integer*, integer*, real*, real*, integer*, ftnlen, ftnlen); - extern logical lse_(real*, real*, integer*); - static integer ica, icb, laa, lbb, lda, lcc, ldb, ldc; - static real als, bls; - static real err; + integer i__, k, m, n, ia, ib, ma, mb, na, nb, nc, ik, im, in, ks, ms, ns, + ica, icb, laa, lbb, lda, lcc, ldb, ldc; + real als, bls; + extern logical lse_(real *, real *, integer *); + real err, beta; + integer ldas, ldbs, ldcs; + logical same, null; + real alpha; + logical isame[13]; + extern /* Subroutine */ int smake_(char *, char *, char *, integer *, + integer *, real *, integer *, real *, integer *, logical *, real * + ); + logical trana, tranb; + extern /* Subroutine */ int smmch_(char *, char *, integer *, integer *, + integer *, real *, real *, integer *, real *, integer *, real *, + real *, integer *, real *, real *, real *, integer *, real *, + real *, logical *, integer *, logical *); + integer nargs; + logical reset; + extern /* Subroutine */ int sprcn1_(integer *, integer *, char *, integer + *, char *, char *, integer *, integer *, integer *, real *, + integer *, integer *, real *, integer *), + csgemm_(integer *, char *, char *, integer *, integer *, integer * + , real *, real *, integer *, real *, integer *, real *, real *, + integer *); + char tranas[1], tranbs[1], transa[1], transb[1]; + real errmax; + extern logical lseres_(char *, char *, integer *, integer *, real *, real + *, integer *); + + /* Fortran I/O blocks */ + static cilist io___128 = { 0, 0, 0, fmt_9994, 0 }; + static cilist io___131 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___133 = { 0, 0, 0, fmt_10000, 0 }; + static cilist io___134 = { 0, 0, 0, fmt_10001, 0 }; + static cilist io___135 = { 0, 0, 0, fmt_10002, 0 }; + static cilist io___136 = { 0, 0, 0, fmt_10003, 0 }; + static cilist io___137 = { 0, 0, 0, fmt_9996, 0 }; + + /* Tests SGEMM. */ @@ -819,17 +1147,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 +1156,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 +1226,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 +1255,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 +1268,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,21 +1308,23 @@ 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); + al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1); } csgemm_(iorder, transa, transb, &m, &n, &k, & alpha, &aa[1], &lda, &bb[1], &ldb, & - beta, &cc[1], &ldc, (ftnlen)1, ( - ftnlen)1); + 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"); + io___128.ciunit = *nout; + s_wsfe(&io___128); + e_wsfe(); *fatal = TRUE_; goto L120; } @@ -1033,8 +1348,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; @@ -1046,7 +1360,12 @@ static logical c_false = FALSE_; for (i__ = 1; i__ <= i__6; ++i__) { same = same && isame[i__ - 1]; if (! isame[i__ - 1]) { - printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + io___131.ciunit = *nout; + s_wsfe(&io___131); + i__7 = i__ + 1; + do_fio(&c__1, (char *)&i__7, (ftnlen) + sizeof(integer)); + e_wsfe(); } /* L40: */ } @@ -1063,9 +1382,8 @@ 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); - errmax = dmax(errmax,err); + eps, &err, fatal, nout, &c_true); + errmax = f2cmax(errmax,err); /* If got really bad answer, report and */ /* return. */ if (*fatal) { @@ -1101,34 +1419,51 @@ static logical c_false = FALSE_; if (errmax < *thresh) { if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___133.ciunit = *nout; + s_wsfe(&io___133); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___134.ciunit = *nout; + s_wsfe(&io___134); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } } else { if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___135.ciunit = *nout; + s_wsfe(&io___135); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real)); + e_wsfe(); } if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___136.ciunit = *nout; + s_wsfe(&io___136); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real)); + e_wsfe(); } } goto L130; L120: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + io___137.ciunit = *nout; + s_wsfe(&io___137); + do_fio(&c__1, sname, (ftnlen)13); + e_wsfe(); sprcn1_(nout, &nc, sname, iorder, transa, transb, &m, &n, &k, &alpha, & - lda, &ldb, &beta, &ldc, (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,11 +1472,23 @@ 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 */ int sprcn1_(integer *nout, integer *nc, char *sname, integer + *iorder, char *transa, char *transb, integer *m, integer *n, integer * + k, real *alpha, integer *lda, integer *ldb, real *beta, integer *ldc) { + /* Format strings */ + static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002," + "a14,\002,\002,a14,\002,\002)"; + static char fmt_9994[] = "(20x,3(i3,\002,\002),f4.1,\002, A,\002,i3,\002" + ", B,\002,i3,\002,\002,f4.1,\002, \002,\002C,\002,i3,\002).\002)"; /* Local variables */ - static char crc[14], cta[14], ctb[14]; + char crc[14], cta[14], ctb[14]; + + /* Fortran I/O blocks */ + static cilist io___141 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___142 = { 0, 0, 0, fmt_9994, 0 }; + if (*(unsigned char *)transa == 'N') { s_copy(cta, " CblasNoTrans", (ftnlen)14, (ftnlen)14); @@ -1162,50 +1509,111 @@ static logical c_false = FALSE_; } else { s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cta,ctb); - printf("%d %d %d %4.1f A, %d, B, %d, %4.1f, C, %d.\n",*m,*n,*k,*alpha,*lda,*ldb,*beta,*ldc); - + io___141.ciunit = *nout; + s_wsfe(&io___141); + do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer)); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, crc, (ftnlen)14); + do_fio(&c__1, cta, (ftnlen)14); + do_fio(&c__1, ctb, (ftnlen)14); + e_wsfe(); + io___142.ciunit = *nout; + s_wsfe(&io___142); + do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(real)); + do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(real)); + do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer)); + e_wsfe(); + return 0; } /* sprcn1_ */ -/* Subroutine */ int schk2_(char* sname, real* eps, real* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, real* alf, integer* nbet, real* bet, integer* nmax, real* a, real* aa, real* as, real* b, real* bb, real* bs, real* c__, real* cc, real* cs, real* ct, real* g, integer* iorder, 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 */ - static char ichs[2+1] = "LR"; - static char ichu[2+1] = "UL"; + static char ichs[2] = "LR"; + static char ichu[2] = "UL"; + + /* Format strings */ + static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT " + "TAKEN ON VALID CALL *******\002)"; + static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER" + " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)"; + static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO" + "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR " + " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM" + "BER:\002)"; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, - i__3, i__4, i__5; - + i__3, i__4, i__5, i__6; + alist al__1; /* Local variables */ - static real beta; - static integer ldas, ldbs, ldcs; - static logical same; - static char side[1]; - static logical left, null; - static char uplo[1]; - static integer i__, m, n; - static real alpha; - static logical isame[13]; - static char sides[1]; - static integer nargs; - static logical reset; - static char uplos[1]; - static integer ia, ib, na, nc, im, in, ms, ns; - static real errmax; - extern logical lseres_(char*, char*, integer*, integer*, real*, real*, integer*, ftnlen, ftnlen); - extern /* Subroutine */ void cssymm_(integer*, char*, char*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, ftnlen, ftnlen); - extern void sprcn2_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, real*, integer*, integer*, real*, integer*, ftnlen, ftnlen, ftnlen); - extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, logical*, real*, ftnlen, ftnlen, ftnlen); - extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*, ftnlen, ftnlen); - static integer laa, lbb, lda, lcc, ldb, ldc, ics; - static real als, bls; - static integer icu; - extern logical lse_(real*, real*, integer*); - static real err; + integer i__, m, n, ia, ib, na, nc, im, in, ms, ns, laa, lbb, lda, lcc, + ldb, ldc, ics; + real als, bls; + integer icu; + extern logical lse_(real *, real *, integer *); + real err, beta; + integer ldas, ldbs, ldcs; + logical same; + char side[1]; + logical left, null; + char uplo[1]; + real alpha; + logical isame[13]; + extern /* Subroutine */ int smake_(char *, char *, char *, integer *, + integer *, real *, integer *, real *, integer *, logical *, real * + ); + char sides[1]; + extern /* Subroutine */ int smmch_(char *, char *, integer *, integer *, + integer *, real *, real *, integer *, real *, integer *, real *, + real *, integer *, real *, real *, real *, integer *, real *, + real *, logical *, integer *, logical *); + integer nargs; + logical reset; + char uplos[1]; + extern /* Subroutine */ int sprcn2_(integer *, integer *, char *, integer + *, char *, char *, integer *, integer *, real *, integer *, + integer *, real *, integer *); + real errmax; + extern logical lseres_(char *, char *, integer *, integer *, real *, real + *, integer *); + extern /* Subroutine */ int cssymm_(integer *, char *, char *, integer *, + integer *, real *, real *, integer *, real *, integer *, real *, + real *, integer *); + + /* Fortran I/O blocks */ + static cilist io___180 = { 0, 0, 0, fmt_9994, 0 }; + static cilist io___183 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___185 = { 0, 0, 0, fmt_10000, 0 }; + static cilist io___186 = { 0, 0, 0, fmt_10001, 0 }; + static cilist io___187 = { 0, 0, 0, fmt_10002, 0 }; + static cilist io___188 = { 0, 0, 0, fmt_10003, 0 }; + static cilist io___189 = { 0, 0, 0, fmt_9996, 0 }; + + /* Tests SSYMM. */ @@ -1217,17 +1625,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 +1634,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 +1687,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 +1715,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 +1728,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,20 +1765,23 @@ 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); + al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1); } cssymm_(iorder, side, uplo, &m, &n, &alpha, &aa[1] - , &lda, &bb[1], &ldb, &beta, &cc[1], &ldc, - (ftnlen)1, (ftnlen)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"); + io___180.ciunit = *nout; + s_wsfe(&io___180); + e_wsfe(); *fatal = TRUE_; goto L110; } @@ -1407,7 +1804,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; @@ -1419,7 +1816,12 @@ static logical c_false = FALSE_; 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__); + io___183.ciunit = *nout; + s_wsfe(&io___183); + i__6 = i__ + 1; + do_fio(&c__1, (char *)&i__6, (ftnlen) + sizeof(integer)); + e_wsfe(); } /* L40: */ } @@ -1437,17 +1839,15 @@ 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); + errmax = f2cmax(errmax,err); /* If got really bad answer, report and */ /* return. */ if (*fatal) { @@ -1479,45 +1879,74 @@ static logical c_false = FALSE_; if (errmax < *thresh) { if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___185.ciunit = *nout; + s_wsfe(&io___185); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___186.ciunit = *nout; + s_wsfe(&io___186); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } } else { if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___187.ciunit = *nout; + s_wsfe(&io___187); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real)); + e_wsfe(); } if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); - } + io___188.ciunit = *nout; + s_wsfe(&io___188); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real)); + e_wsfe(); + } } goto L120; L110: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + io___189.ciunit = *nout; + s_wsfe(&io___189); + do_fio(&c__1, sname, (ftnlen)13); + e_wsfe(); sprcn2_(nout, &nc, sname, iorder, side, uplo, &m, &n, &alpha, &lda, &ldb, - &beta, &ldc, (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 */ int sprcn2_(integer *nout, integer *nc, char *sname, integer + *iorder, char *side, char *uplo, integer *m, integer *n, real *alpha, + integer *lda, integer *ldb, real *beta, integer *ldc) { + /* Format strings */ + static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002," + "a14,\002,\002,a14,\002,\002)"; + static char fmt_9994[] = "(20x,2(i3,\002,\002),f4.1,\002, A,\002,i3,\002" + ", B,\002,i3,\002,\002,f4.1,\002, \002,\002C,\002,i3,\002).\002)"; /* Local variables */ - static char cs[14], cu[14], crc[14]; + char cs[14], cu[14], crc[14]; + + /* Fortran I/O blocks */ + static cilist io___193 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___194 = { 0, 0, 0, fmt_9994, 0 }; + if (*(unsigned char *)side == 'L') { s_copy(cs, " CblasLeft", (ftnlen)14, (ftnlen)14); @@ -1534,54 +1963,116 @@ static logical c_false = FALSE_; } else { s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cs,cu); - printf("%d %d %4.1f A, %d, B, %d, %4.1f C, %d.\n",*m,*n,*alpha,*lda,*ldb,*beta,*ldc); + io___193.ciunit = *nout; + s_wsfe(&io___193); + do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer)); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, crc, (ftnlen)14); + do_fio(&c__1, cs, (ftnlen)14); + do_fio(&c__1, cu, (ftnlen)14); + e_wsfe(); + io___194.ciunit = *nout; + s_wsfe(&io___194); + do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(real)); + do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(real)); + do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer)); + e_wsfe(); + return 0; } /* sprcn2_ */ -/* Subroutine */ int schk3_(char* sname, real* eps, real* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, real* alf, integer* nmax, real* a, real* aa, real* as, real* b, real* bb, real* bs, real* ct, real* g, real* c__, integer* iorder, 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 */ - static char ichu[2+1] = "UL"; - static char icht[3+1] = "NTC"; - static char ichd[2+1] = "UN"; - static char ichs[2+1] = "LR"; + static char ichu[2] = "UL"; + static char icht[3] = "NTC"; + static char ichd[2] = "UN"; + static char ichs[2] = "LR"; + + /* Format strings */ + static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT " + "TAKEN ON VALID CALL *******\002)"; + static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER" + " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)"; + static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO" + "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR " + " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM" + "BER:\002)"; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5; - + alist al__1; /* Local variables */ - static char diag[1]; - static integer ldas, ldbs; - static logical same; - static char side[1]; - static logical left, null; - static char uplo[1]; - static integer i__, j, m, n; - static real alpha; - static char diags[1]; - static logical isame[13]; - static char sides[1]; - static integer nargs; - static logical reset; - static char uplos[1]; - extern /* Subroutine */ void sprcn3_(integer*, integer*, char*, integer*, char*, char*, char*, char*, integer*, integer*, real*, integer*, integer*, ftnlen , ftnlen, ftnlen, ftnlen, ftnlen); - static integer ia, na, nc, im, in, ms, ns; - static char tranas[1], transa[1]; - static real errmax; - extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, logical*, real*, ftnlen, ftnlen, ftnlen); - extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*, ftnlen, ftnlen); - extern logical lseres_(char*, char*, integer*, integer*, real*, real*, integer*, ftnlen, ftnlen); - extern /* Subroutine */ void cstrmm_(integer*, char*, char*, char*, char*, integer*, integer*, real*, real*, integer*, real*, integer*, ftnlen, ftnlen, ftnlen, ftnlen); - extern /* Subroutine */ void cstrsm_(integer*, char*, char*, char*, char*, integer*, integer*, real*, real*, integer*, real*, integer*, ftnlen, ftnlen, ftnlen, ftnlen); - static integer laa, icd, lbb, lda, ldb, ics; - static real als; - static integer ict, icu; - extern logical lse_(real*, real*, integer*); - static real err; + integer i__, j, m, n, ia, na, nc, im, in, ms, ns, laa, icd, lbb, lda, ldb, + ics; + real als; + integer ict, icu; + extern logical lse_(real *, real *, integer *); + real err; + char diag[1]; + integer ldas, ldbs; + logical same; + char side[1]; + logical left, null; + char uplo[1]; + real alpha; + char diags[1]; + logical isame[13]; + extern /* Subroutine */ int smake_(char *, char *, char *, integer *, + integer *, real *, integer *, real *, integer *, logical *, real * + ); + char sides[1]; + extern /* Subroutine */ int smmch_(char *, char *, integer *, integer *, + integer *, real *, real *, integer *, real *, integer *, real *, + real *, integer *, real *, real *, real *, integer *, real *, + real *, logical *, integer *, logical *); + integer nargs; + logical reset; + char uplos[1]; + extern /* Subroutine */ int sprcn3_(integer *, integer *, char *, integer + *, char *, char *, char *, char *, integer *, integer *, real *, + integer *, integer *); + char tranas[1], transa[1]; + real errmax; + extern logical lseres_(char *, char *, integer *, integer *, real *, real + *, integer *); + extern /* Subroutine */ int cstrmm_(integer *, char *, char *, char *, + char *, integer *, integer *, real *, real *, integer *, real *, + integer *), cstrsm_(integer *, + char *, char *, char *, char *, integer *, integer *, real *, + real *, integer *, real *, integer *); + + /* Fortran I/O blocks */ + static cilist io___235 = { 0, 0, 0, fmt_9994, 0 }; + static cilist io___238 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___240 = { 0, 0, 0, fmt_10000, 0 }; + static cilist io___241 = { 0, 0, 0, fmt_10001, 0 }; + static cilist io___242 = { 0, 0, 0, fmt_10002, 0 }; + static cilist io___243 = { 0, 0, 0, fmt_10003, 0 }; + static cilist io___244 = { 0, 0, 0, fmt_9996, 0 }; + + /* Tests STRMM and STRSM. */ @@ -1593,49 +2084,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 +2177,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; @@ -1744,38 +2221,42 @@ static logical c_false = FALSE_; sprcn3_(ntra, &nc, sname, iorder, side, uplo, transa, diag, &m, &n, &alpha, &lda, &ldb, ( - ftnlen)12, (ftnlen)1, (ftnlen) + ftnlen)13, (ftnlen)1, (ftnlen) 1, (ftnlen)1, (ftnlen)1); } if (*rewi) { -// f_rew(&al__1); + al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1); } cstrmm_(iorder, side, uplo, transa, diag, &m, &n, &alpha, &aa[1], &lda, &bb[ - 1], &ldb, (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) + ftnlen)13, (ftnlen)1, (ftnlen) 1, (ftnlen)1, (ftnlen)1); } if (*rewi) { -// f_rew(&al__1); + al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1); } cstrsm_(iorder, side, uplo, transa, diag, &m, &n, &alpha, &aa[1], &lda, &bb[ - 1], &ldb, (ftnlen)1, (ftnlen)1, ( - ftnlen)1, (ftnlen)1); + 1], &ldb); } /* Check if error-exit was taken incorrectly. */ if (! infoc_1.ok) { - printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + io___235.ciunit = *nout; + s_wsfe(&io___235); + e_wsfe(); *fatal = TRUE_; goto L150; } @@ -1799,8 +2280,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; @@ -1812,7 +2292,12 @@ static logical c_false = FALSE_; for (i__ = 1; i__ <= i__4; ++i__) { same = same && isame[i__ - 1]; if (! isame[i__ - 1]) { - printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + io___238.ciunit = *nout; + s_wsfe(&io___238); + i__5 = i__ + 1; + do_fio(&c__1, (char *)&i__5, (ftnlen) + sizeof(integer)); + e_wsfe(); } /* L50: */ } @@ -1843,8 +2328,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 +2356,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,11 +2364,10 @@ 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); + errmax = f2cmax(errmax,err); /* If got really bad answer, report and */ /* return. */ if (*fatal) { @@ -1919,47 +2401,76 @@ static logical c_false = FALSE_; if (errmax < *thresh) { if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___240.ciunit = *nout; + s_wsfe(&io___240); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___241.ciunit = *nout; + s_wsfe(&io___241); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } } else { if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___242.ciunit = *nout; + s_wsfe(&io___242); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real)); + e_wsfe(); } if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___243.ciunit = *nout; + s_wsfe(&io___243); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real)); + e_wsfe(); } } goto L160; L150: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + io___244.ciunit = *nout; + s_wsfe(&io___244); + do_fio(&c__1, sname, (ftnlen)13); + e_wsfe(); if (*trace) { sprcn3_(ntra, &nc, sname, iorder, side, uplo, transa, diag, &m, &n, & - alpha, &lda, &ldb, (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 */ int sprcn3_(integer *nout, integer *nc, char *sname, integer + *iorder, char *side, char *uplo, char *transa, char *diag, integer *m, + integer *n, real *alpha, integer *lda, integer *ldb) { + /* Format strings */ + static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002," + "a14,\002,\002,a14,\002,\002)"; + static char fmt_9994[] = "(22x,2(a14,\002,\002),2(i3,\002,\002),f4.1," + "\002, A,\002,i3,\002, B,\002,i3,\002).\002)"; /* Local variables */ - static char ca[14], cd[14], cs[14], cu[14], crc[14]; + char ca[14], cd[14], cs[14], cu[14], crc[14]; + + /* Fortran I/O blocks */ + static cilist io___250 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___251 = { 0, 0, 0, fmt_9994, 0 }; + if (*(unsigned char *)side == 'L') { s_copy(cs, " CblasLeft", (ftnlen)14, (ftnlen)14); @@ -1988,52 +2499,113 @@ static logical c_false = FALSE_; } else { s_copy(crc, "CblasColMajor", (ftnlen)14, (ftnlen)13); } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cs,cu); - printf(" %s %s %d %d %4.1f A %d B %d\n",ca,cd,*m,*n,*alpha,*lda,*ldb); - + io___250.ciunit = *nout; + s_wsfe(&io___250); + do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer)); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, crc, (ftnlen)14); + do_fio(&c__1, cs, (ftnlen)14); + do_fio(&c__1, cu, (ftnlen)14); + e_wsfe(); + io___251.ciunit = *nout; + s_wsfe(&io___251); + do_fio(&c__1, ca, (ftnlen)14); + do_fio(&c__1, cd, (ftnlen)14); + do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(real)); + do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer)); + e_wsfe(); + return 0; } /* sprcn3_ */ -/* Subroutine */ int schk4_(char* sname, real* eps, real* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, real* alf, integer* nbet, real* bet, integer* nmax, real* a, real* aa, real* as, real* b, real* bb, real* bs, real* c__, real* cc, real* cs, real* ct, real* g, integer* iorder, 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 */ - static char icht[3+1] = "NTC"; - static char ichu[2+1] = "UL"; + static char icht[3] = "NTC"; + static char ichu[2] = "UL"; + + /* Format strings */ + static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT " + "TAKEN ON VALID CALL *******\002)"; + static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER" + " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)"; + static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO" + "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR " + " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN" + " \002,i3)"; + static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM" + "BER:\002)"; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, - i__3, i__4, i__5; - + i__3, i__4, i__5, i__6; + alist al__1; /* Local variables */ - static real beta; - static integer ldas, ldcs; - static logical same; - static real bets; - static logical tran, null; - static char uplo[1]; - static integer i__, j, k, n; - static real alpha; - static logical isame[13]; - static integer nargs; - static logical reset; - static char trans[1]; - static logical upper; - static char uplos[1]; - extern /* Subroutine */ void sprcn4_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, ftnlen, ftnlen, ftnlen); - extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, logical*, real*, ftnlen, ftnlen, ftnlen); - extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*, ftnlen, ftnlen); - static integer ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns; - static real errmax; - extern logical lseres_(char*, char*, integer*, integer*, real*, real*, integer*, ftnlen, ftnlen); - static char transs[1]; - extern /* Subroutine */ void cssyrk_(integer*, char*, char*, integer*, integer*, real*, real*, integer*, real*, real*, integer*, ftnlen, ftnlen); - static integer laa, lda, lcc, ldc; - static real als; - static integer ict, icu; - extern logical lse_(real*, real*, integer*); - static real err; + integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa, + lda, lcc, ldc; + real als; + integer ict, icu; + extern logical lse_(real *, real *, integer *); + real err, beta; + integer ldas, ldcs; + logical same; + real bets; + logical tran, null; + char uplo[1]; + real alpha; + logical isame[13]; + extern /* Subroutine */ int smake_(char *, char *, char *, integer *, + integer *, real *, integer *, real *, integer *, logical *, real * + ), smmch_(char *, char *, integer *, + integer *, integer *, real *, real *, integer *, real *, integer * + , real *, real *, integer *, real *, real *, real *, integer *, + real *, real *, logical *, integer *, logical *); + integer nargs; + logical reset; + char trans[1]; + logical upper; + char uplos[1]; + extern /* Subroutine */ int sprcn4_(integer *, integer *, char *, integer + *, char *, char *, integer *, integer *, real *, integer *, real * + , integer *); + real errmax; + extern logical lseres_(char *, char *, integer *, integer *, real *, real + *, integer *); + char transs[1]; + extern /* Subroutine */ int cssyrk_(integer *, char *, char *, integer *, + integer *, real *, real *, integer *, real *, real *, integer *); + + /* Fortran I/O blocks */ + static cilist io___288 = { 0, 0, 0, fmt_9993, 0 }; + static cilist io___291 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___297 = { 0, 0, 0, fmt_10000, 0 }; + static cilist io___298 = { 0, 0, 0, fmt_10001, 0 }; + static cilist io___299 = { 0, 0, 0, fmt_10002, 0 }; + static cilist io___300 = { 0, 0, 0, fmt_10003, 0 }; + static cilist io___301 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___302 = { 0, 0, 0, fmt_9996, 0 }; + + /* Tests SSYRK. */ @@ -2045,17 +2617,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 +2626,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 +2690,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 +2708,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,20 +2738,22 @@ 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); + al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1); } cssyrk_(iorder, uplo, trans, &n, &k, &alpha, &aa[ - 1], &lda, &beta, &cc[1], &ldc, (ftnlen)1, - (ftnlen)1); + 1], &lda, &beta, &cc[1], &ldc); /* Check if error-exit was taken incorrectly. */ if (! infoc_1.ok) { - printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + io___288.ciunit = *nout; + s_wsfe(&io___288); + e_wsfe(); *fatal = TRUE_; goto L120; } @@ -2213,7 +2774,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; @@ -2225,7 +2786,12 @@ static logical c_false = FALSE_; 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__); + io___291.ciunit = *nout; + s_wsfe(&io___291); + i__6 = i__ + 1; + do_fio(&c__1, (char *)&i__6, (ftnlen) + sizeof(integer)); + e_wsfe(); } /* L30: */ } @@ -2255,8 +2821,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,14 +2829,14 @@ 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; } else { jc = jc + ldc + 1; } - errmax = dmax(errmax,err); + errmax = f2cmax(errmax,err); /* If got really bad answer, report and */ /* return. */ if (*fatal) { @@ -2305,49 +2870,82 @@ static logical c_false = FALSE_; if (errmax < *thresh) { if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___297.ciunit = *nout; + s_wsfe(&io___297); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___298.ciunit = *nout; + s_wsfe(&io___298); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } } else { if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___299.ciunit = *nout; + s_wsfe(&io___299); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real)); + e_wsfe(); } if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___300.ciunit = *nout; + s_wsfe(&io___300); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real)); + e_wsfe(); } } goto L130; L110: if (n > 1) { - printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j); + io___301.ciunit = *nout; + s_wsfe(&io___301); + do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer)); + e_wsfe(); } L120: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + io___302.ciunit = *nout; + s_wsfe(&io___302); + do_fio(&c__1, sname, (ftnlen)13); + e_wsfe(); sprcn4_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, & - beta, &ldc, (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 */ int sprcn4_(integer *nout, integer *nc, char *sname, integer + *iorder, char *uplo, char *transa, integer *n, integer *k, real * + alpha, integer *lda, real *beta, integer *ldc) { + /* Format strings */ + static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002," + "\002))"; + static char fmt_9994[] = "(20x,2(i3,\002,\002),f4.1,\002, A,\002,i3" + ",\002,\002,f4.1,\002, C,\002,i3,\002).\002)"; /* Local variables */ - static char ca[14], cu[14], crc[14]; + char ca[14], cu[14], crc[14]; + + /* Fortran I/O blocks */ + static cilist io___306 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___307 = { 0, 0, 0, fmt_9994, 0 }; + if (*(unsigned char *)uplo == 'U') { s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); @@ -2366,53 +2964,114 @@ static logical c_false = FALSE_; } else { s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); - printf("( %d %d %4.1f A %d %4.1f C %d\n",*n,*k,*alpha,*lda,*beta,*ldc); - + io___306.ciunit = *nout; + s_wsfe(&io___306); + do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer)); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, crc, (ftnlen)14); + do_fio(&c__1, cu, (ftnlen)14); + do_fio(&c__1, ca, (ftnlen)14); + e_wsfe(); + io___307.ciunit = *nout; + s_wsfe(&io___307); + do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(real)); + do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(real)); + do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer)); + e_wsfe(); + return 0; } /* sprcn4_ */ -/* Subroutine */ int schk5_(char* sname, real* eps, real* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, real* alf, integer* nbet, real* bet, integer* nmax, real* ab, real* aa, real* as, real* bb, real* bs, real* c__, real* cc, real* cs, real* ct, real* g, real* w, integer* iorder, 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 */ - static char icht[3+1] = "NTC"; - static char ichu[2+1] = "UL"; + static char icht[3] = "NTC"; + static char ichu[2] = "UL"; + + /* Format strings */ + static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT " + "TAKEN ON VALID CALL *******\002)"; + static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER" + " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)"; + static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO" + "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR " + " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN" + " \002,i3)"; + static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM" + "BER:\002)"; /* System generated locals */ integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8; - + alist al__1; /* Local variables */ - static integer jjab; - static real beta; - static integer ldas, ldbs, ldcs; - static logical same; - static real bets; - static logical tran, null; - static char uplo[1]; - static integer i__, j, k, n; - static real alpha; - static logical isame[13]; - static integer nargs; - static logical reset; - static char trans[1]; - static logical upper; - static char uplos[1]; - static integer ia, ib; - extern /* Subroutine */ void sprcn5_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, real*, integer*, integer*, real*, integer*, ftnlen, ftnlen, ftnlen); - static integer jc, ma, na, nc, ik, in, jj, lj, ks, ns; - static real errmax; - extern logical lseres_(char*, char*, integer*, integer*, real*, real*, integer*, ftnlen, ftnlen); - extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, logical*, real*, ftnlen, ftnlen, ftnlen); - static char transs[1]; - static integer laa, lbb, lda, lcc, ldb, ldc; - static real als; - static integer ict, icu; - extern /* Subroutine */ void cssyr2k_(integer*, char*, char*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, ftnlen, ftnlen); - extern logical lse_(real*, real*, integer*); - extern /* Subroutine */ int smmch_(char*, char*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, integer*, real*, real*, logical*, integer*, logical*, ftnlen, ftnlen); - static real err; + integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa, + lbb, lda, lcc, ldb, ldc; + real als; + integer ict, icu; + extern logical lse_(real *, real *, integer *); + real err; + integer jjab; + real beta; + integer ldas, ldbs, ldcs; + logical same; + real bets; + logical tran, null; + char uplo[1]; + real alpha; + logical isame[13]; + extern /* Subroutine */ int smake_(char *, char *, char *, integer *, + integer *, real *, integer *, real *, integer *, logical *, real * + ), smmch_(char *, char *, integer *, + integer *, integer *, real *, real *, integer *, real *, integer * + , real *, real *, integer *, real *, real *, real *, integer *, + real *, real *, logical *, integer *, logical *); + integer nargs; + logical reset; + char trans[1]; + logical upper; + char uplos[1]; + extern /* Subroutine */ int sprcn5_(integer *, integer *, char *, integer + *, char *, char *, integer *, integer *, real *, integer *, + integer *, real *, integer *); + real errmax; + extern logical lseres_(char *, char *, integer *, integer *, real *, real + *, integer *); + char transs[1]; + extern /* Subroutine */ int cssyr2k_(integer *, char *, char *, integer *, + integer *, real *, real *, integer *, real *, integer *, real *, + real *, integer *); + + /* Fortran I/O blocks */ + static cilist io___347 = { 0, 0, 0, fmt_9993, 0 }; + static cilist io___350 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___357 = { 0, 0, 0, fmt_10000, 0 }; + static cilist io___358 = { 0, 0, 0, fmt_10001, 0 }; + static cilist io___359 = { 0, 0, 0, fmt_10002, 0 }; + static cilist io___360 = { 0, 0, 0, fmt_10003, 0 }; + static cilist io___361 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___362 = { 0, 0, 0, fmt_9996, 0 }; + + /* Tests SSYR2K. */ @@ -2424,17 +3083,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 +3093,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 +3102,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 +3154,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 +3167,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 +3188,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,20 +3225,24 @@ 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) { -// f_rew(&al__1); + al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1); } cssyr2k_(iorder, uplo, trans, &n, &k, &alpha, &aa[ 1], &lda, &bb[1], &ldb, &beta, &cc[1], & - ldc, (ftnlen)1, (ftnlen)1); + ldc); /* Check if error-exit was taken incorrectly. */ if (! infoc_1.ok) { - printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + io___347.ciunit = *nout; + s_wsfe(&io___347); + e_wsfe(); *fatal = TRUE_; goto L150; } @@ -2619,7 +3265,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; @@ -2631,7 +3277,12 @@ static logical c_false = FALSE_; 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__); + io___350.ciunit = *nout; + s_wsfe(&io___350); + i__6 = i__ + 1; + do_fio(&c__1, (char *)&i__6, (ftnlen) + sizeof(integer)); + e_wsfe(); } /* L40: */ } @@ -2658,9 +3309,9 @@ static logical c_false = FALSE_; if (tran) { i__6 = k; for (i__ = 1; i__ <= i__6; ++i__) { - w[i__] = ab[((j - 1) << 1) * *nmax + w[i__] = ab[(j - 1 << 1) * *nmax + k + i__]; - w[k + i__] = ab[((j - 1) << 1) * * + w[k + i__] = ab[(j - 1 << 1) * * nmax + i__]; /* L50: */ } @@ -2672,8 +3323,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 +3340,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; @@ -2701,7 +3350,7 @@ static logical c_false = FALSE_; jjab += *nmax << 1; } } - errmax = dmax(errmax,err); + errmax = f2cmax(errmax,err); /* If got really bad answer, report and */ /* return. */ if (*fatal) { @@ -2735,50 +3384,82 @@ static logical c_false = FALSE_; if (errmax < *thresh) { if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___357.ciunit = *nout; + s_wsfe(&io___357); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___358.ciunit = *nout; + s_wsfe(&io___358); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } } else { if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___359.ciunit = *nout; + s_wsfe(&io___359); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real)); + e_wsfe(); } if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___360.ciunit = *nout; + s_wsfe(&io___360); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real)); + e_wsfe(); } } goto L160; L140: if (n > 1) { - printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j); + io___361.ciunit = *nout; + s_wsfe(&io___361); + do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer)); + e_wsfe(); } L150: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + io___362.ciunit = *nout; + s_wsfe(&io___362); + do_fio(&c__1, sname, (ftnlen)13); + e_wsfe(); sprcn5_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &ldb, - &beta, &ldc, (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 */ int sprcn5_(integer *nout, integer *nc, char *sname, integer + *iorder, char *uplo, char *transa, integer *n, integer *k, real * + alpha, integer *lda, integer *ldb, real *beta, integer *ldc) { + /* Format strings */ + static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002," + "\002))"; + static char fmt_9994[] = "(20x,2(i3,\002,\002),f4.1,\002, A,\002,i3,\002" + ", B\002,i3,\002,\002,f4.1,\002, C,\002,i3,\002).\002)"; /* Local variables */ - static char ca[14], cu[14], crc[14]; + char ca[14], cu[14], crc[14]; + + /* Fortran I/O blocks */ + static cilist io___366 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___367 = { 0, 0, 0, fmt_9994, 0 }; + if (*(unsigned char *)uplo == 'U') { s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); @@ -2797,25 +3478,41 @@ static logical c_false = FALSE_; } else { s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); - printf("%d %d %4.1f , A, %d, B, %d, %4.1f , C, %d.\n",*n,*k,*alpha,*lda,*ldb,*beta,*ldc); - + io___366.ciunit = *nout; + s_wsfe(&io___366); + do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer)); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, crc, (ftnlen)14); + do_fio(&c__1, cu, (ftnlen)14); + do_fio(&c__1, ca, (ftnlen)14); + e_wsfe(); + io___367.ciunit = *nout; + s_wsfe(&io___367); + do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(real)); + do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(real)); + do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer)); + e_wsfe(); + return 0; } /* sprcn5_ */ -/* Subroutine */ int smake_(char* type__, char* uplo, char* diag, integer* m, integer* n, real* a, integer* nmax, real* aa, integer* lda, logical* reset, real* transl, 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*); - static logical unit; - static integer i__, j; - static logical lower, upper, gen, tri, sym; + integer i__, j; + logical gen, tri, sym; + integer ibeg, iend; + extern real sbeg_(logical *); + logical unit, lower, upper; /* Generates values for an M by N matrix A. */ @@ -2832,15 +3529,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; @@ -2858,27 +3549,27 @@ static logical c_false = FALSE_; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { - if (gen || (upper && i__ <= j) || (lower && i__ >= j)) { + if (gen || upper && i__ <= j || lower && i__ >= j) { a[i__ + j * a_dim1] = sbeg_(reset) + *transl; if (i__ != j) { /* Set some elements to zero */ 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 +3586,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 +3612,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 +3622,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,21 +3634,37 @@ 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) { + /* Format strings */ + static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS" + " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 EX" + "PECTED RESULT COMPU\002,\002TED RESULT\002)"; + static char fmt_9998[] = "(1x,i7,2g18.6)"; + static char fmt_9997[] = "(\002 THESE ARE THE RESULTS FOR COLUMN" + " \002,i3)"; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, cc_dim1, cc_offset, i__1, i__2, i__3; real r__1, r__2; - /* Builtin functions */ - double sqrt(double); - /* Local variables */ - static real erri; - static integer i__, j, k; - static logical trana, tranb; + integer i__, j, k; + real erri; + logical trana, tranb; + + /* Fortran I/O blocks */ + static cilist io___384 = { 0, 0, 0, fmt_9999, 0 }; + static cilist io___385 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___386 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___387 = { 0, 0, 0, fmt_9997, 0 }; + + /* Checks the results of the computational tests. */ @@ -2969,26 +3676,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 +3707,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) { @@ -3016,8 +3717,8 @@ static logical c_false = FALSE_; i__3 = *m; for (i__ = 1; i__ <= i__3; ++i__) { ct[i__] += a[i__ + k * a_dim1] * b[k + j * b_dim1]; - g[i__] += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) * ( - r__2 = b[k + j * b_dim1], dabs(r__2)); + g[i__] += (r__1 = a[i__ + k * a_dim1], abs(r__1)) * (r__2 + = b[k + j * b_dim1], abs(r__2)); /* L20: */ } /* L30: */ @@ -3028,8 +3729,8 @@ static logical c_false = FALSE_; i__3 = *m; for (i__ = 1; i__ <= i__3; ++i__) { ct[i__] += a[k + i__ * a_dim1] * b[k + j * b_dim1]; - g[i__] += (r__1 = a[k + i__ * a_dim1], dabs(r__1)) * ( - r__2 = b[k + j * b_dim1], dabs(r__2)); + g[i__] += (r__1 = a[k + i__ * a_dim1], abs(r__1)) * (r__2 + = b[k + j * b_dim1], abs(r__2)); /* L40: */ } /* L50: */ @@ -3040,8 +3741,8 @@ static logical c_false = FALSE_; i__3 = *m; for (i__ = 1; i__ <= i__3; ++i__) { ct[i__] += a[i__ + k * a_dim1] * b[j + k * b_dim1]; - g[i__] += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) * ( - r__2 = b[j + k * b_dim1], dabs(r__2)); + g[i__] += (r__1 = a[i__ + k * a_dim1], abs(r__1)) * (r__2 + = b[j + k * b_dim1], abs(r__2)); /* L60: */ } /* L70: */ @@ -3052,8 +3753,8 @@ static logical c_false = FALSE_; i__3 = *m; for (i__ = 1; i__ <= i__3; ++i__) { ct[i__] += a[k + i__ * a_dim1] * b[j + k * b_dim1]; - g[i__] += (r__1 = a[k + i__ * a_dim1], dabs(r__1)) * ( - r__2 = b[j + k * b_dim1], dabs(r__2)); + g[i__] += (r__1 = a[k + i__ * a_dim1], abs(r__1)) * (r__2 + = b[j + k * b_dim1], abs(r__2)); /* L80: */ } /* L90: */ @@ -3062,23 +3763,22 @@ static logical c_false = FALSE_; i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { ct[i__] = *alpha * ct[i__] + *beta * c__[i__ + j * c_dim1]; - g[i__] = dabs(*alpha) * g[i__] + dabs(*beta) * (r__1 = c__[i__ + - j * c_dim1], dabs(r__1)); + 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 = (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)) / * - eps; - if (g[i__] != (float)0.) { + erri = (r__1 = ct[i__] - cc[i__ + j * cc_dim1], abs(r__1)) / *eps; + if (g[i__] != 0.f) { erri /= g[i__]; } - *err = dmax(*err,erri); - if (*err * sqrt(*eps) >= (float)1.) { + *err = f2cmax(*err,erri); + if (*err * sqrt(*eps) >= 1.f) { goto L130; } /* L110: */ @@ -3094,19 +3794,35 @@ static logical c_false = FALSE_; L130: *fatal = TRUE_; - printf(" ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HALF ACCURATE *******\n"); - printf(" EXPECTED RESULT COMPUTED RESULT\n"); + io___384.ciunit = *nout; + s_wsfe(&io___384); + e_wsfe(); i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { if (*mv) { - printf("%7d %15.6g %15.6g\n",i__,ct[i__],cc[i__+j*cc_dim1]); + io___385.ciunit = *nout; + s_wsfe(&io___385); + do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&ct[i__], (ftnlen)sizeof(real)); + do_fio(&c__1, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(real) + ); + e_wsfe(); } else { - printf("%7d %15.6g %15.6g\n",i__,cc[i__+j*cc_dim1],ct[i__]); + io___386.ciunit = *nout; + s_wsfe(&io___386); + do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(real) + ); + do_fio(&c__1, (char *)&ct[i__], (ftnlen)sizeof(real)); + e_wsfe(); } /* L140: */ } if (*n > 1) { - printf(" THESE ARE THE RESULTS FOR COLUMN %d\n",j); + io___387.ciunit = *nout; + s_wsfe(&io___387); + do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer)); + e_wsfe(); } L150: @@ -3117,14 +3833,14 @@ static logical c_false = FALSE_; } /* smmch_ */ -logical lse_(real* ri, real* rj, integer* lr) +logical lse_(real *ri, real *rj, integer *lr) { /* System generated locals */ integer i__1; logical ret_val; /* Local variables */ - static integer i__; + integer i__; /* Tests if two arrays are identical. */ @@ -3137,10 +3853,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,17 +3876,16 @@ 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; + integer i__, j, ibeg, iend; + logical upper; /* Tests if selected elements in two arrays are equal. */ @@ -3189,16 +3900,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 +3950,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 +3962,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 +3981,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 +4003,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 +4024,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 +4031,689 @@ 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"; + + /* Format strings */ + static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT " + "TAKEN ON VALID CALL *******\002)"; + static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER" + " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)"; + static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO" + "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR " + " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM" + "BER:\002)"; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5; + alist al__1; + + /* Local variables */ + extern /* Subroutine */ int csgemmtr_(integer *, char *, char *, char *, + integer *, integer *, real *, real *, integer *, real *, integer * + , real *, real *, integer *); + integer i__, k, n, ia, ib, ma, mb, na, nb, nc, ik, in, is, ks, ns, ica, + icb, laa, lbb, lda, lcc, ldb, ldc; + real als, bls; + extern logical lse_(real *, real *, integer *); + real err, beta; + integer ldas, ldbs, ldcs; + logical same, null; + char uplo[1]; + real alpha; + logical isame[13]; + extern /* Subroutine */ int smake_(char *, char *, char *, integer *, + integer *, real *, integer *, real *, integer *, logical *, real * + ); + logical trana, tranb; + integer nargs; + logical reset; + char uplos[1]; + extern /* Subroutine */ int sprcn8_(integer *, integer *, char *, integer + *, char *, char *, char *, integer *, integer *, real *, integer * + , integer *, real *, integer *); + char tranas[1], tranbs[1], transa[1], transb[1]; + extern /* Subroutine */ int smmtch_(char *, char *, char *, integer *, + integer *, real *, real *, integer *, real *, integer *, real *, + real *, integer *, real *, real *, real *, integer *, real *, + real *, logical *, integer *, logical *); + real errmax; + extern logical lseres_(char *, char *, integer *, integer *, real *, real + *, integer *); + + /* Fortran I/O blocks */ + static cilist io___441 = { 0, 0, 0, fmt_9994, 0 }; + static cilist io___444 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___446 = { 0, 0, 0, fmt_10000, 0 }; + static cilist io___447 = { 0, 0, 0, fmt_10001, 0 }; + static cilist io___448 = { 0, 0, 0, fmt_10002, 0 }; + static cilist io___449 = { 0, 0, 0, fmt_10003, 0 }; + static cilist io___450 = { 0, 0, 0, fmt_9996, 0 }; + + + +/* Tests SGEMMTR. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 19-July-2023. */ +/* Martin Koehler, MPI Magdeburg */ + + /* Parameter adjustments */ + --idim; + --alf; + --bet; + --g; + --ct; + --cs; + --cc; + c_dim1 = *nmax; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --bs; + --bb; + b_dim1 = *nmax; + b_offset = 1 + b_dim1; + b -= b_offset; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + + nargs = 13; + nc = 0; + reset = TRUE_; + errmax = 0.f; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; +/* Set LDC to 1 more than minimum value if room. */ + ldc = n; + if (ldc < *nmax) { + ++ldc; + } +/* Skip tests if not enough room. */ + if (ldc > *nmax) { + goto L100; + } + lcc = ldc * n; + null = n <= 0; + + i__2 = *nidim; + for (ik = 1; ik <= i__2; ++ik) { + k = idim[ik]; + + for (ica = 1; ica <= 3; ++ica) { + *(unsigned char *)transa = *(unsigned char *)&ich[ica - 1]; + trana = *(unsigned char *)transa == 'T' || *(unsigned char *) + transa == 'C'; + + if (trana) { + ma = k; + na = n; + } else { + ma = n; + na = k; + } +/* Set LDA to 1 more than minimum value if room. */ + lda = ma; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L80; + } + laa = lda * na; + +/* Generate the matrix A. */ + + smake_("GE", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[1], & + lda, &reset, &c_b103) + ; + + for (icb = 1; icb <= 3; ++icb) { + *(unsigned char *)transb = *(unsigned char *)&ich[icb - 1] + ; + tranb = *(unsigned char *)transb == 'T' || *(unsigned + char *)transb == 'C'; + + if (tranb) { + mb = n; + nb = k; + } else { + mb = k; + nb = n; + } +/* Set LDB to 1 more than minimum value if room. */ + ldb = mb; + if (ldb < *nmax) { + ++ldb; + } +/* Skip tests if not enough room. */ + if (ldb > *nmax) { + goto L70; + } + lbb = ldb * nb; + +/* Generate the matrix B. */ + + smake_("GE", " ", " ", &mb, &nb, &b[b_offset], nmax, &bb[ + 1], &ldb, &reset, &c_b103); + + i__3 = *nalf; + for (ia = 1; ia <= i__3; ++ia) { + alpha = alf[ia]; + + i__4 = *nbet; + for (ib = 1; ib <= i__4; ++ib) { + beta = bet[ib]; + for (is = 1; is <= 2; ++is) { + *(unsigned char *)uplo = *(unsigned char *)& + ishape[is - 1]; + +/* Generate the matrix C. */ + + smake_("GE", uplo, " ", &n, &n, &c__[c_offset] + , nmax, &cc[1], &ldc, &reset, &c_b103); + + ++nc; + +/* Save every datum before calling the */ +/* subroutine. */ + + *(unsigned char *)uplos = *(unsigned char *) + uplo; + *(unsigned char *)tranas = *(unsigned char *) + transa; + *(unsigned char *)tranbs = *(unsigned char *) + transb; + ns = n; + ks = k; + als = alpha; + i__5 = laa; + for (i__ = 1; i__ <= i__5; ++i__) { + as[i__] = aa[i__]; +/* L10: */ + } + ldas = lda; + i__5 = lbb; + for (i__ = 1; i__ <= i__5; ++i__) { + bs[i__] = bb[i__]; +/* L20: */ + } + ldbs = ldb; + bls = beta; + i__5 = lcc; + for (i__ = 1; i__ <= i__5; ++i__) { + cs[i__] = cc[i__]; +/* L30: */ + } + ldcs = ldc; + +/* Call the subroutine. */ + + if (*trace) { + sprcn8_(ntra, &nc, sname, iorder, uplo, + transa, transb, &n, &k, &alpha, & + lda, &ldb, &beta, &ldc); + } + if (*rewi) { + al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1); + } + csgemmtr_(iorder, uplo, transa, transb, &n, & + k, &alpha, &aa[1], &lda, &bb[1], &ldb, + &beta, &cc[1], &ldc); + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_2.ok) { + io___441.ciunit = *nout; + s_wsfe(&io___441); + e_wsfe(); + *fatal = TRUE_; + goto L120; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)uplo == *( + unsigned char *)uplos; + isame[1] = *(unsigned char *)transa == *( + unsigned char *)tranas; + isame[2] = *(unsigned char *)transb == *( + unsigned char *)tranbs; + isame[3] = ns == n; + isame[4] = ks == k; + isame[5] = als == alpha; + isame[6] = lse_(&as[1], &aa[1], &laa); + isame[7] = ldas == lda; + isame[8] = lse_(&bs[1], &bb[1], &lbb); + isame[9] = ldbs == ldb; + isame[10] = bls == beta; + if (null) { + isame[11] = lse_(&cs[1], &cc[1], &lcc); + } else { + isame[11] = lseres_("GE", " ", &n, &n, & + cs[1], &cc[1], &ldc); + } + isame[12] = ldcs == ldc; + +/* If data was incorrectly changed, report */ +/* and return. */ + + same = TRUE_; + i__5 = nargs; + for (i__ = 1; i__ <= i__5; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + io___444.ciunit = *nout; + s_wsfe(&io___444); + do_fio(&c__1, (char *)&i__, (ftnlen) + sizeof(integer)); + e_wsfe(); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L120; + } + + if (! null) { + +/* Check the result. */ + + smmtch_(uplo, transa, transb, &n, &k, & + alpha, &a[a_offset], nmax, &b[ + b_offset], nmax, &beta, &c__[ + c_offset], nmax, &ct[1], &g[1], & + cc[1], &ldc, eps, &err, fatal, + nout, &c_true); + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L120; + } + } + +/* L45: */ + } + +/* L50: */ + } + +/* L60: */ + } + +L70: + ; + } + +L80: + ; + } + +/* L90: */ + } + +L100: + ; + } + + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + io___446.ciunit = *nout; + s_wsfe(&io___446); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); + } + if (*iorder == 1) { + io___447.ciunit = *nout; + s_wsfe(&io___447); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); + } + } else { + if (*iorder == 0) { + io___448.ciunit = *nout; + s_wsfe(&io___448); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real)); + e_wsfe(); + } + if (*iorder == 1) { + io___449.ciunit = *nout; + s_wsfe(&io___449); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real)); + e_wsfe(); + } + } + goto L130; + +L120: + io___450.ciunit = *nout; + s_wsfe(&io___450); + do_fio(&c__1, sname, (ftnlen)13); + e_wsfe(); + sprcn8_(nout, &nc, sname, iorder, uplo, transa, transb, &n, &k, &alpha, & + lda, &ldb, &beta, &ldc); + +L130: + return 0; + +/* L9997: */ +/* L9995: */ + +/* End of SCHK6 */ + +} /* schk6_ */ + +/* Subroutine */ int sprcn8_(integer *nout, integer *nc, char *sname, integer + *iorder, char *uplo, char *transa, char *transb, integer *n, integer * + k, real *alpha, integer *lda, integer *ldb, real *beta, integer *ldc) +{ + /* Format strings */ + static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002," + "a14,\002,\002,a14,\002,\002,a14,\002,\002)"; + static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 \002,f4.1,\002 , A" + ",\002,i3,\002, B,\002,i3,\002, \002,f4.1,\002 , C,\002,i3,\002)" + ".\002)"; + + /* Local variables */ + char crc[14], cta[14], ctb[14], cuplo[14]; + + /* Fortran I/O blocks */ + static cilist io___455 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___456 = { 0, 0, 0, fmt_9994, 0 }; + + + if (*(unsigned char *)uplo == 'U') { + s_copy(cuplo, "CblasUpper", (ftnlen)14, (ftnlen)10); + } else { + s_copy(cuplo, "CblasLower", (ftnlen)14, (ftnlen)10); + } + if (*(unsigned char *)transa == 'N') { + s_copy(cta, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transa == 'T') { + s_copy(cta, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cta, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)transb == 'N') { + s_copy(ctb, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transb == 'T') { + s_copy(ctb, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(ctb, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*iorder == 1) { + s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); + } else { + s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); + } + io___455.ciunit = *nout; + s_wsfe(&io___455); + do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer)); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, crc, (ftnlen)14); + do_fio(&c__1, cuplo, (ftnlen)14); + do_fio(&c__1, cta, (ftnlen)14); + do_fio(&c__1, ctb, (ftnlen)14); + e_wsfe(); + io___456.ciunit = *nout; + s_wsfe(&io___456); + do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(real)); + do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(real)); + do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer)); + e_wsfe(); + return 0; +} /* sprcn8_ */ + +/* Subroutine */ int smmtch_(char *uplo, char *transa, char *transb, integer * + n, integer *kk, real *alpha, real *a, integer *lda, real *b, integer * + ldb, real *beta, real *c__, integer *ldc, real *ct, real *g, real *cc, + integer *ldcc, real *eps, real *err, logical *fatal, integer *nout, + logical *mv) +{ + /* Format strings */ + static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS" + " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 EX" + "PECTED RESULT COMPU\002,\002TED RESULT\002)"; + static char fmt_9998[] = "(1x,i7,2g18.6)"; + static char fmt_9997[] = "(\002 THESE ARE THE RESULTS FOR COLUMN" + " \002,i3)"; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, cc_dim1, + cc_offset, i__1, i__2, i__3; + real r__1, r__2; + + /* Local variables */ + integer i__, j, k; + real erri; + logical trana, tranb, upper; + integer istop, istart; + + /* Fortran I/O blocks */ + static cilist io___466 = { 0, 0, 0, fmt_9999, 0 }; + static cilist io___467 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___468 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___469 = { 0, 0, 0, fmt_9997, 0 }; + + + +/* Checks the results of the computational tests. */ + +/* Auxiliary routine for test program for Level 3 Blas. (DGEMMTR) */ + +/* -- Written on 19-July-2023. */ +/* Martin Koehler, MPI Magdeburg */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --ct; + --g; + cc_dim1 = *ldcc; + cc_offset = 1 + cc_dim1; + cc -= cc_offset; + + /* Function Body */ + upper = *(unsigned char *)uplo == 'U'; + trana = *(unsigned char *)transa == 'T' || *(unsigned char *)transa == + 'C'; + tranb = *(unsigned char *)transb == 'T' || *(unsigned char *)transb == + 'C'; + +/* Compute expected result, one column at a time, in CT using data */ +/* in A, B and C. */ +/* Compute gauges in G. */ + + istart = 1; + istop = *n; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + + if (upper) { + istart = 1; + istop = j; + } else { + istart = j; + istop = *n; + } + i__2 = istop; + for (i__ = istart; i__ <= i__2; ++i__) { + ct[i__] = 0.f; + g[i__] = 0.f; +/* L10: */ + } + if (! trana && ! tranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = istop; + for (i__ = istart; i__ <= i__3; ++i__) { + ct[i__] += a[i__ + k * a_dim1] * b[k + j * b_dim1]; + g[i__] += (r__1 = a[i__ + k * a_dim1], abs(r__1)) * (r__2 + = b[k + j * b_dim1], abs(r__2)); +/* L20: */ + } +/* L30: */ + } + } else if (trana && ! tranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = istop; + for (i__ = istart; i__ <= i__3; ++i__) { + ct[i__] += a[k + i__ * a_dim1] * b[k + j * b_dim1]; + g[i__] += (r__1 = a[k + i__ * a_dim1], abs(r__1)) * (r__2 + = b[k + j * b_dim1], abs(r__2)); +/* L40: */ + } +/* L50: */ + } + } else if (! trana && tranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = istop; + for (i__ = istart; i__ <= i__3; ++i__) { + ct[i__] += a[i__ + k * a_dim1] * b[j + k * b_dim1]; + g[i__] += (r__1 = a[i__ + k * a_dim1], abs(r__1)) * (r__2 + = b[j + k * b_dim1], abs(r__2)); +/* L60: */ + } +/* L70: */ + } + } else if (trana && tranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = istop; + for (i__ = istart; i__ <= i__3; ++i__) { + ct[i__] += a[k + i__ * a_dim1] * b[j + k * b_dim1]; + g[i__] += (r__1 = a[k + i__ * a_dim1], abs(r__1)) * (r__2 + = b[j + k * b_dim1], abs(r__2)); +/* L80: */ + } +/* L90: */ + } + } + i__2 = istop; + for (i__ = istart; i__ <= i__2; ++i__) { + ct[i__] = *alpha * ct[i__] + *beta * c__[i__ + j * c_dim1]; + g[i__] = abs(*alpha) * g[i__] + abs(*beta) * (r__1 = c__[i__ + j * + c_dim1], abs(r__1)); +/* L100: */ + } + +/* Compute the error ratio for this result. */ + + *err = 0.f; + i__2 = istop; + for (i__ = istart; i__ <= i__2; ++i__) { + erri = (r__1 = ct[i__] - cc[i__ + j * cc_dim1], abs(r__1)) / *eps; + if (g[i__] != 0.f) { + erri /= g[i__]; + } + *err = f2cmax(*err,erri); + if (*err * sqrt(*eps) >= 1.f) { + goto L130; + } +/* L110: */ + } + +/* L120: */ + } + +/* If the loop completes, all results are at least half accurate. */ + goto L150; + +/* Report fatal error. */ + +L130: + *fatal = TRUE_; + io___466.ciunit = *nout; + s_wsfe(&io___466); + e_wsfe(); + i__1 = istop; + for (i__ = istart; i__ <= i__1; ++i__) { + if (*mv) { + io___467.ciunit = *nout; + s_wsfe(&io___467); + do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&ct[i__], (ftnlen)sizeof(real)); + do_fio(&c__1, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(real) + ); + e_wsfe(); + } else { + io___468.ciunit = *nout; + s_wsfe(&io___468); + do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(real) + ); + do_fio(&c__1, (char *)&ct[i__], (ftnlen)sizeof(real)); + e_wsfe(); + } +/* L140: */ + } + if (*n > 1) { + io___469.ciunit = *nout; + s_wsfe(&io___469); + do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer)); + e_wsfe(); + } + +L150: + return 0; + + +/* End of SMMTCH */ + +} /* smmtch_ */ + +/* Main program alias */ int sblat3_ () { MAIN__ (); return 0; } diff --git a/ctest/c_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..ce66fd4fd3 100644 --- a/ctest/c_zblat3c.c +++ b/ctest/c_zblat3c.c @@ -22,11 +22,14 @@ typedef double doublereal; typedef struct { real r, i; } complex; typedef struct { doublereal r, i; } doublecomplex; #ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} #else static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} #endif #define pCf(z) (*_pCf(z)) @@ -233,13 +236,113 @@ 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 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} /* Common Block Declarations */ @@ -251,7 +354,7 @@ struct { #define infoc_1 infoc_ struct { - char srnamt[12]; + char srnamt[13]; } srnamc_; #define srnamc_1 srnamc_ @@ -260,78 +363,200 @@ struct { static doublecomplex c_b1 = {0.,0.}; static doublecomplex c_b2 = {1.,0.}; +static integer c__9 = 9; static integer c__1 = 1; +static integer c__3 = 3; +static integer c__8 = 8; +static integer c__5 = 5; static integer c__65 = 65; +static integer c__7 = 7; +static integer c__2 = 2; static doublereal c_b92 = 1.; static integer c__6 = 6; static logical c_true = TRUE_; 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[13*10] = "cblas_zgemm " "cblas_zhemm " "cblas_zsymm" + " " "cblas_ztrmm " "cblas_ztrsm " "cblas_zherk " "cblas_zsyrk" + " " "cblas_zher2k " "cblas_zsyr2k " "cblas_zgemmtr"; + + /* Format strings */ + static char fmt_9997[] = "(\002 NUMBER OF VALUES OF \002,a,\002 IS LESS " + "THAN 1 OR GREATER \002,\002THAN \002,i2)"; + static char fmt_9996[] = "(\002 VALUE OF N IS LESS THAN 0 OR GREATER THA" + "N \002,i2)"; + static char fmt_9995[] = "(\002TESTS OF THE COMPLEX*16 LEVEL 3 BL" + "AS\002,//\002 THE F\002,\002OLLOWING PARAMETER VALUES WILL BE US" + "ED:\002)"; + static char fmt_9994[] = "(\002 FOR N \002,9i6)"; + static char fmt_9993[] = "(\002 FOR ALPHA \002,7(\002(\002,f4" + ".1,\002,\002,f4.1,\002) \002,:))"; + static char fmt_9992[] = "(\002 FOR BETA \002,7(\002(\002,f4" + ".1,\002,\002,f4.1,\002) \002,:))"; + static char fmt_9984[] = "(\002 ERROR-CALL MYEXITS WILL NOT BE TESTED" + "\002)"; + static char fmt_9999[] = "(\002 ROUTINES PASS COMPUTATIONAL TESTS IF TES" + "T RATIO IS LES\002,\002S THAN\002,f8.2)"; + static char fmt_10002[] = "(\002 COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS" + " ARE TESTED\002)"; + static char fmt_10001[] = "(\002 ROW-MAJOR DATA LAYOUT IS TESTED\002)"; + static char fmt_10000[] = "(\002 COLUMN-MAJOR DATA LAYOUT IS TESTED\002)"; + static char fmt_9988[] = "(a13,l2)"; + static char fmt_9990[] = "(\002 SUBPROGRAM NAME \002,a13,\002 NOT RECOGN" + "IZED\002,/\002 ******* T\002,\002ESTS ABANDONED *******\002)"; + static char fmt_9998[] = "(\002 RELATIVE MACHINE PRECISION IS TAKEN TO" + " BE\002,1p,e9.1)"; + static char fmt_9989[] = "(\002 ERROR IN ZMMCH - IN-LINE DOT PRODUCTS A" + "RE BEING EVALU\002,\002ATED WRONGLY.\002,/\002 ZMMCH WAS CALLED " + "WITH TRANSA = \002,a1,\002AND TRANSB = \002,a1,/\002 AND RETURNE" + "D SAME = \002,l1,\002 AND \002,\002 ERR = \002,f12.3,\002.\002," + "/\002 THIS MAY BE DUE TO FAULTS IN THE \002,\002ARITHMETIC OR TH" + "E COMPILER.\002,/\002 ******* TESTS ABANDONED \002,\002******" + "*\002)"; + static char fmt_9987[] = "(1x,a13,\002 WAS NOT TESTED\002)"; + static char fmt_9986[] = "(/\002 END OF TESTS\002)"; + static char fmt_9985[] = "(/\002 ******* FATAL ERROR - TESTS ABANDONED *" + "******\002)"; + static char fmt_9991[] = "(\002 AMEND DATA FILE OR INCREASE ARRAY SIZES " + "IN PROGRAM\002,/\002 ******* TESTS ABANDONED *******\002)"; /* System generated locals */ integer i__1, i__2, i__3, i__4, i__5; doublereal d__1; - - /* 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); + olist o__1; + cllist cl__1; /* 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 *); + + /* Fortran I/O blocks */ + static cilist io___2 = { 0, 5, 0, 0, 0 }; + static cilist io___4 = { 0, 5, 0, 0, 0 }; + static cilist io___7 = { 0, 5, 0, 0, 0 }; + static cilist io___9 = { 0, 5, 0, 0, 0 }; + static cilist io___11 = { 0, 5, 0, 0, 0 }; + static cilist io___13 = { 0, 5, 0, 0, 0 }; + static cilist io___15 = { 0, 5, 0, 0, 0 }; + static cilist io___17 = { 0, 5, 0, 0, 0 }; + static cilist io___19 = { 0, 6, 0, fmt_9997, 0 }; + static cilist io___20 = { 0, 5, 0, 0, 0 }; + static cilist io___23 = { 0, 6, 0, fmt_9996, 0 }; + static cilist io___24 = { 0, 5, 0, 0, 0 }; + static cilist io___26 = { 0, 6, 0, fmt_9997, 0 }; + static cilist io___27 = { 0, 5, 0, 0, 0 }; + static cilist io___29 = { 0, 5, 0, 0, 0 }; + static cilist io___31 = { 0, 6, 0, fmt_9997, 0 }; + static cilist io___32 = { 0, 5, 0, 0, 0 }; + static cilist io___34 = { 0, 6, 0, fmt_9995, 0 }; + static cilist io___35 = { 0, 6, 0, fmt_9994, 0 }; + static cilist io___36 = { 0, 6, 0, fmt_9993, 0 }; + static cilist io___37 = { 0, 6, 0, fmt_9992, 0 }; + static cilist io___38 = { 0, 6, 0, 0, 0 }; + static cilist io___39 = { 0, 6, 0, fmt_9984, 0 }; + static cilist io___40 = { 0, 6, 0, 0, 0 }; + static cilist io___41 = { 0, 6, 0, fmt_9999, 0 }; + static cilist io___42 = { 0, 6, 0, 0, 0 }; + static cilist io___45 = { 0, 6, 0, fmt_10002, 0 }; + static cilist io___46 = { 0, 6, 0, fmt_10001, 0 }; + static cilist io___47 = { 0, 6, 0, fmt_10000, 0 }; + static cilist io___48 = { 0, 6, 0, 0, 0 }; + static cilist io___50 = { 0, 5, 1, fmt_9988, 0 }; + static cilist io___53 = { 0, 6, 0, fmt_9990, 0 }; + static cilist io___55 = { 0, 6, 0, fmt_9998, 0 }; + static cilist io___68 = { 0, 6, 0, fmt_9989, 0 }; + static cilist io___69 = { 0, 6, 0, fmt_9989, 0 }; + static cilist io___70 = { 0, 6, 0, fmt_9989, 0 }; + static cilist io___71 = { 0, 6, 0, fmt_9989, 0 }; + static cilist io___73 = { 0, 6, 0, 0, 0 }; + static cilist io___74 = { 0, 6, 0, fmt_9987, 0 }; + static cilist io___75 = { 0, 6, 0, 0, 0 }; + static cilist io___82 = { 0, 6, 0, fmt_9986, 0 }; + static cilist io___83 = { 0, 6, 0, fmt_9985, 0 }; + static cilist io___84 = { 0, 6, 0, fmt_9991, 0 }; + + + /* Test program for the COMPLEX*16 Level 3 Blas. */ /* The program must be driven by a short data file. The first 13 records */ /* of the file are read using list-directed input, the last 9 records */ -/* are read using the format ( 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 +565,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,34 +590,20 @@ 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 line[80]; - - fgets(line,80,stdin); - sscanf(line,"'%s'",snaps); - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&ntra); -#else - sscanf(line,"%d",&ntra); -#endif + s_rsle(&io___2); + do_lio(&c__9, &c__1, snaps, (ftnlen)32); + e_rsle(); + s_rsle(&io___4); + do_lio(&c__3, &c__1, (char *)&ntra, (ftnlen)sizeof(integer)); + e_rsle(); trace = ntra >= 0; if (trace) { -/* o__1.oerr = 0; + o__1.oerr = 0; o__1.ounit = ntra; o__1.ofnmlen = 32; o__1.ofnm = snaps; @@ -401,155 +612,194 @@ static logical c_false = FALSE_; o__1.oacc = 0; o__1.ofm = 0; o__1.oblnk = 0; - f_open(&o__1);*/ + f_open(&o__1); } /* Read the flag that directs rewinding of the snapshot file. */ - fgets(line,80,stdin); - sscanf(line,"%d",&rewi); - rewi = rewi && trace; + s_rsle(&io___7); + do_lio(&c__8, &c__1, (char *)&rewi, (ftnlen)sizeof(logical)); + e_rsle(); + rewi = rewi && trace; /* Read the flag that directs stopping on any failure. */ - fgets(line,80,stdin); - sscanf(line,"%c",&tmpchar); - sfatal=FALSE_; - if (tmpchar=='T')sfatal=TRUE_; + s_rsle(&io___9); + do_lio(&c__8, &c__1, (char *)&sfatal, (ftnlen)sizeof(logical)); + e_rsle(); /* Read the flag that indicates whether error exits are to be tested. */ - fgets(line,80,stdin); - sscanf(line,"%c",&tmpchar); - tsterr=FALSE_; - if (tmpchar=='T')tsterr=TRUE_; + s_rsle(&io___11); + do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical)); + e_rsle(); /* Read the flag that indicates whether row-major data layout to be tested. */ - fgets(line,80,stdin); - sscanf(line,"%d",&layout); + s_rsle(&io___13); + do_lio(&c__3, &c__1, (char *)&layout, (ftnlen)sizeof(integer)); + e_rsle(); /* Read the threshold value of the test ratio */ - fgets(line,80,stdin); - sscanf(line,"%lf",&thresh); + s_rsle(&io___15); + do_lio(&c__5, &c__1, (char *)&thresh, (ftnlen)sizeof(doublereal)); + e_rsle(); /* Read and check the parameter values for the tests. */ /* Values of N */ - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%d",&nidim); -#else - sscanf(line,"%d",&nidim); -#endif + s_rsle(&io___17); + do_lio(&c__3, &c__1, (char *)&nidim, (ftnlen)sizeof(integer)); + e_rsle(); if (nidim < 1 || nidim > 9) { - fprintf(stderr,"NUMBER OF VALUES OF N IS LESS THAN 1 OR GREATER THAN 9"); - goto L220; + s_wsfe(&io___19); + do_fio(&c__1, "N", (ftnlen)1); + do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer)); + e_wsfe(); + goto L220; } - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld %ld %ld %ld %ld %ld %ld %ld %ld",&idim[0],&idim[1],&idim[2], - &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]); -#else - sscanf(line,"%d %d %d %d %d %d %d %d %d",&idim[0],&idim[1],&idim[2], - &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]); -#endif + s_rsle(&io___20); + i__1 = nidim; + for (i__ = 1; i__ <= i__1; ++i__) { + do_lio(&c__3, &c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer)); + } + e_rsle(); i__1 = nidim; for (i__ = 1; i__ <= i__1; ++i__) { - if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) { - 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) { + s_wsfe(&io___23); + do_fio(&c__1, (char *)&c__65, (ftnlen)sizeof(integer)); + e_wsfe(); + goto L220; + } /* L10: */ } /* Values of ALPHA */ - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&nalf); -#else - sscanf(line,"%d",&nalf); -#endif + s_rsle(&io___24); + do_lio(&c__3, &c__1, (char *)&nalf, (ftnlen)sizeof(integer)); + e_rsle(); if (nalf < 1 || nalf > 7) { - fprintf(stderr,"VALUE OF ALPHA IS LESS THAN 0 OR GREATER THAN 7\n"); - goto L220; + s_wsfe(&io___26); + do_fio(&c__1, "ALPHA", (ftnlen)5); + do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer)); + e_wsfe(); + goto L220; } - fgets(line,80,stdin); - sscanf(line,"(%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf)",&alf[0].r,&alf[0].i,&alf[1].r,&alf[1].i,&alf[2].r,&alf[2].i,&alf[3].r,&alf[3].i, - &alf[4].r,&alf[4].i,&alf[5].r,&alf[5].i,&alf[6].r,&alf[6].i); - + s_rsle(&io___27); + i__1 = nalf; + for (i__ = 1; i__ <= i__1; ++i__) { + do_lio(&c__7, &c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof( + doublecomplex)); + } + e_rsle(); /* Values of BETA */ - fgets(line,80,stdin); -#ifdef USE64BITINT - sscanf(line,"%ld",&nbet); -#else - sscanf(line,"%d",&nbet); -#endif - if (nalf < 1 || nbet > 7) { - fprintf(stderr,"VALUE OF BETA IS LESS THAN 0 OR GREATER THAN 7\n"); - goto L220; + s_rsle(&io___29); + do_lio(&c__3, &c__1, (char *)&nbet, (ftnlen)sizeof(integer)); + e_rsle(); + if (nbet < 1 || nbet > 7) { + s_wsfe(&io___31); + do_fio(&c__1, "BETA", (ftnlen)4); + do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer)); + e_wsfe(); + goto L220; + } + s_rsle(&io___32); + i__1 = nbet; + for (i__ = 1; i__ <= i__1; ++i__) { + do_lio(&c__7, &c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof( + doublecomplex)); } - fgets(line,80,stdin); - sscanf(line,"(%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf) (%lf,%lf)",&bet[0].r,&bet[0].i,&bet[1].r,&bet[1].i,&bet[2].r,&bet[2].i,&bet[3].r,&bet[3].i, - &bet[4].r,&bet[4].i,&bet[5].r,&bet[5].i,&bet[6].r,&bet[6].i); + e_rsle(); /* Report values of parameters. */ - printf("TESTS OF THE DOUBLE PRECISION COMPLEX LEVEL 3 BLAS\nTHE FOLLOWING PARAMETER VALUES WILL BE USED:\n"); - printf(" FOR N"); - for (i__ =1; i__ <=nidim;++i__) printf(" %d",idim[i__-1]); - printf("\n"); - printf(" FOR ALPHA"); - for (i__ =1; i__ <=nalf;++i__) printf(" (%lf,%lf)",alf[i__-1].r,alf[i__-1].i); - printf("\n"); - printf(" FOR BETA"); - for (i__ =1; i__ <=nbet;++i__) printf(" (%lf,%lf)",bet[i__-1].r,bet[i__-1].i); - printf("\n"); - + s_wsfe(&io___34); + e_wsfe(); + s_wsfe(&io___35); + i__1 = nidim; + for (i__ = 1; i__ <= i__1; ++i__) { + do_fio(&c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer)); + } + e_wsfe(); + s_wsfe(&io___36); + i__1 = nalf; + for (i__ = 1; i__ <= i__1; ++i__) { + do_fio(&c__2, (char *)&alf[i__ - 1], (ftnlen)sizeof(doublereal)); + } + e_wsfe(); + s_wsfe(&io___37); + i__1 = nbet; + for (i__ = 1; i__ <= i__1; ++i__) { + do_fio(&c__2, (char *)&bet[i__ - 1], (ftnlen)sizeof(doublereal)); + } + e_wsfe(); if (! tsterr) { - printf(" ERROR-EXITS WILL NOT BE TESTED\n"); + s_wsle(&io___38); + e_wsle(); + s_wsfe(&io___39); + e_wsfe(); } - - printf("ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LESS THAN %lf\n",thresh); + s_wsle(&io___40); + e_wsle(); + s_wsfe(&io___41); + do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(doublereal)); + e_wsfe(); + s_wsle(&io___42); + e_wsle(); rorder = FALSE_; corder = FALSE_; if (layout == 2) { rorder = TRUE_; corder = TRUE_; - printf("COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED\n"); + s_wsfe(&io___45); + e_wsfe(); } else if (layout == 1) { rorder = TRUE_; - printf("ROW-MAJOR DATA LAYOUT IS TESTED\n"); + s_wsfe(&io___46); + e_wsfe(); } else if (layout == 0) { corder = TRUE_; - printf("COLUMN-MAJOR DATA LAYOUT IS TESTED\n"); + s_wsfe(&io___47); + e_wsfe(); } + s_wsle(&io___48); + e_wsle(); /* Read names of subroutines and flags which indicate */ /* whether they are to be tested. */ - for (i__ = 1; i__ <= 9; ++i__) { + for (i__ = 1; i__ <= 10; ++i__) { ltest[i__ - 1] = FALSE_; /* L20: */ } L30: - if (! fgets(line,80,stdin)) { - goto L60; - } - i__1 = sscanf(line,"%12c %c",snamet,&tmpchar); - ltestt=FALSE_; - if (tmpchar=='T')ltestt=TRUE_; - if (i__1 < 2) { - goto L60; - } - for (i__ = 1; i__ <= 9; ++i__) { - if (s_cmp(snamet, snames[i__ - 1] , (ftnlen)12, (ftnlen)12) == - 0) { - goto L50; - } + i__1 = s_rsfe(&io___50); + if (i__1 != 0) { + goto L60; + } + i__1 = do_fio(&c__1, snamet, (ftnlen)13); + if (i__1 != 0) { + goto L60; + } + i__1 = do_fio(&c__1, (char *)<estt, (ftnlen)sizeof(logical)); + if (i__1 != 0) { + goto L60; + } + i__1 = e_rsfe(); + if (i__1 != 0) { + goto L60; + } + for (i__ = 1; i__ <= 10; ++i__) { + if (s_cmp(snamet, snames + (i__ - 1) * 13, (ftnlen)13, (ftnlen)13) == + 0) { + goto L50; + } /* L40: */ } - printf("SUBPROGRAM NAME %s NOT RECOGNIZED\n****** TESTS ABANDONED ******\n",snamet); - exit(1); + s_wsfe(&io___53); + do_fio(&c__1, snamet, (ftnlen)13); + e_wsfe(); + s_stop("", (ftnlen)0); L50: ltest[i__ - 1] = ltestt; goto L30; L60: -/* cl__1.cerr = 0; + cl__1.cerr = 0; cl__1.cunit = 5; cl__1.csta = 0; - f_clos(&cl__1);*/ + f_clos(&cl__1); /* Compute EPS (the machine precision). */ @@ -563,7 +813,9 @@ static logical c_false = FALSE_; goto L70; L80: eps += eps; - printf("RELATIVE MACHINE PRECISION IS TAKEN TO BE %9.1g\n",eps); + s_wsfe(&io___55); + do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal)); + e_wsfe(); /* Check the reliability of ZMMCH using exact data. */ @@ -600,28 +852,30 @@ 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"); - printf("ZMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); - printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); - printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); - printf("****** TESTS ABANDONED ******\n"); - exit(1); + s_wsfe(&io___68); + do_fio(&c__1, transa, (ftnlen)1); + do_fio(&c__1, transb, (ftnlen)1); + do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical)); + do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal)); + e_wsfe(); + s_stop("", (ftnlen)0); } *(unsigned char *)transb = 'C'; zmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], & c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal, - &c__6, &c_true, (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"); - printf("ZMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); - printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); - printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); - printf("****** TESTS ABANDONED ******\n"); - exit(1); + s_wsfe(&io___69); + do_fio(&c__1, transa, (ftnlen)1); + do_fio(&c__1, transb, (ftnlen)1); + do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical)); + do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal)); + e_wsfe(); + s_stop("", (ftnlen)0); } i__1 = n; for (j = 1; j <= i__1; ++j) { @@ -644,48 +898,56 @@ 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"); - printf("ZMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); - printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); - printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); - printf("****** TESTS ABANDONED ******\n"); - exit(1); + s_wsfe(&io___70); + do_fio(&c__1, transa, (ftnlen)1); + do_fio(&c__1, transb, (ftnlen)1); + do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical)); + do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal)); + e_wsfe(); + s_stop("", (ftnlen)0); } *(unsigned char *)transb = 'C'; zmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], & c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal, - &c__6, &c_true, (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"); - printf("ZMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb); - printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err); - printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n"); - printf("****** TESTS ABANDONED ******\n"); - exit(1); + s_wsfe(&io___71); + do_fio(&c__1, transa, (ftnlen)1); + do_fio(&c__1, transb, (ftnlen)1); + do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical)); + do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal)); + e_wsfe(); + s_stop("", (ftnlen)0); } /* Test each subroutine in turn. */ - for (isnum = 1; isnum <= 9; ++isnum) { + for (isnum = 1; isnum <= 10; ++isnum) { + s_wsle(&io___73); + e_wsle(); if (! ltest[isnum - 1]) { /* Subprogram is not to be tested. */ - printf("%12s WAS NOT TESTED\n",snames[isnum-1]); + s_wsfe(&io___74); + do_fio(&c__1, snames + (isnum - 1) * 13, (ftnlen)13); + e_wsfe(); } else { - s_copy(srnamc_1.srnamt, snames[isnum - 1], (ftnlen)12, ( - ftnlen)12); + s_copy(srnamc_1.srnamt, snames + (isnum - 1) * 13, (ftnlen)13, ( + ftnlen)13); /* Test error exits. */ if (tsterr) { - cz3chke_(snames[isnum - 1], (ftnlen)12); + cz3chke_(snames + (isnum - 1) * 13); + s_wsle(&io___75); + e_wsle(); } /* Test computations. */ infoc_1.infot = 0; infoc_1.ok = TRUE_; fatal = FALSE_; - switch ((int)isnum) { + switch (isnum) { case 1: goto L140; case 2: goto L150; case 3: goto L150; @@ -695,80 +957,96 @@ 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: if (corder) { - zchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + zchk1_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__0, (ftnlen)12); + cc, cs, ct, g, &c__0); } if (rorder) { - zchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + zchk1_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__1, (ftnlen)12); + cc, cs, ct, g, &c__1); } goto L190; /* Test ZHEMM, 02, ZSYMM, 03. */ L150: if (corder) { - zchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + zchk2_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__0, (ftnlen)12); + cc, cs, ct, g, &c__0); } if (rorder) { - zchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + zchk2_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__1, (ftnlen)12); + cc, cs, ct, g, &c__1); } goto L190; /* Test ZTRMM, 04, ZTRSM, 05. */ L160: if (corder) { - zchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + zchk3_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, & - c__0, (ftnlen)12); + c__0); } if (rorder) { - zchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + zchk3_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, & - c__1, (ftnlen)12); + c__1); } goto L190; /* Test ZHERK, 06, ZSYRK, 07. */ L170: if (corder) { - zchk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + zchk4_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__0, (ftnlen)12); + cc, cs, ct, g, &c__0); } if (rorder) { - zchk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + zchk4_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, - cc, cs, ct, g, &c__1, (ftnlen)12); + cc, cs, ct, g, &c__1); } goto L190; /* Test ZHER2K, 08, ZSYR2K, 09. */ L180: if (corder) { - zchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + zchk5_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, - ct, g, w, &c__0, (ftnlen)12); + ct, g, w, &c__0); } if (rorder) { - zchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra, + zchk5_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, - ct, g, w, &c__1, (ftnlen)12); + ct, g, w, &c__1); + } + goto L190; +/* Test ZGEMMTR, 10 */ +L185: + if (corder) { + zchk6_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__0); + } + if (rorder) { + zchk6_(snames + (isnum - 1) * 13, &eps, &thresh, &c__6, &ntra, + &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, & + nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, + cc, cs, ct, g, &c__1); } goto L190; @@ -779,66 +1057,119 @@ static logical c_false = FALSE_; } /* L200: */ } - printf("\nEND OF TESTS\n"); + s_wsfe(&io___82); + e_wsfe(); goto L230; L210: - printf("\n****** FATAL ERROR - TESTS ABANDONED ******\n"); + s_wsfe(&io___83); + e_wsfe(); goto L230; L220: - printf("AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM\n"); - printf("****** TESTS ABANDONED ******\n"); + s_wsfe(&io___84); + e_wsfe(); L230: if (trace) { -/* cl__1.cerr = 0; + cl__1.cerr = 0; cl__1.cunit = ntra; cl__1.csta = 0; - f_clos(&cl__1);*/ + f_clos(&cl__1); } -/* cl__1.cerr = 0; + cl__1.cerr = 0; cl__1.cunit = 6; cl__1.csta = 0; - f_clos(&cl__1);*/ - exit(0); + f_clos(&cl__1); + s_stop("", (ftnlen)0); + /* End of ZBLAT3. */ + return 0; } /* MAIN__ */ -/* Subroutine */ int zchk1_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublecomplex* alf, integer* nbet, doublecomplex* bet, integer* nmax, doublecomplex* a, doublecomplex* aa, doublecomplex* as, doublecomplex* b, doublecomplex* bb, doublecomplex* bs, doublecomplex* c__, doublecomplex* cc, doublecomplex* cs, doublecomplex* ct, doublereal* g, integer* iorder, 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 */ - static char ich[3+1] = "NTC"; + static char ich[3] = "NTC"; + + /* Format strings */ + static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT " + "TAKEN ON VALID CALL *******\002)"; + static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER" + " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)"; + static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO" + "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR " + " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM" + "BER:\002)"; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8; + alist al__1; /* Local variables */ - static doublecomplex beta; - static integer ldas, ldbs, ldcs; - static logical same, null; - static integer i__, k, m, n; - static doublecomplex alpha; - static logical isame[13], trana, tranb; - extern /* Subroutine */ int zmake_(char*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, logical*, doublecomplex*, ftnlen, ftnlen, ftnlen); - static integer nargs; - extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); - static logical reset; - static integer ia, ib; - extern /* Subroutine */ int zprcn1_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, integer*, doublecomplex*, integer*, integer*, doublecomplex*, integer*, ftnlen, ftnlen, ftnlen); - static integer ma, mb, na, nb, nc, ik, im, in, ks, ms, ns; - extern /* Subroutine */ void czgemm_(integer*, char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen); - static char tranas[1], tranbs[1], transa[1], transb[1]; - static doublereal errmax; - extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen); - static integer ica, icb, laa, lbb, lda, lcc, ldb, ldc; - static doublecomplex als, bls; - static doublereal err; - extern logical lze_(doublecomplex*, doublecomplex*, integer*); + integer i__, k, m, n, ia, ib, ma, mb, na, nb, nc, ik, im, in, ks, ms, ns, + ica, icb, laa, lbb, lda, lcc, ldb, ldc; + doublecomplex als, bls; + doublereal err; + extern logical lze_(doublecomplex *, doublecomplex *, integer *); + doublecomplex beta; + integer ldas, ldbs, ldcs; + logical same, null; + doublecomplex alpha; + logical isame[13], trana, tranb; + extern /* Subroutine */ int zmake_(char *, char *, char *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, integer *, + logical *, doublecomplex *); + integer nargs; + extern /* Subroutine */ int zmmch_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *, doublereal *, doublecomplex *, + integer *, doublereal *, doublereal *, logical *, integer *, + logical *); + logical reset; + extern /* Subroutine */ int zprcn1_(integer *, integer *, char *, integer + *, char *, char *, integer *, integer *, integer *, doublecomplex + *, integer *, integer *, doublecomplex *, integer *), czgemm_(integer *, char *, char *, integer *, + integer *, integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); + char tranas[1], tranbs[1], transa[1], transb[1]; + doublereal errmax; + extern logical lzeres_(char *, char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *); + + /* Fortran I/O blocks */ + static cilist io___128 = { 0, 0, 0, fmt_9994, 0 }; + static cilist io___131 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___133 = { 0, 0, 0, fmt_10000, 0 }; + static cilist io___134 = { 0, 0, 0, fmt_10001, 0 }; + static cilist io___135 = { 0, 0, 0, fmt_10002, 0 }; + static cilist io___136 = { 0, 0, 0, fmt_10003, 0 }; + static cilist io___137 = { 0, 0, 0, fmt_9996, 0 }; + + /* Tests ZGEMM. */ @@ -850,17 +1181,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 +1190,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 +1260,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 +1289,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 +1304,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,23 +1353,23 @@ 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; + al__1.aerr = 0; al__1.aunit = *ntra; - f_rew(&al__1);*/ + f_rew(&al__1); } czgemm_(iorder, transa, transb, &m, &n, &k, & alpha, &aa[1], &lda, &bb[1], &ldb, & - beta, &cc[1], &ldc, (ftnlen)1, ( - ftnlen)1); + 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"); + io___128.ciunit = *nout; + s_wsfe(&io___128); + e_wsfe(); *fatal = TRUE_; goto L120; } @@ -1079,8 +1395,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; @@ -1092,7 +1407,11 @@ static logical c_false = FALSE_; for (i__ = 1; i__ <= i__6; ++i__) { same = same && isame[i__ - 1]; if (! isame[i__ - 1]) { - printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + io___131.ciunit = *nout; + s_wsfe(&io___131); + do_fio(&c__1, (char *)&i__, (ftnlen) + sizeof(integer)); + e_wsfe(); } /* L40: */ } @@ -1109,8 +1428,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,44 +1465,76 @@ static logical c_false = FALSE_; if (errmax < *thresh) { if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___133.ciunit = *nout; + s_wsfe(&io___133); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___134.ciunit = *nout; + s_wsfe(&io___134); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } } else { if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___135.ciunit = *nout; + s_wsfe(&io___135); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal)); + e_wsfe(); } if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___136.ciunit = *nout; + s_wsfe(&io___136); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal)); + e_wsfe(); } } goto L130; L120: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + io___137.ciunit = *nout; + s_wsfe(&io___137); + do_fio(&c__1, sname, (ftnlen)13); + e_wsfe(); zprcn1_(nout, &nc, sname, iorder, transa, transb, &m, &n, &k, &alpha, & - lda, &ldb, &beta, &ldc, (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) { + /* Format strings */ + static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002," + "a14,\002,\002,a14,\002,\002)"; + static char fmt_9994[] = "(10x,3(i3,\002,\002),\002 (\002,f4.1,\002,\002" + ",f4.1,\002) , A,\002,i3,\002, B,\002,i3,\002, (\002,f4.1,\002" + ",\002,f4.1,\002) , C,\002,i3,\002).\002)"; + /* Local variables */ - static char crc[14], cta[14], ctb[14]; + char crc[14], cta[14], ctb[14]; + + /* Fortran I/O blocks */ + static cilist io___141 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___142 = { 0, 0, 0, fmt_9994, 0 }; + if (*(unsigned char *)transa == 'N') { s_copy(cta, " CblasNoTrans", (ftnlen)14, (ftnlen)14); @@ -1205,52 +1555,120 @@ static logical c_false = FALSE_; } else { s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cta,ctb); - printf("%d %d %d (%4.1lf,%4.1lf) , A, %d, B, %d, (%4.1lf,%4.1lf) , C, %d.\n",*m,*n,*k,alpha->r,alpha->i,*lda,*ldb,beta->r,beta->i,*ldc); - -return 0; + io___141.ciunit = *nout; + s_wsfe(&io___141); + do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer)); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, crc, (ftnlen)14); + do_fio(&c__1, cta, (ftnlen)14); + do_fio(&c__1, ctb, (ftnlen)14); + e_wsfe(); + io___142.ciunit = *nout; + s_wsfe(&io___142); + do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(doublereal)); + do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(doublereal)); + do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer)); + e_wsfe(); + return 0; } /* zprcn1_ */ -/* Subroutine */ int zchk2_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublecomplex* alf, integer* nbet, doublecomplex* bet, integer* nmax, doublecomplex* a, doublecomplex* aa, doublecomplex* as, doublecomplex* b, doublecomplex* bb, doublecomplex* bs, doublecomplex* c__, doublecomplex* cc, doublecomplex* cs, doublecomplex* ct, doublereal* g, integer* iorder, 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 */ - static char ichs[2+1] = "LR"; - static char ichu[2+1] = "UL"; + static char ichs[2] = "LR"; + static char ichu[2] = "UL"; + + /* Format strings */ + static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT " + "TAKEN ON VALID CALL *******\002)"; + static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER" + " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)"; + static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO" + "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR " + " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM" + "BER:\002)"; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7; + alist al__1; /* Local variables */ - static doublecomplex beta; - static integer ldas, ldbs, ldcs; - static logical same; - static char side[1]; - static logical isconj, left, null; - static char uplo[1]; - static integer i__, m, n; - static doublecomplex alpha; - static logical isame[13]; - static char sides[1]; - extern /* Subroutine */ int zmake_(char*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, logical*, doublecomplex*, ftnlen, ftnlen, ftnlen); - static integer nargs; - extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); - static logical reset; - static char uplos[1]; - static integer ia, ib; - extern /* Subroutine */ int zprcn2_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublecomplex*, integer*, integer*, doublecomplex*, integer*, ftnlen, ftnlen, ftnlen); - static integer na, nc, im, in, ms, ns; - extern /* Subroutine */ void czhemm_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen); - static doublereal errmax; - extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen); - extern /* Subroutine */ void czsymm_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen); - static integer laa, lbb, lda, lcc, ldb, ldc, ics; - static doublecomplex als, bls; - static integer icu; - static doublereal err; - extern logical lze_(doublecomplex*, doublecomplex*, integer*); + integer i__, m, n, ia, ib, na, nc, im, in, ms, ns, laa, lbb, lda, lcc, + ldb, ldc, ics; + doublecomplex als, bls; + integer icu; + doublereal err; + extern logical lze_(doublecomplex *, doublecomplex *, integer *); + doublecomplex beta; + integer ldas, ldbs, ldcs; + logical same; + char side[1]; + logical conj, left, null; + char uplo[1]; + doublecomplex alpha; + logical isame[13]; + char sides[1]; + extern /* Subroutine */ int zmake_(char *, char *, char *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, integer *, + logical *, doublecomplex *); + integer nargs; + extern /* Subroutine */ int zmmch_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *, doublereal *, doublecomplex *, + integer *, doublereal *, doublereal *, logical *, integer *, + logical *); + logical reset; + char uplos[1]; + extern /* Subroutine */ int zprcn2_(integer *, integer *, char *, integer + *, char *, char *, integer *, integer *, doublecomplex *, integer + *, integer *, doublecomplex *, integer *), + czhemm_(integer *, char *, char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *); + doublereal errmax; + extern logical lzeres_(char *, char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *); + extern /* Subroutine */ int czsymm_(integer *, char *, char *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); + + /* Fortran I/O blocks */ + static cilist io___181 = { 0, 0, 0, fmt_9994, 0 }; + static cilist io___184 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___186 = { 0, 0, 0, fmt_10000, 0 }; + static cilist io___187 = { 0, 0, 0, fmt_10001, 0 }; + static cilist io___188 = { 0, 0, 0, fmt_10002, 0 }; + static cilist io___189 = { 0, 0, 0, fmt_10003, 0 }; + static cilist io___190 = { 0, 0, 0, fmt_9996, 0 }; + + /* Tests ZHEMM and ZSYMM. */ @@ -1262,17 +1680,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,22 +1689,21 @@ 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 */ -/* .. Executable Statements .. */ - isconj = s_cmp(sname + 7, "he", (ftnlen)2, (ftnlen)2) == 0; + conj = s_cmp(sname + 7, "he", (ftnlen)2, (ftnlen)2) == 0; nargs = 12; nc = 0; @@ -1336,7 +1742,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 +1770,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 +1785,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,28 +1831,30 @@ 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) { -/* al__1.aerr = 0; + al__1.aerr = 0; al__1.aunit = *ntra; - f_rew(&al__1);*/ + f_rew(&al__1); } - if (isconj) { + if (conj) { 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. */ if (! infoc_1.ok) { - printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + io___181.ciunit = *nout; + s_wsfe(&io___181); + e_wsfe(); *fatal = TRUE_; goto L110; } @@ -1471,7 +1877,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; @@ -1483,7 +1889,11 @@ return 0; 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__); + io___184.ciunit = *nout; + s_wsfe(&io___184); + do_fio(&c__1, (char *)&i__, (ftnlen) + sizeof(integer)); + e_wsfe(); } /* L40: */ } @@ -1501,15 +1911,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,44 +1951,76 @@ return 0; if (errmax < *thresh) { if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___186.ciunit = *nout; + s_wsfe(&io___186); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___187.ciunit = *nout; + s_wsfe(&io___187); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } } else { if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___188.ciunit = *nout; + s_wsfe(&io___188); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal)); + e_wsfe(); } if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___189.ciunit = *nout; + s_wsfe(&io___189); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal)); + e_wsfe(); } } goto L120; L110: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + io___190.ciunit = *nout; + s_wsfe(&io___190); + do_fio(&c__1, sname, (ftnlen)13); + e_wsfe(); zprcn2_(nout, &nc, sname, iorder, side, uplo, &m, &n, &alpha, &lda, &ldb, - &beta, &ldc, (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) { + /* Format strings */ + static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002," + "a14,\002,\002,a14,\002,\002)"; + static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002" + ",f4.1,\002), A,\002,i3,\002, B,\002,i3,\002, (\002,f4.1,\002," + "\002,f4.1,\002), \002,\002C,\002,i3,\002).\002)"; + /* Local variables */ - static char cs[14], cu[14], crc[14]; + char cs[14], cu[14], crc[14]; + + /* Fortran I/O blocks */ + static cilist io___194 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___195 = { 0, 0, 0, fmt_9994, 0 }; + if (*(unsigned char *)side == 'L') { s_copy(cs, " CblasLeft", (ftnlen)14, (ftnlen)14); @@ -1597,57 +2037,121 @@ return 0; } else { s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cs,cu); - printf("%d %d (%4.1lf,%4.1lf) , A, %d, B, %d, (%4.1lf,%4.1lf) , C, %d.\n",*m,*n,alpha->r,alpha->i,*lda,*ldb,beta->r,beta->i,*ldc); - -return 0; + io___194.ciunit = *nout; + s_wsfe(&io___194); + do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer)); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, crc, (ftnlen)14); + do_fio(&c__1, cs, (ftnlen)14); + do_fio(&c__1, cu, (ftnlen)14); + e_wsfe(); + io___195.ciunit = *nout; + s_wsfe(&io___195); + do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(doublereal)); + do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(doublereal)); + do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer)); + e_wsfe(); + return 0; } /* zprcn2_ */ -/* Subroutine */ int zchk3_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublecomplex* alf, integer* nmax, doublecomplex* a, doublecomplex* aa, doublecomplex* as, doublecomplex* b, doublecomplex* bb, doublecomplex* bs, doublecomplex* ct, doublereal* g, doublecomplex* c__, integer* iorder, 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 */ - static char ichu[2+1] = "UL"; - static char icht[3+1] = "NTC"; - static char ichd[2+1] = "UN"; - static char ichs[2+1] = "LR"; + static char ichu[2] = "UL"; + static char icht[3] = "NTC"; + static char ichd[2] = "UN"; + static char ichs[2] = "LR"; + + /* Format strings */ + static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT " + "TAKEN ON VALID CALL *******\002)"; + static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER" + " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)"; + static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO" + "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR " + " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM" + "BER:\002)"; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7; doublecomplex z__1; + alist al__1; /* Local variables */ - static char diag[1]; - static integer ldas, ldbs; - static logical same; - static char side[1]; - static logical left, null; - static char uplo[1]; - static integer i__, j, m, n; - static doublecomplex alpha; - static char diags[1]; - static logical isame[13]; - static char sides[1]; - extern /* Subroutine */ int zmake_(char*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, logical*, doublecomplex*, ftnlen, ftnlen, ftnlen); - static integer nargs; - extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); - static logical reset; - static char uplos[1]; - static integer ia, na; - extern /* Subroutine */ int zprcn3_(integer*, integer*, char*, integer*, char*, char*, char*, char*, integer*, integer*, doublecomplex*, integer*, integer*, ftnlen, ftnlen, ftnlen, ftnlen, ftnlen); - static integer nc, im, in, ms, ns; - static char tranas[1], transa[1]; - static doublereal errmax; - extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen); - extern /* Subroutine */ void cztrmm_(integer*, char*, char*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, ftnlen, ftnlen, ftnlen, ftnlen); - extern /* Subroutine */ void cztrsm_(integer*, char*, char*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, ftnlen, ftnlen, ftnlen, ftnlen); - static integer laa, icd, lbb, lda, ldb, ics; - static doublecomplex als; - static integer ict, icu; - static doublereal err; - extern logical lze_(doublecomplex*, doublecomplex*, integer*); + integer i__, j, m, n, ia, na, nc, im, in, ms, ns, laa, icd, lbb, lda, ldb, + ics; + doublecomplex als; + integer ict, icu; + doublereal err; + extern logical lze_(doublecomplex *, doublecomplex *, integer *); + char diag[1]; + integer ldas, ldbs; + logical same; + char side[1]; + logical left, null; + char uplo[1]; + doublecomplex alpha; + char diags[1]; + logical isame[13]; + char sides[1]; + extern /* Subroutine */ int zmake_(char *, char *, char *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, integer *, + logical *, doublecomplex *); + integer nargs; + extern /* Subroutine */ int zmmch_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *, doublereal *, doublecomplex *, + integer *, doublereal *, doublereal *, logical *, integer *, + logical *); + logical reset; + char uplos[1]; + extern /* Subroutine */ int zprcn3_(integer *, integer *, char *, integer + *, char *, char *, char *, char *, integer *, integer *, + doublecomplex *, integer *, integer *); + char tranas[1], transa[1]; + doublereal errmax; + extern logical lzeres_(char *, char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *); + extern /* Subroutine */ int cztrmm_(integer *, char *, char *, char *, + char *, integer *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *, integer *), cztrsm_(integer *, char *, char *, char *, char *, + integer *, integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *); + + /* Fortran I/O blocks */ + static cilist io___236 = { 0, 0, 0, fmt_9994, 0 }; + static cilist io___239 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___241 = { 0, 0, 0, fmt_10000, 0 }; + static cilist io___242 = { 0, 0, 0, fmt_10001, 0 }; + static cilist io___243 = { 0, 0, 0, fmt_10002, 0 }; + static cilist io___244 = { 0, 0, 0, fmt_10003, 0 }; + static cilist io___245 = { 0, 0, 0, fmt_9996, 0 }; + + /* Tests ZTRMM and ZTRSM. */ @@ -1659,38 +2163,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 +2258,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; @@ -1818,42 +2308,42 @@ return 0; zprcn3_(ntra, &nc, sname, iorder, side, uplo, transa, diag, &m, &n, &alpha, &lda, &ldb, ( - ftnlen)12, (ftnlen)1, (ftnlen) + ftnlen)13, (ftnlen)1, (ftnlen) 1, (ftnlen)1, (ftnlen)1); } if (*rewi) { -/* al__1.aerr = 0; + al__1.aerr = 0; al__1.aunit = *ntra; - f_rew(&al__1);*/ + f_rew(&al__1); } 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) + ftnlen)13, (ftnlen)1, (ftnlen) 1, (ftnlen)1, (ftnlen)1); } if (*rewi) { -/* al__1.aerr = 0; + al__1.aerr = 0; al__1.aunit = *ntra; - f_rew(&al__1);*/ + f_rew(&al__1); } 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. */ if (! infoc_1.ok) { - printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + io___236.ciunit = *nout; + s_wsfe(&io___236); + e_wsfe(); *fatal = TRUE_; goto L150; } @@ -1878,8 +2368,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; @@ -1891,7 +2380,11 @@ return 0; for (i__ = 1; i__ <= i__4; ++i__) { same = same && isame[i__ - 1]; if (! isame[i__ - 1]) { - printf(" ******* FATAL ERROR - PARAMETER NUMBER %d WAS CHANGED INCORRECTLY *******\n",i__); + io___239.ciunit = *nout; + s_wsfe(&io___239); + do_fio(&c__1, (char *)&i__, (ftnlen) + sizeof(integer)); + e_wsfe(); } /* L50: */ } @@ -1922,8 +2415,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 +2449,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 +2457,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,48 +2494,77 @@ return 0; if (errmax < *thresh) { if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___241.ciunit = *nout; + s_wsfe(&io___241); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___242.ciunit = *nout; + s_wsfe(&io___242); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } } else { if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___243.ciunit = *nout; + s_wsfe(&io___243); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal)); + e_wsfe(); } if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___244.ciunit = *nout; + s_wsfe(&io___244); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal)); + e_wsfe(); } } goto L160; L150: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); + io___245.ciunit = *nout; + s_wsfe(&io___245); + do_fio(&c__1, sname, (ftnlen)13); + e_wsfe(); if (*trace) { zprcn3_(ntra, &nc, sname, iorder, side, uplo, transa, diag, &m, &n, & - alpha, &lda, &ldb, (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) { + /* Format strings */ + static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002," + "a14,\002,\002,a14,\002,\002)"; + static char fmt_9994[] = "(10x,2(a14,\002,\002),2(i3,\002,\002),\002 " + "(\002,f4.1,\002,\002,f4.1,\002), A,\002,i3,\002, B,\002,i3,\002)." + "\002)"; /* Local variables */ - static char ca[14], cd[14], cs[14], cu[14], crc[14]; + char ca[14], cd[14], cs[14], cu[14], crc[14]; + + /* Fortran I/O blocks */ + static cilist io___251 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___252 = { 0, 0, 0, fmt_9994, 0 }; + if (*(unsigned char *)side == 'L') { s_copy(cs, " CblasLeft", (ftnlen)14, (ftnlen)14); @@ -2074,61 +2593,130 @@ return 0; } else { s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cs,cu); - printf(" %s %s %d %d (%4.1lf,%4.1lf) A %d B %d\n",ca,cd,*m,*n,alpha->r,alpha->i,*lda,*ldb); - -return 0; + io___251.ciunit = *nout; + s_wsfe(&io___251); + do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer)); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, crc, (ftnlen)14); + do_fio(&c__1, cs, (ftnlen)14); + do_fio(&c__1, cu, (ftnlen)14); + e_wsfe(); + io___252.ciunit = *nout; + s_wsfe(&io___252); + do_fio(&c__1, ca, (ftnlen)14); + do_fio(&c__1, cd, (ftnlen)14); + do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(doublereal)); + do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer)); + e_wsfe(); + return 0; } /* zprcn3_ */ -/* Subroutine */ int zchk4_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublecomplex* alf, integer* nbet, doublecomplex* bet, integer* nmax, doublecomplex* a, doublecomplex* aa, doublecomplex* as, doublecomplex* b, doublecomplex* bb, doublecomplex* bs, doublecomplex* c__, doublecomplex* cc, doublecomplex* cs, doublecomplex* ct, doublereal* g, integer* iorder, 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 */ - static char icht[2+1] = "NC"; - static char ichu[2+1] = "UL"; + static char icht[2] = "NC"; + static char ichu[2] = "UL"; + + /* Format strings */ + static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT " + "TAKEN ON VALID CALL *******\002)"; + static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER" + " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)"; + static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO" + "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR " + " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN" + " \002,i3)"; + static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM" + "BER:\002)"; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7; doublecomplex z__1; + alist al__1; /* Local variables */ - static doublecomplex beta; - static integer ldas, ldcs; - static logical same, isconj; - static doublecomplex bets; - static doublereal rals; - static logical tran, null; - static char uplo[1]; - static integer i__, j, k, n; - static doublecomplex alpha; - static doublereal rbeta; - static logical isame[13]; - extern /* Subroutine */ int zmake_(char*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, logical*, doublecomplex*, ftnlen, ftnlen, ftnlen); - static integer nargs; - extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); - static doublereal rbets; - static logical reset; - static char trans[1]; - static logical upper; - static char uplos[1]; - static integer ia, ib, jc, ma, na; - extern /* Subroutine */ int zprcn4_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, ftnlen, ftnlen, ftnlen); - static integer nc; - extern /* Subroutine */ int zprcn6_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen); - static integer ik, in, jj, lj, ks, ns; - static doublereal ralpha; - extern /* Subroutine */ int czherk_(integer*, char*, char*, integer*, integer*, doublereal*, doublecomplex*, integer*, doublereal*, doublecomplex*, integer*, ftnlen, ftnlen); - static doublereal errmax; - extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen); - static char transs[1], transt[1]; - extern /* Subroutine */ int czsyrk_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen); - static integer laa, lda, lcc, ldc; - static doublecomplex als; - static integer ict, icu; - static doublereal err; - extern logical lze_(doublecomplex*, doublecomplex*, integer*); + integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa, + lda, lcc, ldc; + doublecomplex als; + integer ict, icu; + doublereal err; + extern logical lze_(doublecomplex *, doublecomplex *, integer *); + doublecomplex beta; + integer ldas, ldcs; + logical same, conj; + doublecomplex bets; + doublereal rals; + logical tran, null; + char uplo[1]; + doublecomplex alpha; + doublereal rbeta; + logical isame[13]; + extern /* Subroutine */ int zmake_(char *, char *, char *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, integer *, + logical *, doublecomplex *); + integer nargs; + extern /* Subroutine */ int zmmch_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *, doublereal *, doublecomplex *, + integer *, doublereal *, doublereal *, logical *, integer *, + logical *); + doublereal rbets; + logical reset; + char trans[1]; + logical upper; + char uplos[1]; + extern /* Subroutine */ int zprcn4_(integer *, integer *, char *, integer + *, char *, char *, integer *, integer *, doublecomplex *, integer + *, doublecomplex *, integer *), zprcn6_( + integer *, integer *, char *, integer *, char *, char *, integer * + , integer *, doublereal *, integer *, doublereal *, integer *); + doublereal ralpha; + extern /* Subroutine */ int czherk_(integer *, char *, char *, integer *, + integer *, doublereal *, doublecomplex *, integer *, doublereal *, + doublecomplex *, integer *); + doublereal errmax; + extern logical lzeres_(char *, char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *); + char transs[1], transt[1]; + extern /* Subroutine */ int czsyrk_(integer *, char *, char *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, doublecomplex *, integer *); + + /* Fortran I/O blocks */ + static cilist io___294 = { 0, 0, 0, fmt_9992, 0 }; + static cilist io___297 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___304 = { 0, 0, 0, fmt_10000, 0 }; + static cilist io___305 = { 0, 0, 0, fmt_10001, 0 }; + static cilist io___306 = { 0, 0, 0, fmt_10002, 0 }; + static cilist io___307 = { 0, 0, 0, fmt_10003, 0 }; + static cilist io___308 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___309 = { 0, 0, 0, fmt_9996, 0 }; + + /* Tests ZHERK and ZSYRK. */ @@ -2140,17 +2728,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,29 +2737,26 @@ 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 */ -/* .. Executable Statements .. */ - isconj = s_cmp(sname + 7, "he", (ftnlen)2, (ftnlen)2) == 0; + conj = s_cmp(sname + 7, "he", (ftnlen)2, (ftnlen)2) == 0; nargs = 10; nc = 0; reset = TRUE_; errmax = 0.; - rals = 1.; - rbets = 1.; i__1 = *nidim; for (in = 1; in <= i__1; ++in) { @@ -2205,7 +2779,7 @@ return 0; for (ict = 1; ict <= 2; ++ict) { *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1]; tran = *(unsigned char *)trans == 'C'; - if (tran && ! isconj) { + if (tran && ! conj) { *(unsigned char *)trans = 'T'; } if (tran) { @@ -2229,7 +2803,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]; @@ -2239,7 +2813,7 @@ return 0; for (ia = 1; ia <= i__3; ++ia) { i__4 = ia; alpha.r = alf[i__4].r, alpha.i = alf[i__4].i; - if (isconj) { + if (conj) { ralpha = alpha.r; z__1.r = ralpha, z__1.i = 0.; alpha.r = z__1.r, alpha.i = z__1.i; @@ -2249,22 +2823,22 @@ return 0; for (ib = 1; ib <= i__4; ++ib) { i__5 = ib; beta.r = bet[i__5].r, beta.i = bet[i__5].i; - if (isconj) { + if (conj) { rbeta = beta.r; z__1.r = rbeta, z__1.i = 0.; beta.r = z__1.r, beta.i = z__1.i; } null = n <= 0; - if (isconj) { - null = null ||( (k <= 0 || ralpha == 0.) && - rbeta == 1.); + if (conj) { + null = null || (k <= 0 || ralpha == 0.) && + rbeta == 1.; } /* Generate the matrix C. */ zmake_(sname + 7, uplo, " ", &n, &n, &c__[ c_offset], nmax, &cc[1], &ldc, &reset, & - c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)1); + c_b1); ++nc; @@ -2275,7 +2849,7 @@ return 0; trans; ns = n; ks = k; - if (isconj) { + if (conj) { rals = ralpha; } else { als.r = alpha.r, als.i = alpha.i; @@ -2289,7 +2863,7 @@ return 0; /* L10: */ } ldas = lda; - if (isconj) { + if (conj) { rbets = rbeta; } else { bets.r = beta.r, bets.i = beta.i; @@ -2306,42 +2880,40 @@ return 0; /* Call the subroutine. */ - if (isconj) { + if (conj) { 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; + al__1.aerr = 0; al__1.aunit = *ntra; - f_rew(&al__1);*/ + f_rew(&al__1); } czherk_(iorder, uplo, trans, &n, &k, &ralpha, - &aa[1], &lda, &rbeta, &cc[1], &ldc, ( - 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; + al__1.aerr = 0; al__1.aunit = *ntra; - f_rew(&al__1);*/ + f_rew(&al__1); } czsyrk_(iorder, uplo, trans, &n, &k, &alpha, & - aa[1], &lda, &beta, &cc[1], &ldc, ( - ftnlen)1, (ftnlen)1); + aa[1], &lda, &beta, &cc[1], &ldc); } /* Check if error-exit was taken incorrectly. */ if (! infoc_1.ok) { - printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n"); + io___294.ciunit = *nout; + s_wsfe(&io___294); + e_wsfe(); *fatal = TRUE_; goto L120; } @@ -2354,7 +2926,7 @@ return 0; char *)trans; isame[2] = ns == n; isame[3] = ks == k; - if (isconj) { + if (conj) { isame[4] = rals == ralpha; } else { isame[4] = als.r == alpha.r && als.i == @@ -2362,7 +2934,7 @@ return 0; } isame[5] = lze_(&as[1], &aa[1], &laa); isame[6] = ldas == lda; - if (isconj) { + if (conj) { isame[7] = rbets == rbeta; } else { isame[7] = bets.r == beta.r && bets.i == @@ -2372,8 +2944,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; @@ -2385,7 +2956,11 @@ return 0; 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__); + io___297.ciunit = *nout; + s_wsfe(&io___297); + do_fio(&c__1, (char *)&i__, (ftnlen) + sizeof(integer)); + e_wsfe(); } /* L30: */ } @@ -2398,7 +2973,7 @@ return 0; /* Check the result column by column. */ - if (isconj) { + if (conj) { *(unsigned char *)transt = 'C'; } else { *(unsigned char *)transt = 'T'; @@ -2420,8 +2995,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 +3003,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,57 +3044,89 @@ return 0; if (errmax < *thresh) { if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___304.ciunit = *nout; + s_wsfe(&io___304); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___305.ciunit = *nout; + s_wsfe(&io___305); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } } else { if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___306.ciunit = *nout; + s_wsfe(&io___306); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal)); + e_wsfe(); } if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___307.ciunit = *nout; + s_wsfe(&io___307); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal)); + e_wsfe(); } } goto L130; L110: if (n > 1) { - printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j); + io___308.ciunit = *nout; + s_wsfe(&io___308); + do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer)); + e_wsfe(); } L120: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); - if (isconj) { + io___309.ciunit = *nout; + s_wsfe(&io___309); + do_fio(&c__1, sname, (ftnlen)13); + e_wsfe(); + if (conj) { zprcn6_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &ralpha, &lda, - &rbeta, &ldc, (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) { + /* Format strings */ + static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002," + "\002))"; + static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002" + ",f4.1,\002), A,\002,i3,\002, (\002,f4.1,\002,\002,f4.1,\002), C" + ",\002,i3,\002).\002)"; + /* Local variables */ - static char ca[14], cu[14], crc[14]; + char ca[14], cu[14], crc[14]; + + /* Fortran I/O blocks */ + static cilist io___313 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___314 = { 0, 0, 0, fmt_9994, 0 }; + if (*(unsigned char *)uplo == 'U') { s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); @@ -2539,19 +3145,45 @@ return 0; } else { s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); - printf("( %d %d (%4.1lf,%4.1lf) A %d (%4.1lf,%4.1lf) C %d\n",*n,*k,alpha->r,alpha->i,*lda,beta->r,beta->i,*ldc); - -return 0; + io___313.ciunit = *nout; + s_wsfe(&io___313); + do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer)); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, crc, (ftnlen)14); + do_fio(&c__1, cu, (ftnlen)14); + do_fio(&c__1, ca, (ftnlen)14); + e_wsfe(); + io___314.ciunit = *nout; + s_wsfe(&io___314); + do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(doublereal)); + do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(doublereal)); + do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer)); + e_wsfe(); + return 0; } /* zprcn4_ */ -/* Subroutine */ int zprcn6_(integer* nout, integer* nc, char* sname, integer* iorder, char* uplo, char* transa, integer* n, integer* k, doublereal* alpha, integer* lda, doublereal* beta, integer* ldc, 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) { + /* Format strings */ + static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002," + "\002))"; + static char fmt_9994[] = "(10x,2(i3,\002,\002),f4.1,\002, A,\002,i3" + ",\002,\002,f4.1,\002, C,\002,i3,\002).\002)"; /* Local variables */ - static char ca[14], cu[14], crc[14]; + char ca[14], cu[14], crc[14]; + + /* Fortran I/O blocks */ + static cilist io___318 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___319 = { 0, 0, 0, fmt_9994, 0 }; + if (*(unsigned char *)uplo == 'U') { s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); @@ -2570,58 +3202,129 @@ return 0; } else { s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); - printf("( %d %d %4.1lf A %d %4.1lf C %d\n",*n,*k,*alpha,*lda,*beta,*ldc); - -return 0; + io___318.ciunit = *nout; + s_wsfe(&io___318); + do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer)); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, crc, (ftnlen)14); + do_fio(&c__1, cu, (ftnlen)14); + do_fio(&c__1, ca, (ftnlen)14); + e_wsfe(); + io___319.ciunit = *nout; + s_wsfe(&io___319); + do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(doublereal)); + do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(doublereal)); + do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer)); + e_wsfe(); + return 0; } /* zprcn6_ */ -/* Subroutine */ int zchk5_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublecomplex* alf, integer* nbet, doublecomplex* bet, integer* nmax, doublecomplex* ab, doublecomplex* aa, doublecomplex* as, doublecomplex* bb, doublecomplex* bs, doublecomplex* c__, doublecomplex* cc, doublecomplex* cs, doublecomplex* ct, doublereal* g, doublecomplex* w, integer* iorder, 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 */ - static char icht[2+1] = "NC"; - static char ichu[2+1] = "UL"; + static char icht[2] = "NC"; + static char ichu[2] = "UL"; + + /* Format strings */ + static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT " + "TAKEN ON VALID CALL *******\002)"; + static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER" + " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)"; + static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO" + "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR " + " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN" + " \002,i3)"; + static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM" + "BER:\002)"; /* System generated locals */ integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8; doublecomplex z__1, z__2; + alist al__1; /* Local variables */ - static integer jjab; - static doublecomplex beta; - static integer ldas, ldbs, ldcs; - static logical same, isconj; - static doublecomplex bets; - static logical tran, null; - static char uplo[1]; - static integer i__, j, k, n; - static doublecomplex alpha; - static doublereal rbeta; - static logical isame[13]; - extern /* Subroutine */ int zmake_(char*, char*, char*, integer*, integer*, doublecomplex*, integer*, doublecomplex*, integer*, logical*, doublecomplex*, ftnlen, ftnlen, ftnlen); - static integer nargs; - extern /* Subroutine */ int zmmch_(char*, char*, integer*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, doublereal*, doublecomplex*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen); - static doublereal rbets; - static logical reset; - static char trans[1]; - static logical upper; - static char uplos[1]; - static integer ia, ib, jc, ma, na, nc; - extern /* Subroutine */ int zprcn5_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublecomplex*, integer*, integer*, doublecomplex*, integer*, ftnlen, ftnlen, ftnlen); - extern /* Subroutine */ int zprcn7_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublecomplex*, integer*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen); - static integer ik, in, jj, lj, ks, ns; - static doublereal errmax; - extern logical lzeres_(char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen); - static char transs[1], transt[1]; - extern /* Subroutine */ int czher2k_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublereal*, doublecomplex*, integer*, ftnlen, ftnlen); - static integer laa, lbb, lda, lcc, ldb, ldc; - static doublecomplex als; - static integer ict, icu; - extern /* Subroutine */ int czsyr2k_(integer*, char*, char*, integer*, integer*, doublecomplex*, doublecomplex*, integer*, doublecomplex*, integer*, doublecomplex*, doublecomplex*, integer*, ftnlen, ftnlen); - static doublereal err; - extern logical lze_(doublecomplex*, doublecomplex*, integer*); + integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa, + lbb, lda, lcc, ldb, ldc; + doublecomplex als; + integer ict, icu; + doublereal err; + extern logical lze_(doublecomplex *, doublecomplex *, integer *); + integer jjab; + doublecomplex beta; + integer ldas, ldbs, ldcs; + logical same, conj; + doublecomplex bets; + logical tran, null; + char uplo[1]; + doublecomplex alpha; + doublereal rbeta; + logical isame[13]; + extern /* Subroutine */ int zmake_(char *, char *, char *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, integer *, + logical *, doublecomplex *); + integer nargs; + extern /* Subroutine */ int zmmch_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *, doublereal *, doublecomplex *, + integer *, doublereal *, doublereal *, logical *, integer *, + logical *); + doublereal rbets; + logical reset; + char trans[1]; + logical upper; + char uplos[1]; + extern /* Subroutine */ int zprcn5_(integer *, integer *, char *, integer + *, char *, char *, integer *, integer *, doublecomplex *, integer + *, integer *, doublecomplex *, integer *), + zprcn7_(integer *, integer *, char *, integer *, char *, char *, + integer *, integer *, doublecomplex *, integer *, integer *, + doublereal *, integer *); + doublereal errmax; + extern logical lzeres_(char *, char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *); + char transs[1], transt[1]; + extern /* Subroutine */ int czher2k_(integer *, char *, char *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublereal *, doublecomplex *, + integer *), czsyr2k_(integer *, char *, char *, + integer *, integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); + + /* Fortran I/O blocks */ + static cilist io___362 = { 0, 0, 0, fmt_9992, 0 }; + static cilist io___365 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___373 = { 0, 0, 0, fmt_10000, 0 }; + static cilist io___374 = { 0, 0, 0, fmt_10001, 0 }; + static cilist io___375 = { 0, 0, 0, fmt_10002, 0 }; + static cilist io___376 = { 0, 0, 0, fmt_10003, 0 }; + static cilist io___377 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___378 = { 0, 0, 0, fmt_9996, 0 }; + + /* Tests ZHER2K and ZSYR2K. */ @@ -2633,17 +3336,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 +3346,7 @@ return 0; --cs; --cc; c_dim1 = *nmax; - c_offset = 1 + c_dim1 * 1; + c_offset = 1 + c_dim1; c__ -= c_offset; --bs; --bb; @@ -2663,8 +3355,7 @@ return 0; --ab; /* Function Body */ -/* .. Executable Statements .. */ - isconj = s_cmp(sname + 7, "he", (ftnlen)2, (ftnlen)2) == 0; + conj = s_cmp(sname + 7, "he", (ftnlen)2, (ftnlen)2) == 0; nargs = 12; nc = 0; @@ -2692,7 +3383,7 @@ return 0; for (ict = 1; ict <= 2; ++ict) { *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1]; tran = *(unsigned char *)trans == 'C'; - if (tran && ! isconj) { + if (tran && ! conj) { *(unsigned char *)trans = 'T'; } if (tran) { @@ -2718,12 +3409,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 +3422,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) { @@ -2754,22 +3441,22 @@ return 0; for (ib = 1; ib <= i__4; ++ib) { i__5 = ib; beta.r = bet[i__5].r, beta.i = bet[i__5].i; - if (isconj) { + if (conj) { rbeta = beta.r; z__1.r = rbeta, z__1.i = 0.; beta.r = z__1.r, beta.i = z__1.i; } null = n <= 0; - if (isconj) { - null = null ||( (k <= 0 || (alpha.r == 0. && - alpha.i == 0.)) && rbeta == 1.); + if (conj) { + null = null || (k <= 0 || alpha.r == 0. && + alpha.i == 0.) && rbeta == 1.; } /* Generate the matrix C. */ zmake_(sname + 7, uplo, " ", &n, &n, &c__[ c_offset], nmax, &cc[1], &ldc, &reset, & - c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)1); + c_b1); ++nc; @@ -2799,7 +3486,7 @@ return 0; /* L20: */ } ldbs = ldb; - if (isconj) { + if (conj) { rbets = rbeta; } else { bets.r = beta.r, bets.i = beta.i; @@ -2816,42 +3503,42 @@ return 0; /* Call the subroutine. */ - if (isconj) { + if (conj) { 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; + al__1.aerr = 0; al__1.aunit = *ntra; - f_rew(&al__1);*/ + f_rew(&al__1); } czher2k_(iorder, uplo, trans, &n, &k, &alpha, &aa[1], &lda, &bb[1], &ldb, &rbeta, & - 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; + al__1.aerr = 0; al__1.aunit = *ntra; - f_rew(&al__1);*/ + f_rew(&al__1); } czsyr2k_(iorder, uplo, trans, &n, &k, &alpha, &aa[1], &lda, &bb[1], &ldb, &beta, & - cc[1], &ldc, (ftnlen)1, (ftnlen)1); + 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"); + io___362.ciunit = *nout; + s_wsfe(&io___362); + e_wsfe(); *fatal = TRUE_; goto L150; } @@ -2869,7 +3556,7 @@ return 0; isame[6] = ldas == lda; isame[7] = lze_(&bs[1], &bb[1], &lbb); isame[8] = ldbs == ldb; - if (isconj) { + if (conj) { isame[9] = rbets == rbeta; } else { isame[9] = bets.r == beta.r && bets.i == @@ -2879,7 +3566,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; @@ -2891,8 +3578,12 @@ return 0; 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__); - } + io___365.ciunit = *nout; + s_wsfe(&io___365); + do_fio(&c__1, (char *)&i__, (ftnlen) + sizeof(integer)); + e_wsfe(); + } /* L40: */ } if (! same) { @@ -2904,7 +3595,7 @@ return 0; /* Check the result column by column. */ - if (isconj) { + if (conj) { *(unsigned char *)transt = 'C'; } else { *(unsigned char *)transt = 'T'; @@ -2924,7 +3615,7 @@ return 0; i__6 = k; for (i__ = 1; i__ <= i__6; ++i__) { i__7 = i__; - i__8 = ((j - 1) << 1) * *nmax + k + + i__8 = (j - 1 << 1) * *nmax + k + i__; z__1.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8].i, @@ -2933,17 +3624,17 @@ return 0; i__8].r; w[i__7].r = z__1.r, w[i__7].i = z__1.i; - if (isconj) { + if (conj) { i__7 = k + i__; d_cnjg(&z__2, &alpha); - i__8 = ((j - 1) << 1) * *nmax + i__; + i__8 = (j - 1 << 1) * *nmax + i__; z__1.r = z__2.r * ab[i__8].r - z__2.i * ab[i__8].i, z__1.i = z__2.r * ab[i__8].i + z__2.i * ab[ i__8].r; w[i__7].r = z__1.r, w[i__7].i = z__1.i; } else { i__7 = k + i__; - i__8 = ((j - 1) << 1) * *nmax + i__; + i__8 = (j - 1 << 1) * *nmax + i__; z__1.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8] .i, z__1.i = alpha.r * ab[i__8].i + alpha.i * ab[i__8].r; @@ -2959,12 +3650,11 @@ 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__) { - if (isconj) { + if (conj) { i__7 = i__; d_cnjg(&z__2, &ab[(k + i__ - 1) * *nmax + j]); z__1.r = alpha.r * z__2.r - alpha.i * z__2.i, @@ -3001,8 +3691,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,57 +3735,90 @@ return 0; if (errmax < *thresh) { if (*iorder == 0) { - printf("%s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___373.ciunit = *nout; + s_wsfe(&io___373); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } if (*iorder == 1) { - printf("%s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)\n",sname,nc); + io___374.ciunit = *nout; + s_wsfe(&io___374); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); } } else { if (*iorder == 0) { - printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___375.ciunit = *nout; + s_wsfe(&io___375); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal)); + e_wsfe(); } if (*iorder == 1) { - printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc); - printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax); + io___376.ciunit = *nout; + s_wsfe(&io___376); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal)); + e_wsfe(); } } goto L160; L140: if (n > 1) { - printf(" THESE ARE THE RESULTS FOR COLUMN %d:\n",j); + io___377.ciunit = *nout; + s_wsfe(&io___377); + do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer)); + e_wsfe(); } L150: - printf(" ******* %s FAILED ON CALL NUMBER:\n",sname); - if (isconj) { + io___378.ciunit = *nout; + s_wsfe(&io___378); + do_fio(&c__1, sname, (ftnlen)13); + e_wsfe(); + if (conj) { zprcn7_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, & - ldb, &rbeta, &ldc, (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) { + /* Format strings */ + static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002," + "\002))"; + static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002" + ",f4.1,\002), A,\002,i3,\002, B\002,i3,\002, (\002,f4.1,\002,\002" + ",f4.1,\002), C,\002,i3,\002).\002)"; + /* Local variables */ - static char ca[14], cu[14], crc[14]; + char ca[14], cu[14], crc[14]; + + /* Fortran I/O blocks */ + static cilist io___382 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___383 = { 0, 0, 0, fmt_9994, 0 }; + if (*(unsigned char *)uplo == 'U') { s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); @@ -3115,19 +3837,48 @@ return 0; } else { s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); - printf("%d %d (%4.1lf,%4.1lf) , A, %d, B, %d, (%4.1lf,%4.1lf) , C, %d.\n",*n,*k,alpha->r,alpha->i,*lda,*ldb,beta->r,beta->i,*ldc); - -return 0; + io___382.ciunit = *nout; + s_wsfe(&io___382); + do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer)); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, crc, (ftnlen)14); + do_fio(&c__1, cu, (ftnlen)14); + do_fio(&c__1, ca, (ftnlen)14); + e_wsfe(); + io___383.ciunit = *nout; + s_wsfe(&io___383); + do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(doublereal)); + do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(doublereal)); + do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer)); + e_wsfe(); + return 0; } /* zprcn5_ */ -/* Subroutine */ int zprcn7_(integer* nout, integer* nc, char* sname, integer* iorder, char* uplo, char* transa, integer* n, integer* k, doublecomplex* alpha, integer* lda, integer* ldb, doublereal* beta, integer* ldc, 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) { + /* Format strings */ + static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,3(a14,\002," + "\002))"; + static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002" + ",f4.1,\002), A,\002,i3,\002, B\002,i3,\002,\002,f4.1,\002, C," + "\002,i3,\002).\002)"; /* Local variables */ - static char ca[14], cu[14], crc[14]; + char ca[14], cu[14], crc[14]; + + /* Fortran I/O blocks */ + static cilist io___387 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___388 = { 0, 0, 0, fmt_9994, 0 }; + if (*(unsigned char *)uplo == 'U') { s_copy(cu, " CblasUpper", (ftnlen)14, (ftnlen)14); @@ -3146,14 +3897,31 @@ return 0; } else { s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); } - printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca); - printf("%d %d (%4.1lf,%4.1lf), A, %d, B, %d, %4.1lf, C, %d.\n",*n,*k,alpha->r,alpha->i,*lda,*ldb,*beta,*ldc); - -return 0; + io___387.ciunit = *nout; + s_wsfe(&io___387); + do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer)); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, crc, (ftnlen)14); + do_fio(&c__1, cu, (ftnlen)14); + do_fio(&c__1, ca, (ftnlen)14); + e_wsfe(); + io___388.ciunit = *nout; + s_wsfe(&io___388); + do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(doublereal)); + do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*beta), (ftnlen)sizeof(doublereal)); + do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer)); + e_wsfe(); + return 0; } /* zprcn7_ */ -/* Subroutine */ int zmake_(char* type__, char* uplo, char* diag, integer* m, integer* n, doublecomplex* a, integer* nmax, doublecomplex* aa, integer* lda, logical* reset, doublecomplex* transl, 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; @@ -3161,13 +3929,11 @@ return 0; doublecomplex z__1, z__2; /* Local variables */ - static integer ibeg, iend; - extern /* Double Complex */ VOID zbeg_(doublecomplex*, logical*); - static logical unit; - static integer i__, j; - static logical lower, upper; - static integer jj; - static logical gen, her, tri, sym; + integer i__, j, jj; + logical gen, her, tri, sym; + integer ibeg, iend; + extern /* Double Complex */ VOID zbeg_(doublecomplex *, logical *); + logical unit, lower, upper; /* Generates values for an M by N matrix A. */ @@ -3184,16 +3950,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; @@ -3212,7 +3971,7 @@ return 0; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { - if (gen || (upper && i__ <= j) || (lower && i__ >= j)) { + if (gen || upper && i__ <= j || lower && i__ >= j) { i__3 = i__ + j * a_dim1; zbeg_(&z__2, reset); z__1.r = z__2.r + transl->r, z__1.i = z__2.i + transl->i; @@ -3335,8 +4094,22 @@ 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) { + /* Format strings */ + static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS" + " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 " + " EXPECTED RE\002,\002SULT COMPUTED R" + "ESULT\002)"; + static char fmt_9998[] = "(1x,i7,2(\002 (\002,g15.6,\002,\002,g15.6," + "\002)\002))"; + static char fmt_9997[] = "(\002 THESE ARE THE RESULTS FOR COLUMN" + " \002,i3)"; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, cc_dim1, @@ -3344,11 +4117,18 @@ return 0; doublereal d__1, d__2, d__3, d__4, d__5, d__6; doublecomplex z__1, z__2, z__3, z__4; - double sqrt(double); /* Local variables */ - static doublereal erri; - static integer i__, j, k; - static logical trana, tranb, ctrana, ctranb; + integer i__, j, k; + doublereal erri; + logical trana, tranb, ctrana, ctranb; + + /* Fortran I/O blocks */ + static cilist io___409 = { 0, 0, 0, fmt_9999, 0 }; + static cilist io___410 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___411 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___412 = { 0, 0, 0, fmt_9997, 0 }; + + /* Checks the results of the computational tests. */ @@ -3360,28 +4140,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_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 */ @@ -3694,19 +4466,35 @@ return 0; L230: *fatal = TRUE_; - printf(" ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HALF ACCURATE *******\n"); - printf(" EXPECTED RESULT COMPUTED RESULT\n"); + io___409.ciunit = *nout; + s_wsfe(&io___409); + e_wsfe(); i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { if (*mv) { - printf("%7d (%15.6g,%15.6g) (%15.6g,%15.6g)\n",i__,ct[i__].r,ct[i__].i,cc[i__+j*cc_dim1].r,cc[i__+j*cc_dim1].i); - } else { - printf("%7d (%15.6g,%15.6g) (%15.6g,%15.6g)\n",i__,cc[i__+j*cc_dim1].r,cc[i__+j*cc_dim1].i,ct[i__].r,ct[i__].i); + io___410.ciunit = *nout; + s_wsfe(&io___410); + do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&ct[i__], (ftnlen)sizeof(doublereal)); + do_fio(&c__2, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof( + doublereal)); + e_wsfe(); + } else { + io___411.ciunit = *nout; + s_wsfe(&io___411); + do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof( + doublereal)); + do_fio(&c__2, (char *)&ct[i__], (ftnlen)sizeof(doublereal)); + e_wsfe(); } /* L240: */ } if (*n > 1) { - printf(" THESE ARE THE RESULTS FOR COLUMN %d\n",j); + io___412.ciunit = *nout; + s_wsfe(&io___412); + do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer)); + e_wsfe(); } L250: @@ -3717,14 +4505,14 @@ return 0; } /* zmmch_ */ -logical lze_(doublecomplex* ri, doublecomplex* rj, integer* lr) +logical lze_(doublecomplex *ri, doublecomplex *rj, integer *lr) { /* System generated locals */ integer i__1, i__2, i__3; logical ret_val; /* Local variables */ - static integer i__; + integer i__; /* Tests if two arrays are identical. */ @@ -3737,10 +4525,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,15 +4550,16 @@ 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; logical ret_val; /* Local variables */ - static integer ibeg, iend, i__, j; - static logical upper; + integer i__, j, ibeg, iend; + logical upper; /* Tests if selected elements in two arrays are equal. */ @@ -3789,16 +4574,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 +4631,7 @@ logical lzeres_(char* type__, char* uplo, integer* m, integer* n, doublecomplex } } -/* 60 CONTINUE */ +/* L60: */ ret_val = TRUE_; goto L80; L70: @@ -3862,7 +4643,7 @@ logical lzeres_(char* type__, char* uplo, integer* m, integer* n, doublecomplex } /* lzeres_ */ -/* Double Complex */ VOID zbeg_(doublecomplex* ret_val, logical* reset) +/* Double Complex */ VOID zbeg_(doublecomplex * ret_val, logical *reset) { /* System generated locals */ doublereal d__1, d__2; @@ -3883,11 +4664,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; @@ -3925,7 +4701,7 @@ logical lzeres_(char* type__, char* uplo, integer* m, integer* n, doublecomplex } /* zbeg_ */ -doublereal ddiff_(doublereal* x, doublereal* y) +doublereal ddiff_(doublereal *x, doublereal *y) { /* System generated locals */ doublereal ret_val; @@ -3939,8 +4715,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 +4722,920 @@ 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"; + + /* Format strings */ + static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-CALL MYEXIT " + "TAKEN ON VALID CALL *******\002)"; + static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER" + " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)"; + static char fmt_10000[] = "(\002 \002,a13,\002 PASSED THE COLUMN-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10001[] = "(\002 \002,a13,\002 PASSED THE ROW-MAJOR C" + "OMPUTATIONAL TESTS\002,\002 (\002,i6,\002 CALL\002,\002S)\002)"; + static char fmt_10002[] = "(\002 \002,a13,\002 COMPLETED THE COLUMN-MAJO" + "R COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_10003[] = "(\002 \002,a13,\002 COMPLETED THE ROW-MAJOR " + " COMPUTATIONAL \002,\002TESTS (\002,i6,\002 CALLS)\002,/\002 **" + "***** BUT WITH MAXIMUM TEST \002,\002RATIO \002,f8.2,\002 - SUSP" + "ECT *******\002)"; + static char fmt_9996[] = "(\002 ******* \002,a13,\002 FAILED ON CALL NUM" + "BER:\002)"; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5, i__6, i__7; + alist al__1; + + /* Local variables */ + extern /* Subroutine */ int czgemmtr_(integer *, char *, char *, char *, + integer *, integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); + integer i__, k, n, ia, ib, ma, mb, na, nb, nc, ik, in, is, ks, ns, ica, + icb, laa, lbb, lda, lcc, ldb, ldc; + doublecomplex als, bls; + doublereal err; + extern logical lze_(doublecomplex *, doublecomplex *, integer *); + doublecomplex beta; + integer ldas, ldbs, ldcs; + logical same, null; + char uplo[1]; + doublecomplex alpha; + logical isame[13], trana, tranb; + extern /* Subroutine */ int zmake_(char *, char *, char *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, integer *, + logical *, doublecomplex *); + integer nargs; + logical reset; + char uplos[1]; + extern /* Subroutine */ int zprcn8_(integer *, integer *, char *, integer + *, char *, char *, char *, integer *, integer *, doublecomplex *, + integer *, integer *, doublecomplex *, integer *); + char tranas[1], tranbs[1], transa[1], transb[1]; + doublereal errmax; + extern /* Subroutine */ int zmmtch_(char *, char *, char *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *, doublereal *, doublecomplex *, + integer *, doublereal *, doublereal *, logical *, integer *, + logical *); + extern logical lzeres_(char *, char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *); + + /* Fortran I/O blocks */ + static cilist io___468 = { 0, 0, 0, fmt_9994, 0 }; + static cilist io___471 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___473 = { 0, 0, 0, fmt_10000, 0 }; + static cilist io___474 = { 0, 0, 0, fmt_10001, 0 }; + static cilist io___475 = { 0, 0, 0, fmt_10002, 0 }; + static cilist io___476 = { 0, 0, 0, fmt_10003, 0 }; + static cilist io___477 = { 0, 0, 0, fmt_9996, 0 }; + + + +/* Tests CGEMMTR. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 24-June-2024. */ +/* Martin Koehler, Max Planck Institute Magdeburg */ + + /* Parameter adjustments */ + --idim; + --alf; + --bet; + --g; + --ct; + --cs; + --cc; + c_dim1 = *nmax; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --bs; + --bb; + b_dim1 = *nmax; + b_offset = 1 + b_dim1; + b -= b_offset; + --as; + --aa; + a_dim1 = *nmax; + a_offset = 1 + a_dim1; + a -= a_offset; + + /* Function Body */ + + nargs = 13; + nc = 0; + reset = TRUE_; + errmax = 0.; + + i__1 = *nidim; + for (in = 1; in <= i__1; ++in) { + n = idim[in]; +/* Set LDC to 1 more than minimum value if room. */ + ldc = n; + if (ldc < *nmax) { + ++ldc; + } +/* Skip tests if not enough room. */ + if (ldc > *nmax) { + goto L100; + } + lcc = ldc * n; + null = (real) n <= 0.f; + + i__2 = *nidim; + for (ik = 1; ik <= i__2; ++ik) { + k = idim[ik]; + + for (ica = 1; ica <= 3; ++ica) { + *(unsigned char *)transa = *(unsigned char *)&ich[ica - 1]; + trana = *(unsigned char *)transa == 'T' || *(unsigned char *) + transa == 'C'; + + if (trana) { + ma = k; + na = n; + } else { + ma = n; + na = k; + } +/* Set LDA to 1 more than minimum value if room. */ + lda = ma; + if (lda < *nmax) { + ++lda; + } +/* Skip tests if not enough room. */ + if (lda > *nmax) { + goto L80; + } + laa = lda * na; + +/* Generate the matrix A. */ + + zmake_("ge", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[1], & + lda, &reset, &c_b1); + + for (icb = 1; icb <= 3; ++icb) { + *(unsigned char *)transb = *(unsigned char *)&ich[icb - 1] + ; + tranb = *(unsigned char *)transb == 'T' || *(unsigned + char *)transb == 'C'; + + if (tranb) { + mb = n; + nb = k; + } else { + mb = k; + nb = n; + } +/* Set LDB to 1 more than minimum value if room. */ + ldb = mb; + if (ldb < *nmax) { + ++ldb; + } +/* Skip tests if not enough room. */ + if (ldb > *nmax) { + goto L70; + } + lbb = ldb * nb; + +/* Generate the matrix B. */ + + zmake_("ge", " ", " ", &mb, &nb, &b[b_offset], nmax, &bb[ + 1], &ldb, &reset, &c_b1); + + i__3 = *nalf; + for (ia = 1; ia <= i__3; ++ia) { + i__4 = ia; + alpha.r = alf[i__4].r, alpha.i = alf[i__4].i; + + i__4 = *nbet; + for (ib = 1; ib <= i__4; ++ib) { + i__5 = ib; + beta.r = bet[i__5].r, beta.i = bet[i__5].i; + for (is = 1; is <= 2; ++is) { + *(unsigned char *)uplo = *(unsigned char *)& + ishape[is - 1]; + +/* Generate the matrix C. */ + + zmake_("ge", uplo, " ", &n, &n, &c__[c_offset] + , nmax, &cc[1], &ldc, &reset, &c_b1); + + ++nc; + +/* Save every datum before calling the */ +/* subroutine. */ + + *(unsigned char *)uplos = *(unsigned char *) + uplo; + *(unsigned char *)tranas = *(unsigned char *) + transa; + *(unsigned char *)tranbs = *(unsigned char *) + transb; + ns = n; + ks = k; + als.r = alpha.r, als.i = alpha.i; + i__5 = laa; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + as[i__6].r = aa[i__7].r, as[i__6].i = aa[ + i__7].i; +/* L10: */ + } + ldas = lda; + i__5 = lbb; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + bs[i__6].r = bb[i__7].r, bs[i__6].i = bb[ + i__7].i; +/* L20: */ + } + ldbs = ldb; + bls.r = beta.r, bls.i = beta.i; + i__5 = lcc; + for (i__ = 1; i__ <= i__5; ++i__) { + i__6 = i__; + i__7 = i__; + cs[i__6].r = cc[i__7].r, cs[i__6].i = cc[ + i__7].i; +/* L30: */ + } + ldcs = ldc; + +/* Call the subroutine. */ + + if (*trace) { + zprcn8_(ntra, &nc, sname, iorder, uplo, + transa, transb, &n, &k, &alpha, & + lda, &ldb, &beta, &ldc); + } + if (*rewi) { + al__1.aerr = 0; + al__1.aunit = *ntra; + f_rew(&al__1); + } + czgemmtr_(iorder, uplo, transa, transb, &n, & + k, &alpha, &aa[1], &lda, &bb[1], &ldb, + &beta, &cc[1], &ldc); + +/* Check if error-exit was taken incorrectly. */ + + if (! infoc_1.ok) { + io___468.ciunit = *nout; + s_wsfe(&io___468); + e_wsfe(); + *fatal = TRUE_; + goto L120; + } + +/* See what data changed inside subroutines. */ + + isame[0] = *(unsigned char *)uplo == *( + unsigned char *)uplos; + isame[1] = *(unsigned char *)transa == *( + unsigned char *)tranas; + isame[2] = *(unsigned char *)transb == *( + unsigned char *)tranbs; + isame[3] = ns == n; + isame[4] = ks == k; + isame[5] = als.r == alpha.r && als.i == + alpha.i; + isame[6] = lze_(&as[1], &aa[1], &laa); + isame[7] = ldas == lda; + isame[8] = lze_(&bs[1], &bb[1], &lbb); + isame[9] = ldbs == ldb; + isame[10] = bls.r == beta.r && bls.i == + beta.i; + if (null) { + isame[11] = lze_(&cs[1], &cc[1], &lcc); + } else { + isame[11] = lzeres_("ge", " ", &n, &n, & + cs[1], &cc[1], &ldc); + } + isame[12] = ldcs == ldc; + +/* If data was incorrectly changed, report */ +/* and return. */ + + same = TRUE_; + i__5 = nargs; + for (i__ = 1; i__ <= i__5; ++i__) { + same = same && isame[i__ - 1]; + if (! isame[i__ - 1]) { + io___471.ciunit = *nout; + s_wsfe(&io___471); + do_fio(&c__1, (char *)&i__, (ftnlen) + sizeof(integer)); + e_wsfe(); + } +/* L40: */ + } + if (! same) { + *fatal = TRUE_; + goto L120; + } + + if (! null) { + +/* Check the result. */ + + zmmtch_(uplo, transa, transb, &n, &k, & + alpha, &a[a_offset], nmax, &b[ + b_offset], nmax, &beta, &c__[ + c_offset], nmax, &ct[1], &g[1], & + cc[1], &ldc, eps, &err, fatal, + nout, &c_true); + errmax = f2cmax(errmax,err); +/* If got really bad answer, report and */ +/* return. */ + if (*fatal) { + goto L120; + } + } + +/* L45: */ + } + +/* L50: */ + } + +/* L60: */ + } + +L70: + ; + } + +L80: + ; + } + +/* L90: */ + } + +L100: + ; + } + + +/* Report result. */ + + if (errmax < *thresh) { + if (*iorder == 0) { + io___473.ciunit = *nout; + s_wsfe(&io___473); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); + } + if (*iorder == 1) { + io___474.ciunit = *nout; + s_wsfe(&io___474); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + e_wsfe(); + } + } else { + if (*iorder == 0) { + io___475.ciunit = *nout; + s_wsfe(&io___475); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal)); + e_wsfe(); + } + if (*iorder == 1) { + io___476.ciunit = *nout; + s_wsfe(&io___476); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal)); + e_wsfe(); + } + } + goto L130; + +L120: + io___477.ciunit = *nout; + s_wsfe(&io___477); + do_fio(&c__1, sname, (ftnlen)13); + e_wsfe(); + zprcn8_(nout, &nc, sname, iorder, uplo, transa, transb, &n, &k, &alpha, & + lda, &ldb, &beta, &ldc); + +L130: + return 0; + +/* L9995: */ + +/* End of ZCHK6. */ + +} /* zchk6_ */ + +/* Subroutine */ int zprcn8_(integer *nout, integer *nc, char *sname, integer + *iorder, char *uplo, char *transa, char *transb, integer *n, integer * + k, doublecomplex *alpha, integer *lda, integer *ldb, doublecomplex * + beta, integer *ldc) +{ + /* Format strings */ + static char fmt_9995[] = "(1x,i6,\002: \002,a13,\002(\002,a14,\002,\002," + "a14,\002,\002,a14,\002,\002,a14,\002,\002)"; + static char fmt_9994[] = "(10x,2(i3,\002,\002),\002 (\002,f4.1,\002,\002" + ",f4.1,\002) , A,\002,i3,\002, B,\002,i3,\002, (\002,f4.1,\002" + ",\002,f4.1,\002) , C,\002,i3,\002).\002)"; + + /* Local variables */ + char crc[14], cta[14], ctb[14], cuplo[14]; + + /* Fortran I/O blocks */ + static cilist io___482 = { 0, 0, 0, fmt_9995, 0 }; + static cilist io___483 = { 0, 0, 0, fmt_9994, 0 }; + + + if (*(unsigned char *)uplo == 'U') { + s_copy(cuplo, "CblasUpper", (ftnlen)14, (ftnlen)10); + } else { + s_copy(cuplo, "CblasLower", (ftnlen)14, (ftnlen)10); + } + if (*(unsigned char *)transa == 'N') { + s_copy(cta, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transa == 'T') { + s_copy(cta, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(cta, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*(unsigned char *)transb == 'N') { + s_copy(ctb, " CblasNoTrans", (ftnlen)14, (ftnlen)14); + } else if (*(unsigned char *)transb == 'T') { + s_copy(ctb, " CblasTrans", (ftnlen)14, (ftnlen)14); + } else { + s_copy(ctb, "CblasConjTrans", (ftnlen)14, (ftnlen)14); + } + if (*iorder == 1) { + s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14); + } else { + s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14); + } + io___482.ciunit = *nout; + s_wsfe(&io___482); + do_fio(&c__1, (char *)&(*nc), (ftnlen)sizeof(integer)); + do_fio(&c__1, sname, (ftnlen)13); + do_fio(&c__1, crc, (ftnlen)14); + do_fio(&c__1, cuplo, (ftnlen)14); + do_fio(&c__1, cta, (ftnlen)14); + do_fio(&c__1, ctb, (ftnlen)14); + e_wsfe(); + io___483.ciunit = *nout; + s_wsfe(&io___483); + do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*k), (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&(*alpha), (ftnlen)sizeof(doublereal)); + do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*ldb), (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&(*beta), (ftnlen)sizeof(doublereal)); + do_fio(&c__1, (char *)&(*ldc), (ftnlen)sizeof(integer)); + e_wsfe(); + return 0; +} /* zprcn8_ */ + +/* Subroutine */ int zmmtch_(char *uplo, char *transa, char *transb, integer * + n, integer *kk, doublecomplex *alpha, doublecomplex *a, integer *lda, + doublecomplex *b, integer *ldb, doublecomplex *beta, doublecomplex * + c__, integer *ldc, doublecomplex *ct, doublereal *g, doublecomplex * + cc, integer *ldcc, doublereal *eps, doublereal *err, logical *fatal, + integer *nout, logical *mv) +{ + /* Format strings */ + static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS" + " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 " + " EXPECTED RE\002,\002SULT COMPUTED R" + "ESULT\002)"; + static char fmt_9998[] = "(1x,i7,2(\002 (\002,g15.6,\002,\002,g15.6," + "\002)\002))"; + static char fmt_9997[] = "(\002 THESE ARE THE RESULTS FOR COLUMN" + " \002,i3)"; + + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, cc_dim1, + cc_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7; + doublereal d__1, d__2, d__3, d__4, d__5, d__6; + doublecomplex z__1, z__2, z__3, z__4; + + /* Local variables */ + integer i__, j, k; + doublereal erri; + logical trana, tranb, upper; + integer istop; + logical ctrana, ctranb; + integer istart; + + /* Fortran I/O blocks */ + static cilist io___495 = { 0, 0, 0, fmt_9999, 0 }; + static cilist io___496 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___497 = { 0, 0, 0, fmt_9998, 0 }; + static cilist io___498 = { 0, 0, 0, fmt_9997, 0 }; + + + +/* Checks the results of the computational tests for GEMMTR. */ + +/* Auxiliary routine for test program for Level 3 Blas. */ + +/* -- Written on 24-June-2024. */ +/* Martin Koehler, Max Planck Institute, Magdeburg */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1; + c__ -= c_offset; + --ct; + --g; + cc_dim1 = *ldcc; + cc_offset = 1 + cc_dim1; + cc -= cc_offset; + + /* Function Body */ + upper = *(unsigned char *)uplo == 'U'; + trana = *(unsigned char *)transa == 'T' || *(unsigned char *)transa == + 'C'; + tranb = *(unsigned char *)transb == 'T' || *(unsigned char *)transb == + 'C'; + ctrana = *(unsigned char *)transa == 'C'; + ctranb = *(unsigned char *)transb == 'C'; + istart = 1; + istop = *n; + +/* Compute expected result, one column at a time, in CT using data */ +/* in A, B and C. */ +/* Compute gauges in G. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + + if (upper) { + istart = 1; + istop = j; + } else { + istart = j; + istop = *n; + } + i__2 = istop; + for (i__ = istart; i__ <= i__2; ++i__) { + i__3 = i__; + ct[i__3].r = 0., ct[i__3].i = 0.; + g[i__] = 0.; +/* L10: */ + } + if (! trana && ! tranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = istop; + for (i__ = istart; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + i__6 = i__ + k * a_dim1; + i__7 = k + j * b_dim1; + z__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[i__7].i, + z__2.i = a[i__6].r * b[i__7].i + a[i__6].i * b[ + i__7].r; + z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i + + z__2.i; + ct[i__4].r = z__1.r, ct[i__4].i = z__1.i; + i__4 = i__ + k * a_dim1; + i__5 = k + j * b_dim1; + g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag( + &a[i__ + k * a_dim1]), abs(d__2))) * ((d__3 = b[ + i__5].r, abs(d__3)) + (d__4 = d_imag(&b[k + j * + b_dim1]), abs(d__4))); +/* L20: */ + } +/* L30: */ + } + } else if (trana && ! tranb) { + if (ctrana) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = istop; + for (i__ = istart; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + d_cnjg(&z__3, &a[k + i__ * a_dim1]); + i__6 = k + j * b_dim1; + z__2.r = z__3.r * b[i__6].r - z__3.i * b[i__6].i, + z__2.i = z__3.r * b[i__6].i + z__3.i * b[i__6] + .r; + z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i + + z__2.i; + ct[i__4].r = z__1.r, ct[i__4].i = z__1.i; + i__4 = k + i__ * a_dim1; + i__5 = k + j * b_dim1; + g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = + d_imag(&a[k + i__ * a_dim1]), abs(d__2))) * (( + d__3 = b[i__5].r, abs(d__3)) + (d__4 = d_imag( + &b[k + j * b_dim1]), abs(d__4))); +/* L40: */ + } +/* L50: */ + } + } else { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = istop; + for (i__ = istart; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + i__6 = k + i__ * a_dim1; + i__7 = k + j * b_dim1; + z__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[i__7] + .i, z__2.i = a[i__6].r * b[i__7].i + a[i__6] + .i * b[i__7].r; + z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i + + z__2.i; + ct[i__4].r = z__1.r, ct[i__4].i = z__1.i; + i__4 = k + i__ * a_dim1; + i__5 = k + j * b_dim1; + g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = + d_imag(&a[k + i__ * a_dim1]), abs(d__2))) * (( + d__3 = b[i__5].r, abs(d__3)) + (d__4 = d_imag( + &b[k + j * b_dim1]), abs(d__4))); +/* L60: */ + } +/* L70: */ + } + } + } else if (! trana && tranb) { + if (ctranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = istop; + for (i__ = istart; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + i__6 = i__ + k * a_dim1; + d_cnjg(&z__3, &b[j + k * b_dim1]); + z__2.r = a[i__6].r * z__3.r - a[i__6].i * z__3.i, + z__2.i = a[i__6].r * z__3.i + a[i__6].i * + z__3.r; + z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i + + z__2.i; + ct[i__4].r = z__1.r, ct[i__4].i = z__1.i; + i__4 = i__ + k * a_dim1; + i__5 = j + k * b_dim1; + g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = + d_imag(&a[i__ + k * a_dim1]), abs(d__2))) * (( + d__3 = b[i__5].r, abs(d__3)) + (d__4 = d_imag( + &b[j + k * b_dim1]), abs(d__4))); +/* L80: */ + } +/* L90: */ + } + } else { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = istop; + for (i__ = istart; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + i__6 = i__ + k * a_dim1; + i__7 = j + k * b_dim1; + z__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[i__7] + .i, z__2.i = a[i__6].r * b[i__7].i + a[i__6] + .i * b[i__7].r; + z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i + + z__2.i; + ct[i__4].r = z__1.r, ct[i__4].i = z__1.i; + i__4 = i__ + k * a_dim1; + i__5 = j + k * b_dim1; + g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = + d_imag(&a[i__ + k * a_dim1]), abs(d__2))) * (( + d__3 = b[i__5].r, abs(d__3)) + (d__4 = d_imag( + &b[j + k * b_dim1]), abs(d__4))); +/* L100: */ + } +/* L110: */ + } + } + } else if (trana && tranb) { + if (ctrana) { + if (ctranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = istop; + for (i__ = istart; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + d_cnjg(&z__3, &a[k + i__ * a_dim1]); + d_cnjg(&z__4, &b[j + k * b_dim1]); + z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, + z__2.i = z__3.r * z__4.i + z__3.i * + z__4.r; + z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i + + z__2.i; + ct[i__4].r = z__1.r, ct[i__4].i = z__1.i; + i__4 = k + i__ * a_dim1; + i__5 = j + k * b_dim1; + g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = + d_imag(&a[k + i__ * a_dim1]), abs(d__2))) + * ((d__3 = b[i__5].r, abs(d__3)) + (d__4 + = d_imag(&b[j + k * b_dim1]), abs(d__4))); +/* L120: */ + } +/* L130: */ + } + } else { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = istop; + for (i__ = istart; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + d_cnjg(&z__3, &a[k + i__ * a_dim1]); + i__6 = j + k * b_dim1; + z__2.r = z__3.r * b[i__6].r - z__3.i * b[i__6].i, + z__2.i = z__3.r * b[i__6].i + z__3.i * b[ + i__6].r; + z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i + + z__2.i; + ct[i__4].r = z__1.r, ct[i__4].i = z__1.i; + i__4 = k + i__ * a_dim1; + i__5 = j + k * b_dim1; + g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = + d_imag(&a[k + i__ * a_dim1]), abs(d__2))) + * ((d__3 = b[i__5].r, abs(d__3)) + (d__4 + = d_imag(&b[j + k * b_dim1]), abs(d__4))); +/* L140: */ + } +/* L150: */ + } + } + } else { + if (ctranb) { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = istop; + for (i__ = istart; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + i__6 = k + i__ * a_dim1; + d_cnjg(&z__3, &b[j + k * b_dim1]); + z__2.r = a[i__6].r * z__3.r - a[i__6].i * z__3.i, + z__2.i = a[i__6].r * z__3.i + a[i__6].i * + z__3.r; + z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i + + z__2.i; + ct[i__4].r = z__1.r, ct[i__4].i = z__1.i; + i__4 = k + i__ * a_dim1; + i__5 = j + k * b_dim1; + g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = + d_imag(&a[k + i__ * a_dim1]), abs(d__2))) + * ((d__3 = b[i__5].r, abs(d__3)) + (d__4 + = d_imag(&b[j + k * b_dim1]), abs(d__4))); +/* L160: */ + } +/* L170: */ + } + } else { + i__2 = *kk; + for (k = 1; k <= i__2; ++k) { + i__3 = istop; + for (i__ = istart; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__; + i__6 = k + i__ * a_dim1; + i__7 = j + k * b_dim1; + z__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[ + i__7].i, z__2.i = a[i__6].r * b[i__7].i + + a[i__6].i * b[i__7].r; + z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i + + z__2.i; + ct[i__4].r = z__1.r, ct[i__4].i = z__1.i; + i__4 = k + i__ * a_dim1; + i__5 = j + k * b_dim1; + g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = + d_imag(&a[k + i__ * a_dim1]), abs(d__2))) + * ((d__3 = b[i__5].r, abs(d__3)) + (d__4 + = d_imag(&b[j + k * b_dim1]), abs(d__4))); +/* L180: */ + } +/* L190: */ + } + } + } + } + i__2 = istop; + for (i__ = istart; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + z__2.r = alpha->r * ct[i__4].r - alpha->i * ct[i__4].i, z__2.i = + alpha->r * ct[i__4].i + alpha->i * ct[i__4].r; + i__5 = i__ + j * c_dim1; + z__3.r = beta->r * c__[i__5].r - beta->i * c__[i__5].i, z__3.i = + beta->r * c__[i__5].i + beta->i * c__[i__5].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + ct[i__3].r = z__1.r, ct[i__3].i = z__1.i; + i__3 = i__ + j * c_dim1; + g[i__] = ((d__1 = alpha->r, abs(d__1)) + (d__2 = d_imag(alpha), + abs(d__2))) * g[i__] + ((d__3 = beta->r, abs(d__3)) + ( + d__4 = d_imag(beta), abs(d__4))) * ((d__5 = c__[i__3].r, + abs(d__5)) + (d__6 = d_imag(&c__[i__ + j * c_dim1]), abs( + d__6))); +/* L200: */ + } + +/* Compute the error ratio for this result. */ + + *err = 0.; + i__2 = istop; + for (i__ = istart; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__ + j * cc_dim1; + z__2.r = ct[i__3].r - cc[i__4].r, z__2.i = ct[i__3].i - cc[i__4] + .i; + z__1.r = z__2.r, z__1.i = z__2.i; + erri = ((d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), abs( + d__2))) / *eps; + if (g[i__] != 0.) { + erri /= g[i__]; + } + *err = f2cmax(*err,erri); + if (*err * sqrt(*eps) >= 1.) { + goto L230; + } +/* L210: */ + } + +/* L220: */ + } + +/* If the loop completes, all results are at least half accurate. */ + goto L250; + +/* Report fatal error. */ + +L230: + *fatal = TRUE_; + io___495.ciunit = *nout; + s_wsfe(&io___495); + e_wsfe(); + i__1 = istop; + for (i__ = istart; i__ <= i__1; ++i__) { + if (*mv) { + io___496.ciunit = *nout; + s_wsfe(&io___496); + do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&ct[i__], (ftnlen)sizeof(doublereal)); + do_fio(&c__2, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof( + doublereal)); + e_wsfe(); + } else { + io___497.ciunit = *nout; + s_wsfe(&io___497); + do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer)); + do_fio(&c__2, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof( + doublereal)); + do_fio(&c__2, (char *)&ct[i__], (ftnlen)sizeof(doublereal)); + e_wsfe(); + } +/* L240: */ + } + if (*n > 1) { + io___498.ciunit = *nout; + s_wsfe(&io___498); + do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer)); + e_wsfe(); + } + +L250: + return 0; + + +/* End of ZMMTCH. */ + +} /* zmmtch_ */ + +/* Main program alias */ int zblat3_ () { MAIN__ (); return 0; } 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 c0d5896e17..8a75b10ebf 100644 --- a/interface/CMakeLists.txt +++ b/interface/CMakeLists.txt @@ -109,7 +109,7 @@ endif () GenerateNamedObjects("trsm.c" "TRMM" "trmm" ${CBLAS_FLAG}) # gemmtr is gemmt under the name adopted by the Reference BLAS - GenerateNamedObjects("gemm.c" "RNAME" "gemmtr" ${CBLAS_FLAG}) + GenerateNamedObjects("gemmt.c" "RNAME" "gemmtr" ${CBLAS_FLAG}) # max and imax are compiled 4 times GenerateNamedObjects("max.c" "" "" ${CBLAS_FLAG}) @@ -125,8 +125,8 @@ endif () if (BUILD_BFLOAT16) GenerateNamedObjects("bf16dot.c" "" "sbdot" ${CBLAS_FLAG} "" "" true "BFLOAT16") GenerateNamedObjects("gemm.c" "" "sbgemm" ${CBLAS_FLAG} "" "" true "BFLOAT16") - GenerateNamedObjects("gemmt.c" "" "sbgemmt" ${CBLAS_FLAG} "" "" true "BFLOAT16") - GenerateNamedObjects("gemmt.c" "RNAME" "sbgemmtr" ${CBLAS_FLAG} "" "" true "BFLOAT16") + GenerateNamedObjects("sbgemmt.c" "" "sbgemmt" ${CBLAS_FLAG} "" "" true "BFLOAT16") + GenerateNamedObjects("sbgemmt.c" "RNAME" "sbgemmtr" ${CBLAS_FLAG} "" "" true "BFLOAT16") GenerateNamedObjects("sbgemv.c" "" "sbgemv" ${CBLAS_FLAG} "" "" true "BFLOAT16") GenerateNamedObjects("tobf16.c" "SINGLE_PREC" "sbstobf16" ${CBLAS_FLAG} "" "" true "BFLOAT16") GenerateNamedObjects("tobf16.c" "DOUBLE_PREC" "sbdtobf16" ${CBLAS_FLAG} "" "" true "BFLOAT16")