From 19b00163aafb70d80434c2028ece21610067f5e6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20K=C3=B6hler?= Date: Wed, 19 Jul 2023 12:53:54 +0200 Subject: [PATCH 01/23] Add xGEMMT and their test cases The xGEMMT subroutines are added in the Fortran API. The tests are updated as well. --- BLAS/SRC/CMakeLists.txt | 8 +- BLAS/SRC/Makefile | 8 +- BLAS/SRC/cgemmt.f | 570 ++++++++++++++++++++++++++++++++ BLAS/SRC/dgemmt.f | 432 ++++++++++++++++++++++++ BLAS/SRC/sgemmt.f | 432 ++++++++++++++++++++++++ BLAS/SRC/zgemmt.f | 570 ++++++++++++++++++++++++++++++++ BLAS/TESTING/cblat3.f | 706 ++++++++++++++++++++++++++++++++++++++- BLAS/TESTING/cblat3.in | 1 + BLAS/TESTING/dblat3.f | 518 ++++++++++++++++++++++++++++- BLAS/TESTING/dblat3.in | 1 + BLAS/TESTING/sblat3.f | 518 ++++++++++++++++++++++++++++- BLAS/TESTING/sblat3.in | 1 + BLAS/TESTING/zblat3.f | 714 +++++++++++++++++++++++++++++++++++++++- BLAS/TESTING/zblat3.in | 1 + 14 files changed, 4418 insertions(+), 62 deletions(-) create mode 100644 BLAS/SRC/cgemmt.f create mode 100644 BLAS/SRC/dgemmt.f create mode 100644 BLAS/SRC/sgemmt.f create mode 100644 BLAS/SRC/zgemmt.f diff --git a/BLAS/SRC/CMakeLists.txt b/BLAS/SRC/CMakeLists.txt index ebf5fce26f..7af9f451c8 100644 --- a/BLAS/SRC/CMakeLists.txt +++ b/BLAS/SRC/CMakeLists.txt @@ -82,15 +82,15 @@ set(ZBLAS2 zgemv.f zgbmv.f zhemv.f zhbmv.f zhpmv.f #--------------------------------------------------------- # Level 3 BLAS #--------------------------------------------------------- -set(SBLAS3 sgemm.f ssymm.f ssyrk.f ssyr2k.f strmm.f strsm.f) +set(SBLAS3 sgemm.f ssymm.f ssyrk.f ssyr2k.f strmm.f strsm.f sgemmt.f) set(CBLAS3 cgemm.f csymm.f csyrk.f csyr2k.f ctrmm.f ctrsm.f - chemm.f cherk.f cher2k.f) + chemm.f cherk.f cher2k.f cgemmt.f) -set(DBLAS3 dgemm.f dsymm.f dsyrk.f dsyr2k.f dtrmm.f dtrsm.f) +set(DBLAS3 dgemm.f dsymm.f dsyrk.f dsyr2k.f dtrmm.f dtrsm.f dgemmt.f) set(ZBLAS3 zgemm.f zsymm.f zsyrk.f zsyr2k.f ztrmm.f ztrsm.f - zhemm.f zherk.f zher2k.f) + zhemm.f zherk.f zher2k.f zgemmt.f) set(SOURCES) diff --git a/BLAS/SRC/Makefile b/BLAS/SRC/Makefile index 70534c8358..145f40ff42 100644 --- a/BLAS/SRC/Makefile +++ b/BLAS/SRC/Makefile @@ -127,18 +127,18 @@ $(ZBLAS2): $(FRC) # Comment out the next 4 definitions if you already have # the Level 3 BLAS. #--------------------------------------------------------- -SBLAS3 = sgemm.o ssymm.o ssyrk.o ssyr2k.o strmm.o strsm.o +SBLAS3 = sgemm.o ssymm.o ssyrk.o ssyr2k.o strmm.o strsm.o sgemmt.o $(SBLAS3): $(FRC) CBLAS3 = cgemm.o csymm.o csyrk.o csyr2k.o ctrmm.o ctrsm.o \ - chemm.o cherk.o cher2k.o + chemm.o cherk.o cher2k.o cgemmt.o $(CBLAS3): $(FRC) -DBLAS3 = dgemm.o dsymm.o dsyrk.o dsyr2k.o dtrmm.o dtrsm.o +DBLAS3 = dgemm.o dsymm.o dsyrk.o dsyr2k.o dtrmm.o dtrsm.o dgemmt.o $(DBLAS3): $(FRC) ZBLAS3 = zgemm.o zsymm.o zsyrk.o zsyr2k.o ztrmm.o ztrsm.o \ - zhemm.o zherk.o zher2k.o + zhemm.o zherk.o zher2k.o zgemmt.o $(ZBLAS3): $(FRC) ALLOBJ = $(SBLAS1) $(SBLAS2) $(SBLAS3) $(DBLAS1) $(DBLAS2) $(DBLAS3) \ diff --git a/BLAS/SRC/cgemmt.f b/BLAS/SRC/cgemmt.f new file mode 100644 index 0000000000..e6071a345b --- /dev/null +++ b/BLAS/SRC/cgemmt.f @@ -0,0 +1,570 @@ +*> \brief \b CGEMMT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA, +* C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,N +* CHARACTER TRANSA,TRANSB, UPLO +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CGEMMT performs one of the matrix-matrix operations +*> +*> C := alpha*op( A )*op( B ) + beta*C, +*> +*> where op( X ) is one of +*> +*> op( X ) = X or op( X ) = X**T, +*> +*> alpha and beta are scalars, and A, B and C are matrices, with op( A ) +*> an n by k matrix, op( B ) a k by n matrix and C an n by n matrix. +*> Thereby, the routine only accesses and updates the upper or lower +*> triangular part of the result matrix C. This behaviour can be used, +*> the resulting matrix C is known to be symmetric. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the lower or the upper +*> triangular part of C is access and updated. +*> +*> UPLO = 'L' or 'l', the lower tringular part of C is used. +*> +*> UPLO = 'U' or 'u', the upper tringular part of C is used. +*> \endverbatim +* +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n', op( A ) = A. +*> +*> TRANSA = 'T' or 't', op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c', op( A ) = A**H. +*> \endverbatim +*> +*> \param[in] TRANSB +*> \verbatim +*> TRANSB is CHARACTER*1 +*> On entry, TRANSB specifies the form of op( B ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSB = 'N' or 'n', op( B ) = B. +*> +*> TRANSB = 'T' or 't', op( B ) = B**T. +*> +*> TRANSB = 'C' or 'c', op( B ) = B**H. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of rows and columns of +*> the matrix C, the number of columns of op(B) and the number +*> of rows of op(A). N must be at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry, K specifies the number of columns of the matrix +*> op( A ) and the number of rows of the matrix op( B ). K must +*> be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension ( LDA, ka ), where ka is +*> k when TRANSA = 'N' or 'n', and is n otherwise. +*> Before entry with TRANSA = 'N' or 'n', the leading n by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by m part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANSA = 'N' or 'n' then +*> LDA must be at least max( 1, n ), otherwise LDA must be at +*> least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is COMPLEX array, dimension ( LDB, kb ), where kb is +*> n when TRANSB = 'N' or 'n', and is k otherwise. +*> Before entry with TRANSB = 'N' or 'n', the leading k by n +*> part of the array B must contain the matrix B, otherwise +*> the leading n by k part of the array B must contain the +*> matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. When TRANSB = 'N' or 'n' then +*> LDB must be at least max( 1, k ), otherwise LDB must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX. +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX array, dimension ( LDC, N ) +*> Before entry, the leading n by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the upper or lower trinangular part of the matrix +*> C is overwritten by the n by n matrix +*> ( alpha*op( A )*op( B ) + beta*C ). +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Martin Koehler +* +*> \ingroup gemm +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 19-July-2023. +*> Martin Koehler, MPI Magdeburg +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB, + + BETA,C,LDC) + IMPLICIT NONE +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX ALPHA,BETA + INTEGER K,LDA,LDB,LDC,N + CHARACTER TRANSA,TRANSB,UPLO +* .. +* .. Array Arguments .. + COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG,MAX +* .. +* .. Local Scalars .. + COMPLEX TEMP + INTEGER I,INFO,J,L,NROWA,NROWB,ISTART, ISTOP + LOGICAL CONJA,CONJB,NOTA,NOTB,UPPER +* .. +* .. Parameters .. + COMPLEX ONE + PARAMETER (ONE= (1.0E+0,0.0E+0)) + COMPLEX ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* +* Set NOTA and NOTB as true if A and B respectively are not +* conjugated or transposed, set CONJA and CONJB as true if A and +* B respectively are to be transposed but not conjugated and set +* NROWA and NROWB as the number of rows of A and B respectively. +* + NOTA = LSAME(TRANSA,'N') + NOTB = LSAME(TRANSB,'N') + CONJA = LSAME(TRANSA,'C') + CONJB = LSAME(TRANSB,'C') + IF (NOTA) THEN + NROWA = N + ELSE + NROWA = K + END IF + IF (NOTB) THEN + NROWB = K + ELSE + NROWB = N + END IF + UPPER = LSAME(UPLO, 'U') + +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT. UPPER) .AND. (.NOT. LSAME(UPLO, 'L'))) THEN + INFO = 1 + ELSE IF ((.NOT.NOTA) .AND. (.NOT.CONJA) .AND. + + (.NOT.LSAME(TRANSA,'T'))) THEN + INFO = 2 + ELSE IF ((.NOT.NOTB) .AND. (.NOT.CONJB) .AND. + + (.NOT.LSAME(TRANSB,'T'))) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 8 + ELSE IF (LDB.LT.MAX(1,NROWB)) THEN + INFO = 10 + ELSE IF (LDC.LT.MAX(1,N)) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CGEMMT',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. + + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 10 I = ISTART, ISTOP + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + DO 30 I = ISTART, ISTOP + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (NOTB) THEN + IF (NOTA) THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + IF (BETA.EQ.ZERO) THEN + DO 50 I = ISTART, ISTOP + C(I,J) = ZERO + 50 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 60 I = ISTART, ISTOP + C(I,J) = BETA*C(I,J) + 60 CONTINUE + END IF + DO 80 L = 1,K + TEMP = ALPHA*B(L,J) + DO 70 I = ISTART, ISTOP + C(I,J) = C(I,J) + TEMP*A(I,L) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + ELSE IF (CONJA) THEN +* +* Form C := alpha*A**H*B + beta*C. +* + DO 120 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 110 I = ISTART, ISTOP + TEMP = ZERO + DO 100 L = 1,K + TEMP = TEMP + CONJG(A(L,I))*B(L,J) + 100 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 110 CONTINUE + 120 CONTINUE + ELSE +* +* Form C := alpha*A**T*B + beta*C +* + DO 150 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 140 I = ISTART, ISTOP + TEMP = ZERO + DO 130 L = 1,K + TEMP = TEMP + A(L,I)*B(L,J) + 130 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 140 CONTINUE + 150 CONTINUE + END IF + ELSE IF (NOTA) THEN + IF (CONJB) THEN +* +* Form C := alpha*A*B**H + beta*C. +* + DO 200 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + IF (BETA.EQ.ZERO) THEN + DO 160 I = ISTART,ISTOP + C(I,J) = ZERO + 160 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 170 I = ISTART, ISTOP + C(I,J) = BETA*C(I,J) + 170 CONTINUE + END IF + DO 190 L = 1,K + TEMP = ALPHA*CONJG(B(J,L)) + DO 180 I = ISTART, ISTOP + C(I,J) = C(I,J) + TEMP*A(I,L) + 180 CONTINUE + 190 CONTINUE + 200 CONTINUE + ELSE +* +* Form C := alpha*A*B**T + beta*C +* + DO 250 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + IF (BETA.EQ.ZERO) THEN + DO 210 I = ISTART, ISTOP + C(I,J) = ZERO + 210 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 220 I = ISTART, ISTOP + C(I,J) = BETA*C(I,J) + 220 CONTINUE + END IF + DO 240 L = 1,K + TEMP = ALPHA*B(J,L) + DO 230 I = ISTART, ISTOP + C(I,J) = C(I,J) + TEMP*A(I,L) + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + END IF + ELSE IF (CONJA) THEN + IF (CONJB) THEN +* +* Form C := alpha*A**H*B**H + beta*C. +* + DO 280 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 270 I = ISTART, ISTOP + TEMP = ZERO + DO 260 L = 1,K + TEMP = TEMP + CONJG(A(L,I))*CONJG(B(J,L)) + 260 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 270 CONTINUE + 280 CONTINUE + ELSE +* +* Form C := alpha*A**H*B**T + beta*C +* + DO 310 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 300 I = ISTART, ISTOP + TEMP = ZERO + DO 290 L = 1,K + TEMP = TEMP + CONJG(A(L,I))*B(J,L) + 290 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 300 CONTINUE + 310 CONTINUE + END IF + ELSE + IF (CONJB) THEN +* +* Form C := alpha*A**T*B**H + beta*C +* + DO 340 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 330 I = ISTART, ISTOP + TEMP = ZERO + DO 320 L = 1,K + TEMP = TEMP + A(L,I)*CONJG(B(J,L)) + 320 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 330 CONTINUE + 340 CONTINUE + ELSE +* +* Form C := alpha*A**T*B**T + beta*C +* + DO 370 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 360 I = ISTART, ISTOP + TEMP = ZERO + DO 350 L = 1,K + TEMP = TEMP + A(L,I)*B(J,L) + 350 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 360 CONTINUE + 370 CONTINUE + END IF + END IF +* + RETURN +* +* End of CGEMMT +* + END diff --git a/BLAS/SRC/dgemmt.f b/BLAS/SRC/dgemmt.f new file mode 100644 index 0000000000..718fafb17f --- /dev/null +++ b/BLAS/SRC/dgemmt.f @@ -0,0 +1,432 @@ +*> \brief \b DGEMMT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA, +* C,LDC) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,N +* CHARACTER TRANSA,TRANSB, UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEMMT performs one of the matrix-matrix operations +*> +*> C := alpha*op( A )*op( B ) + beta*C, +*> +*> where op( X ) is one of +*> +*> op( X ) = X or op( X ) = X**T, +*> +*> alpha and beta are scalars, and A, B and C are matrices, with op( A ) +*> an n by k matrix, op( B ) a k by n matrix and C an n by n matrix. +*> Thereby, the routine only accesses and updates the upper or lower +*> triangular part of the result matrix C. This behaviour can be used, +*> the resulting matrix C is known to be symmetric. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the lower or the upper +*> triangular part of C is access and updated. +*> +*> UPLO = 'L' or 'l', the lower tringular part of C is used. +*> +*> UPLO = 'U' or 'u', the upper tringular part of C is used. +*> \endverbatim +* +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n', op( A ) = A. +*> +*> TRANSA = 'T' or 't', op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c', op( A ) = A**T. +*> \endverbatim +*> +*> \param[in] TRANSB +*> \verbatim +*> TRANSB is CHARACTER*1 +*> On entry, TRANSB specifies the form of op( B ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSB = 'N' or 'n', op( B ) = B. +*> +*> TRANSB = 'T' or 't', op( B ) = B**T. +*> +*> TRANSB = 'C' or 'c', op( B ) = B**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of rows and columns of +*> the matrix C, the number of columns of op(B) and the number +*> of rows of op(A). N must be at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry, K specifies the number of columns of the matrix +*> op( A ) and the number of rows of the matrix op( B ). K must +*> be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( LDA, ka ), where ka is +*> k when TRANSA = 'N' or 'n', and is n otherwise. +*> Before entry with TRANSA = 'N' or 'n', the leading n by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by m part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANSA = 'N' or 'n' then +*> LDA must be at least max( 1, n ), otherwise LDA must be at +*> least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension ( LDB, kb ), where kb is +*> n when TRANSB = 'N' or 'n', and is k otherwise. +*> Before entry with TRANSB = 'N' or 'n', the leading k by n +*> part of the array B must contain the matrix B, otherwise +*> the leading n by k part of the array B must contain the +*> matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. When TRANSB = 'N' or 'n' then +*> LDB must be at least max( 1, k ), otherwise LDB must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION. +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension ( LDC, N ) +*> Before entry, the leading n by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the upper or lower trinangular part of the matrix +*> C is overwritten by the n by n matrix +*> ( alpha*op( A )*op( B ) + beta*C ). +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Martin Koehler +* +*> \ingroup gemm +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 19-July-2023. +*> Martin Koehler, MPI Magdeburg +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB, + + BETA,C,LDC) + IMPLICIT NONE +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA,BETA + INTEGER K,LDA,LDB,LDC,N + CHARACTER TRANSA,TRANSB,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,J,L,NROWA,NROWB, ISTART, ISTOP + LOGICAL NOTA,NOTB, UPPER +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) +* .. +* +* Set NOTA and NOTB as true if A and B respectively are not +* transposed and set NROWA and NROWB as the number of rows of A +* and B respectively. +* + NOTA = LSAME(TRANSA,'N') + NOTB = LSAME(TRANSB,'N') + IF (NOTA) THEN + NROWA = N + ELSE + NROWA = K + END IF + IF (NOTB) THEN + NROWB = K + ELSE + NROWB = N + END IF + UPPER = LSAME(UPLO, 'U') +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT. UPPER) .AND. (.NOT. LSAME(UPLO, 'L'))) THEN + INFO = 1 + ELSE IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND. + + (.NOT.LSAME(TRANSA,'T'))) THEN + INFO = 2 + ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND. + + (.NOT.LSAME(TRANSB,'T'))) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 8 + ELSE IF (LDB.LT.MAX(1,NROWB)) THEN + INFO = 10 + ELSE IF (LDC.LT.MAX(1,N)) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DGEMMT',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. + + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And if alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 10 I = ISTART, ISTOP + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 30 I = ISTART, ISTOP + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (NOTB) THEN + IF (NOTA) THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + IF (BETA.EQ.ZERO) THEN + DO 50 I = ISTART, ISTOP + C(I,J) = ZERO + 50 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 60 I = ISTART, ISTOP + C(I,J) = BETA*C(I,J) + 60 CONTINUE + END IF + DO 80 L = 1,K + TEMP = ALPHA*B(L,J) + DO 70 I = ISTART, ISTOP + C(I,J) = C(I,J) + TEMP*A(I,L) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + ELSE +* +* Form C := alpha*A**T*B + beta*C +* + DO 120 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 110 I = ISTART, ISTOP + TEMP = ZERO + DO 100 L = 1,K + TEMP = TEMP + A(L,I)*B(L,J) + 100 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 110 CONTINUE + 120 CONTINUE + END IF + ELSE + IF (NOTA) THEN +* +* Form C := alpha*A*B**T + beta*C +* + DO 170 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + IF (BETA.EQ.ZERO) THEN + DO 130 I = ISTART,ISTOP + C(I,J) = ZERO + 130 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 140 I = ISTART,ISTOP + C(I,J) = BETA*C(I,J) + 140 CONTINUE + END IF + DO 160 L = 1,K + TEMP = ALPHA*B(J,L) + DO 150 I = ISTART,ISTOP + C(I,J) = C(I,J) + TEMP*A(I,L) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + ELSE +* +* Form C := alpha*A**T*B**T + beta*C +* + DO 200 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 190 I = ISTART, ISTOP + TEMP = ZERO + DO 180 L = 1,K + TEMP = TEMP + A(L,I)*B(J,L) + 180 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 190 CONTINUE + 200 CONTINUE + END IF + END IF +* + RETURN +* +* End of SGEMM +* + END diff --git a/BLAS/SRC/sgemmt.f b/BLAS/SRC/sgemmt.f new file mode 100644 index 0000000000..3875e63664 --- /dev/null +++ b/BLAS/SRC/sgemmt.f @@ -0,0 +1,432 @@ +*> \brief \b SGEMMT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA, +* C,LDC) +* +* .. Scalar Arguments .. +* REAL ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,N +* CHARACTER TRANSA,TRANSB, UPLO +* .. +* .. Array Arguments .. +* REAL A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SGEMMT performs one of the matrix-matrix operations +*> +*> C := alpha*op( A )*op( B ) + beta*C, +*> +*> where op( X ) is one of +*> +*> op( X ) = X or op( X ) = X**T, +*> +*> alpha and beta are scalars, and A, B and C are matrices, with op( A ) +*> an n by k matrix, op( B ) a k by n matrix and C an n by n matrix. +*> Thereby, the routine only accesses and updates the upper or lower +*> triangular part of the result matrix C. This behaviour can be used, +*> the resulting matrix C is known to be symmetric. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the lower or the upper +*> triangular part of C is access and updated. +*> +*> UPLO = 'L' or 'l', the lower tringular part of C is used. +*> +*> UPLO = 'U' or 'u', the upper tringular part of C is used. +*> \endverbatim +* +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n', op( A ) = A. +*> +*> TRANSA = 'T' or 't', op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c', op( A ) = A**T. +*> \endverbatim +*> +*> \param[in] TRANSB +*> \verbatim +*> TRANSB is CHARACTER*1 +*> On entry, TRANSB specifies the form of op( B ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSB = 'N' or 'n', op( B ) = B. +*> +*> TRANSB = 'T' or 't', op( B ) = B**T. +*> +*> TRANSB = 'C' or 'c', op( B ) = B**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of rows and columns of +*> the matrix C, the number of columns of op(B) and the number +*> of rows of op(A). N must be at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry, K specifies the number of columns of the matrix +*> op( A ) and the number of rows of the matrix op( B ). K must +*> be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is REAL. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension ( LDA, ka ), where ka is +*> k when TRANSA = 'N' or 'n', and is n otherwise. +*> Before entry with TRANSA = 'N' or 'n', the leading n by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by m part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANSA = 'N' or 'n' then +*> LDA must be at least max( 1, n ), otherwise LDA must be at +*> least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is REAL array, dimension ( LDB, kb ), where kb is +*> n when TRANSB = 'N' or 'n', and is k otherwise. +*> Before entry with TRANSB = 'N' or 'n', the leading k by n +*> part of the array B must contain the matrix B, otherwise +*> the leading n by k part of the array B must contain the +*> matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. When TRANSB = 'N' or 'n' then +*> LDB must be at least max( 1, k ), otherwise LDB must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is REAL. +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is REAL array, dimension ( LDC, N ) +*> Before entry, the leading n by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the upper or lower trinangular part of the matrix +*> C is overwritten by the n by n matrix +*> ( alpha*op( A )*op( B ) + beta*C ). +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Martin Koehler +* +*> \ingroup gemm +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 19-July-2023. +*> Martin Koehler, MPI Magdeburg +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB, + + BETA,C,LDC) + IMPLICIT NONE +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL ALPHA,BETA + INTEGER K,LDA,LDB,LDC,N + CHARACTER TRANSA,TRANSB,UPLO +* .. +* .. Array Arguments .. + REAL A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,J,L,NROWA,NROWB, ISTART, ISTOP + LOGICAL NOTA,NOTB, UPPER +* .. +* .. Parameters .. + REAL ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) +* .. +* +* Set NOTA and NOTB as true if A and B respectively are not +* transposed and set NROWA and NROWB as the number of rows of A +* and B respectively. +* + NOTA = LSAME(TRANSA,'N') + NOTB = LSAME(TRANSB,'N') + IF (NOTA) THEN + NROWA = N + ELSE + NROWA = K + END IF + IF (NOTB) THEN + NROWB = K + ELSE + NROWB = N + END IF + UPPER = LSAME(UPLO, 'U') +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT. UPPER) .AND. (.NOT. LSAME(UPLO, 'L'))) THEN + INFO = 1 + ELSE IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND. + + (.NOT.LSAME(TRANSA,'T'))) THEN + INFO = 2 + ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND. + + (.NOT.LSAME(TRANSB,'T'))) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 8 + ELSE IF (LDB.LT.MAX(1,NROWB)) THEN + INFO = 10 + ELSE IF (LDC.LT.MAX(1,N)) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('SGEMMT',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. + + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And if alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 10 I = ISTART, ISTOP + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 30 I = ISTART, ISTOP + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (NOTB) THEN + IF (NOTA) THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + IF (BETA.EQ.ZERO) THEN + DO 50 I = ISTART, ISTOP + C(I,J) = ZERO + 50 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 60 I = ISTART, ISTOP + C(I,J) = BETA*C(I,J) + 60 CONTINUE + END IF + DO 80 L = 1,K + TEMP = ALPHA*B(L,J) + DO 70 I = ISTART, ISTOP + C(I,J) = C(I,J) + TEMP*A(I,L) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + ELSE +* +* Form C := alpha*A**T*B + beta*C +* + DO 120 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 110 I = ISTART, ISTOP + TEMP = ZERO + DO 100 L = 1,K + TEMP = TEMP + A(L,I)*B(L,J) + 100 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 110 CONTINUE + 120 CONTINUE + END IF + ELSE + IF (NOTA) THEN +* +* Form C := alpha*A*B**T + beta*C +* + DO 170 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + IF (BETA.EQ.ZERO) THEN + DO 130 I = ISTART,ISTOP + C(I,J) = ZERO + 130 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 140 I = ISTART,ISTOP + C(I,J) = BETA*C(I,J) + 140 CONTINUE + END IF + DO 160 L = 1,K + TEMP = ALPHA*B(J,L) + DO 150 I = ISTART,ISTOP + C(I,J) = C(I,J) + TEMP*A(I,L) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + ELSE +* +* Form C := alpha*A**T*B**T + beta*C +* + DO 200 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 190 I = ISTART, ISTOP + TEMP = ZERO + DO 180 L = 1,K + TEMP = TEMP + A(L,I)*B(J,L) + 180 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 190 CONTINUE + 200 CONTINUE + END IF + END IF +* + RETURN +* +* End of SGEMMT +* + END diff --git a/BLAS/SRC/zgemmt.f b/BLAS/SRC/zgemmt.f new file mode 100644 index 0000000000..37828abaad --- /dev/null +++ b/BLAS/SRC/zgemmt.f @@ -0,0 +1,570 @@ +*> \brief \b ZGEMMT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA, +* C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,N +* CHARACTER TRANSA,TRANSB, UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEMMT performs one of the matrix-matrix operations +*> +*> C := alpha*op( A )*op( B ) + beta*C, +*> +*> where op( X ) is one of +*> +*> op( X ) = X or op( X ) = X**T, +*> +*> alpha and beta are scalars, and A, B and C are matrices, with op( A ) +*> an n by k matrix, op( B ) a k by n matrix and C an n by n matrix. +*> Thereby, the routine only accesses and updates the upper or lower +*> triangular part of the result matrix C. This behaviour can be used, +*> the resulting matrix C is known to be symmetric. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the lower or the upper +*> triangular part of C is access and updated. +*> +*> UPLO = 'L' or 'l', the lower tringular part of C is used. +*> +*> UPLO = 'U' or 'u', the upper tringular part of C is used. +*> \endverbatim +* +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n', op( A ) = A. +*> +*> TRANSA = 'T' or 't', op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c', op( A ) = A**H. +*> \endverbatim +*> +*> \param[in] TRANSB +*> \verbatim +*> TRANSB is CHARACTER*1 +*> On entry, TRANSB specifies the form of op( B ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSB = 'N' or 'n', op( B ) = B. +*> +*> TRANSB = 'T' or 't', op( B ) = B**T. +*> +*> TRANSB = 'C' or 'c', op( B ) = B**H. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of rows and columns of +*> the matrix C, the number of columns of op(B) and the number +*> of rows of op(A). N must be at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry, K specifies the number of columns of the matrix +*> op( A ) and the number of rows of the matrix op( B ). K must +*> be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, ka ), where ka is +*> k when TRANSA = 'N' or 'n', and is n otherwise. +*> Before entry with TRANSA = 'N' or 'n', the leading n by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by m part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANSA = 'N' or 'n' then +*> LDA must be at least max( 1, n ), otherwise LDA must be at +*> least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is COMPLEX*16 array, dimension ( LDB, kb ), where kb is +*> n when TRANSB = 'N' or 'n', and is k otherwise. +*> Before entry with TRANSB = 'N' or 'n', the leading k by n +*> part of the array B must contain the matrix B, otherwise +*> the leading n by k part of the array B must contain the +*> matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. When TRANSB = 'N' or 'n' then +*> LDB must be at least max( 1, k ), otherwise LDB must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX*16. +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension ( LDC, N ) +*> Before entry, the leading n by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the upper or lower trinangular part of the matrix +*> C is overwritten by the n by n matrix +*> ( alpha*op( A )*op( B ) + beta*C ). +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Martin Koehler +* +*> \ingroup gemm +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 19-July-2023. +*> Martin Koehler, MPI Magdeburg +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB, + + BETA,C,LDC) + IMPLICIT NONE +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA,BETA + INTEGER K,LDA,LDB,LDC,N + CHARACTER TRANSA,TRANSB,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG,MAX +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,J,L,NROWA,NROWB,ISTART, ISTOP + LOGICAL CONJA,CONJB,NOTA,NOTB,UPPER +* .. +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0E+0,0.0E+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* +* Set NOTA and NOTB as true if A and B respectively are not +* conjugated or transposed, set CONJA and CONJB as true if A and +* B respectively are to be transposed but not conjugated and set +* NROWA and NROWB as the number of rows of A and B respectively. +* + NOTA = LSAME(TRANSA,'N') + NOTB = LSAME(TRANSB,'N') + CONJA = LSAME(TRANSA,'C') + CONJB = LSAME(TRANSB,'C') + IF (NOTA) THEN + NROWA = N + ELSE + NROWA = K + END IF + IF (NOTB) THEN + NROWB = K + ELSE + NROWB = N + END IF + UPPER = LSAME(UPLO, 'U') + +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT. UPPER) .AND. (.NOT. LSAME(UPLO, 'L'))) THEN + INFO = 1 + ELSE IF ((.NOT.NOTA) .AND. (.NOT.CONJA) .AND. + + (.NOT.LSAME(TRANSA,'T'))) THEN + INFO = 2 + ELSE IF ((.NOT.NOTB) .AND. (.NOT.CONJB) .AND. + + (.NOT.LSAME(TRANSB,'T'))) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 8 + ELSE IF (LDB.LT.MAX(1,NROWB)) THEN + INFO = 10 + ELSE IF (LDC.LT.MAX(1,N)) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZGEMMT',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. + + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 10 I = ISTART, ISTOP + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + DO 30 I = ISTART, ISTOP + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (NOTB) THEN + IF (NOTA) THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + IF (BETA.EQ.ZERO) THEN + DO 50 I = ISTART, ISTOP + C(I,J) = ZERO + 50 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 60 I = ISTART, ISTOP + C(I,J) = BETA*C(I,J) + 60 CONTINUE + END IF + DO 80 L = 1,K + TEMP = ALPHA*B(L,J) + DO 70 I = ISTART, ISTOP + C(I,J) = C(I,J) + TEMP*A(I,L) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + ELSE IF (CONJA) THEN +* +* Form C := alpha*A**H*B + beta*C. +* + DO 120 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 110 I = ISTART, ISTOP + TEMP = ZERO + DO 100 L = 1,K + TEMP = TEMP + CONJG(A(L,I))*B(L,J) + 100 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 110 CONTINUE + 120 CONTINUE + ELSE +* +* Form C := alpha*A**T*B + beta*C +* + DO 150 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 140 I = ISTART, ISTOP + TEMP = ZERO + DO 130 L = 1,K + TEMP = TEMP + A(L,I)*B(L,J) + 130 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 140 CONTINUE + 150 CONTINUE + END IF + ELSE IF (NOTA) THEN + IF (CONJB) THEN +* +* Form C := alpha*A*B**H + beta*C. +* + DO 200 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + IF (BETA.EQ.ZERO) THEN + DO 160 I = ISTART,ISTOP + C(I,J) = ZERO + 160 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 170 I = ISTART, ISTOP + C(I,J) = BETA*C(I,J) + 170 CONTINUE + END IF + DO 190 L = 1,K + TEMP = ALPHA*CONJG(B(J,L)) + DO 180 I = ISTART, ISTOP + C(I,J) = C(I,J) + TEMP*A(I,L) + 180 CONTINUE + 190 CONTINUE + 200 CONTINUE + ELSE +* +* Form C := alpha*A*B**T + beta*C +* + DO 250 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + IF (BETA.EQ.ZERO) THEN + DO 210 I = ISTART, ISTOP + C(I,J) = ZERO + 210 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 220 I = ISTART, ISTOP + C(I,J) = BETA*C(I,J) + 220 CONTINUE + END IF + DO 240 L = 1,K + TEMP = ALPHA*B(J,L) + DO 230 I = ISTART, ISTOP + C(I,J) = C(I,J) + TEMP*A(I,L) + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + END IF + ELSE IF (CONJA) THEN + IF (CONJB) THEN +* +* Form C := alpha*A**H*B**H + beta*C. +* + DO 280 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 270 I = ISTART, ISTOP + TEMP = ZERO + DO 260 L = 1,K + TEMP = TEMP + CONJG(A(L,I))*CONJG(B(J,L)) + 260 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 270 CONTINUE + 280 CONTINUE + ELSE +* +* Form C := alpha*A**H*B**T + beta*C +* + DO 310 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 300 I = ISTART, ISTOP + TEMP = ZERO + DO 290 L = 1,K + TEMP = TEMP + CONJG(A(L,I))*B(J,L) + 290 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 300 CONTINUE + 310 CONTINUE + END IF + ELSE + IF (CONJB) THEN +* +* Form C := alpha*A**T*B**H + beta*C +* + DO 340 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 330 I = ISTART, ISTOP + TEMP = ZERO + DO 320 L = 1,K + TEMP = TEMP + A(L,I)*CONJG(B(J,L)) + 320 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 330 CONTINUE + 340 CONTINUE + ELSE +* +* Form C := alpha*A**T*B**T + beta*C +* + DO 370 J = 1,N + IF (UPPER) THEN + ISTART = 1 + ISTOP = J + ELSE + ISTART = J + ISTOP = N + END IF + + DO 360 I = ISTART, ISTOP + TEMP = ZERO + DO 350 L = 1,K + TEMP = TEMP + A(L,I)*B(J,L) + 350 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 360 CONTINUE + 370 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZGEMMT +* + END diff --git a/BLAS/TESTING/cblat3.f b/BLAS/TESTING/cblat3.f index 18adeba6d5..a8cd24c123 100644 --- a/BLAS/TESTING/cblat3.f +++ b/BLAS/TESTING/cblat3.f @@ -19,7 +19,7 @@ *> Test program for the COMPLEX Level 3 Blas. *> *> The program must be driven by a short data file. The first 14 records -*> of the file are read using list-directed input, the last 9 records +*> of the file are read using list-directed input, the last 10 records *> are read using the format ( A6, L2 ). An annotated example of a data *> file can be obtained by deleting the first 3 characters from the *> following 23 lines: @@ -46,6 +46,7 @@ *> CSYRK T PUT F FOR NO TEST. SAME COLUMNS. *> CHER2K T PUT F FOR NO TEST. SAME COLUMNS. *> CSYR2K T PUT F FOR NO TEST. SAME COLUMNS. +*> CGEMMT T PUT F FOR NO TEST. SAME COLUMNS. *> *> Further Details *> =============== @@ -93,7 +94,7 @@ PROGRAM CBLAT3 INTEGER NIN PARAMETER ( NIN = 5 ) INTEGER NSUBS - PARAMETER ( NSUBS = 9 ) + PARAMETER ( NSUBS = 10 ) COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) REAL RZERO @@ -127,6 +128,7 @@ PROGRAM CBLAT3 EXTERNAL SDIFF, LCE * .. External Subroutines .. EXTERNAL CCHK1, CCHK2, CCHK3, CCHK4, CCHK5, CCHKE, CMMCH + EXTERNAL CCHK6 * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Scalars in Common .. @@ -139,7 +141,7 @@ PROGRAM CBLAT3 * .. Data statements .. DATA SNAMES/'CGEMM ', 'CHEMM ', 'CSYMM ', 'CTRMM ', $ 'CTRSM ', 'CHERK ', 'CSYRK ', 'CHER2K', - $ 'CSYR2K'/ + $ 'CSYR2K', 'CGEMMT'/ * .. Executable Statements .. * * Read name and unit number for summary output file and open file. @@ -317,7 +319,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 CALL CCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, @@ -346,6 +348,11 @@ PROGRAM CBLAT3 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) GO TO 190 + 185 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 ) + * 190 IF( FATAL.AND.SFATAL ) $ GO TO 210 @@ -2031,7 +2038,7 @@ SUBROUTINE CCHKE( ISNUM, SRNAMT, NOUT ) RBETA = TWO * GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, - $ 90 )ISNUM + $ 90, 100 )ISNUM 10 INFOT = 1 CALL CGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2212,7 +2219,7 @@ SUBROUTINE CCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 13 CALL CGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 + GO TO 110 20 INFOT = 1 CALL CHEMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2279,7 +2286,7 @@ SUBROUTINE CCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 12 CALL CHEMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 + GO TO 110 30 INFOT = 1 CALL CSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2346,7 +2353,7 @@ SUBROUTINE CCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 12 CALL CSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 + GO TO 110 40 INFOT = 1 CALL CTRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2503,7 +2510,7 @@ SUBROUTINE CCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 11 CALL CTRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 + GO TO 110 50 INFOT = 1 CALL CTRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2660,7 +2667,7 @@ SUBROUTINE CCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 11 CALL CTRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 + GO TO 110 60 INFOT = 1 CALL CHERK( '/', 'N', 0, 0, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2715,7 +2722,7 @@ SUBROUTINE CCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 10 CALL CHERK( 'L', 'C', 2, 0, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 + GO TO 110 70 INFOT = 1 CALL CSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2770,7 +2777,7 @@ SUBROUTINE CCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 10 CALL CSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 + GO TO 110 80 INFOT = 1 CALL CHER2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2837,7 +2844,7 @@ SUBROUTINE CCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 12 CALL CHER2K( 'L', 'C', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 + GO TO 110 90 INFOT = 1 CALL CSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2904,8 +2911,186 @@ SUBROUTINE CCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 12 CALL CSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + GO TO 110 + 100 INFOT = 1 + CALL CGEMMT( '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL CGEMMT( '/', 'N', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL CGEMMT( '/', 'N', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL CGEMMT( '/', 'T', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL CGEMMT( '/', 'T', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL CGEMMT( '/', 'T', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL CGEMMT( '/', 'C', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL CGEMMT( '/', 'C', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL CGEMMT( '/', 'C', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + + INFOT = 2 + CALL CGEMMT( 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGEMMT( 'U', '/', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGEMMT( 'U', '/', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGEMMT( 'L', '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGEMMT( 'L', '/', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGEMMT( 'L', '/', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + + INFOT = 3 + CALL CGEMMT( 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CGEMMT( 'U', 'C', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CGEMMT( 'U', 'T', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGEMMT( 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGEMMT( 'U', 'N', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGEMMT( 'U', 'N', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGEMMT( 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGEMMT( 'U', 'C', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGEMMT( 'U', 'C', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGEMMT( 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGEMMT( 'U', 'T', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGEMMT( 'U', 'T', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGEMMT( 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGEMMT( 'U', 'N', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGEMMT( 'U', 'N', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGEMMT( 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGEMMT( 'U', 'C', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGEMMT( 'U', 'C', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGEMMT( 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGEMMT( 'U', 'T', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGEMMT( 'U', 'T', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + + INFOT = 8 + CALL CGEMMT( 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CGEMMT( 'U', 'N', 'C', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CGEMMT( 'U', 'N', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CGEMMT( 'U', 'C', 'N', 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CGEMMT( 'U', 'C', 'C', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CGEMMT( 'U', 'C', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CGEMMT( 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CGEMMT( 'U', 'T', 'C', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CGEMMT( 'U', 'T', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + + INFOT = 10 + CALL CGEMMT( 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CGEMMT( 'U', 'C', 'N', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CGEMMT( 'U', 'T', 'N', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL CGEMMT( 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL CGEMMT( 'U', 'N', 'C', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL CGEMMT( 'U', 'N', 'T', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL CGEMMT( 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL CGEMMT( 'U', 'C', 'C', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL CGEMMT( 'U', 'C', 'T', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL CGEMMT( 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL CGEMMT( 'U', 'T', 'C', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL CGEMMT( 'U', 'T', 'T', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + GO TO 110 + * - 100 IF( OK )THEN + 110 IF( OK )THEN WRITE( NOUT, FMT = 9999 )SRNAMT ELSE WRITE( NOUT, FMT = 9998 )SRNAMT @@ -3486,3 +3671,496 @@ SUBROUTINE XERBLA( SRNAME, INFO ) * End of XERBLA * 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 ) +* +* Tests CGEMMT. +* +* Auxiliary routine for test program for Level 3 Blas. +* +* -- Written on 8-February-1989. +* Jack Dongarra, Argonne National Laboratory. +* Iain Duff, AERE Harwell. +* Jeremy Du Croz, Numerical Algorithms Group Ltd. +* Sven Hammarling, Numerical Algorithms Group Ltd. +* +* .. Parameters .. + 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 + LOGICAL FATAL, REWI, TRACE + CHARACTER*6 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, IN, K, KS, LAA, + $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M, + $ 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 CGEMM, CMAKE, CMMCH +* .. 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, ' ', M, 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 ) + $ WRITE( NTRA, FMT = 9995 )NC, SNAME, UPLO + $ TRANSA, TRANSB, N, K, ALPHA, LDA, LDB, + $ BETA, LDC + IF( REWI ) + $ REWIND NTRA + CALL CGEMMT( 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 ) = UPLOS.EQ.UPLO + 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', ' ', M, 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 + WRITE( NOUT, FMT = 9999 )SNAME, NC + ELSE + WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX + END IF + GO TO 130 +* + 120 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, M, N, K, + $ ALPHA, LDA, LDB, BETA, LDC +* + 130 CONTINUE + RETURN +* + 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + $ 'S)' ) + 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, + $ ' - SUSPECT *******' ) + 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A6, '(''',A1, ''',''',A1, ''',''', 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 *', + $ '******' ) +* +* End of CCHK6 +* + 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. +* +* Auxiliary routine for test program for Level 3 Blas. +* +* -- Written on 8-February-1989. +* Jack Dongarra, Argonne National Laboratory. +* Iain Duff, AERE Harwell. +* Jeremy Du Croz, Numerical Algorithms Group Ltd. +* Sven Hammarling, Numerical Algorithms Group Ltd. +* +* .. Parameters .. + 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' +* +* Compute expected result, one column at a time, in CT using data +* in A, B and C. +* Compute gauges in G. +* + ISTART = 1 + ISTOP = 1 + + 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/BLAS/TESTING/cblat3.in b/BLAS/TESTING/cblat3.in index f1480557a1..686fe64084 100644 --- a/BLAS/TESTING/cblat3.in +++ b/BLAS/TESTING/cblat3.in @@ -21,3 +21,4 @@ CHERK T PUT F FOR NO TEST. SAME COLUMNS. CSYRK T PUT F FOR NO TEST. SAME COLUMNS. CHER2K T PUT F FOR NO TEST. SAME COLUMNS. CSYR2K T PUT F FOR NO TEST. SAME COLUMNS. +CGEMMT T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/BLAS/TESTING/dblat3.f b/BLAS/TESTING/dblat3.f index 89087d539c..ddfbbfbd6a 100644 --- a/BLAS/TESTING/dblat3.f +++ b/BLAS/TESTING/dblat3.f @@ -19,10 +19,10 @@ *> Test program for the DOUBLE PRECISION Level 3 Blas. *> *> The program must be driven by a short data file. The first 14 records -*> of the file are read using list-directed input, the last 6 records +*> of the file are read using list-directed input, the last 7 records *> are read using the format ( A6, L2 ). An annotated example of a data *> file can be obtained by deleting the first 3 characters from the -*> following 20 lines: +*> following 21 lines: *> 'dblat3.out' NAME OF SUMMARY OUTPUT FILE *> 6 UNIT NUMBER OF SUMMARY FILE *> 'DBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE @@ -43,6 +43,7 @@ *> DTRSM T PUT F FOR NO TEST. SAME COLUMNS. *> DSYRK T PUT F FOR NO TEST. SAME COLUMNS. *> DSYR2K T PUT F FOR NO TEST. SAME COLUMNS. +*> DGEMMT T PUT F FOR NO TEST. SAME COLUMNS. *> *> Further Details *> =============== @@ -90,7 +91,7 @@ PROGRAM DBLAT3 INTEGER NIN PARAMETER ( NIN = 5 ) INTEGER NSUBS - PARAMETER ( NSUBS = 6 ) + PARAMETER ( NSUBS = 7 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) INTEGER NMAX @@ -132,7 +133,7 @@ PROGRAM DBLAT3 COMMON /SRNAMC/SRNAMT * .. Data statements .. DATA SNAMES/'DGEMM ', 'DSYMM ', 'DTRMM ', 'DTRSM ', - $ 'DSYRK ', 'DSYR2K'/ + $ 'DSYRK ', 'DSYR2K', 'DGEMMT'/ * .. Executable Statements .. * * Read name and unit number for summary output file and open file. @@ -309,7 +310,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 CALL DCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, @@ -338,6 +339,12 @@ PROGRAM DBLAT3 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) GO TO 190 +* Test DGEMMT, 07. + 185 CALL DCHK6( 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 ) + * 190 IF( FATAL.AND.SFATAL ) $ GO TO 210 @@ -1882,7 +1889,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) ALPHA = ONE BETA = TWO * - GO TO ( 10, 20, 30, 40, 50, 60 )ISNUM + GO TO ( 10, 20, 30, 40, 50, 60, 70 )ISNUM 10 INFOT = 1 CALL DGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -1967,7 +1974,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 13 CALL DGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 + GO TO 80 20 INFOT = 1 CALL DSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2034,7 +2041,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 12 CALL DSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 + GO TO 80 30 INFOT = 1 CALL DTRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2143,7 +2150,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 11 CALL DTRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 + GO TO 80 40 INFOT = 1 CALL DTRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2252,7 +2259,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 11 CALL DTRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 + GO TO 80 50 INFOT = 1 CALL DSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2307,7 +2314,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 10 CALL DSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 + GO TO 80 60 INFOT = 1 CALL DSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2374,8 +2381,78 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 12 CALL DSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + GO TO 80 + 70 INFOT = 1 + CALL DGEMMT( '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGEMMT( 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGEMMT( 'U', '/', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DGEMMT( 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DGEMMT( 'U', 'T', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGEMMT( 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGEMMT( 'U', 'N', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGEMMT( 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGEMMT( 'U', 'T', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DGEMMT( 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DGEMMT( 'U', 'N', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DGEMMT( 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DGEMMT( 'U', 'T', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DGEMMT( 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DGEMMT( 'U', 'N', 'T', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DGEMMT( 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DGEMMT( 'U', 'T', 'N', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DGEMMT( 'U', 'N', 'T', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DGEMMT( 'U', 'T', 'T', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL DGEMMT( 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL DGEMMT( 'U', 'N', 'T', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL DGEMMT( 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL DGEMMT( 'U', 'T', 'T', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) * - 70 IF( OK )THEN + 80 IF( OK )THEN WRITE( NOUT, FMT = 9999 )SRNAMT ELSE WRITE( NOUT, FMT = 9998 )SRNAMT @@ -2867,3 +2944,420 @@ SUBROUTINE XERBLA( SRNAME, INFO ) * End of XERBLA * 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 ) +* +* Tests DGEMMT. +* +* 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 + LOGICAL FATAL, REWI, TRACE + CHARACTER*6 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 DGEMMT, 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 ) + $ WRITE( NTRA, FMT = 9995 )NC, SNAME, + $ UPLO, TRANSA, TRANSB, N, K, ALPHA, LDA, + $ LDB, BETA, LDC + IF( REWI ) + $ REWIND NTRA + CALL DGEMMT( 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', ' ', M, 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 + WRITE( NOUT, FMT = 9999 )SNAME, NC + ELSE + WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX + END IF + GO TO 130 +* + 120 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, TRANSA, TRANSB, N, K, + $ ALPHA, LDA, LDB, BETA, LDC +* + 130 CONTINUE + RETURN +* + 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + $ 'S)' ) + 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, + $ ' - SUSPECT *******' ) + 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A6, '(''',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 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. (DGEMMT) +* +* -- 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/BLAS/TESTING/dblat3.in b/BLAS/TESTING/dblat3.in index 0098f3e521..82e571ee84 100644 --- a/BLAS/TESTING/dblat3.in +++ b/BLAS/TESTING/dblat3.in @@ -18,3 +18,4 @@ DTRMM T PUT F FOR NO TEST. SAME COLUMNS. DTRSM T PUT F FOR NO TEST. SAME COLUMNS. DSYRK T PUT F FOR NO TEST. SAME COLUMNS. DSYR2K T PUT F FOR NO TEST. SAME COLUMNS. +DGEMMT T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/BLAS/TESTING/sblat3.f b/BLAS/TESTING/sblat3.f index c4c1fccee8..a0522d96e8 100644 --- a/BLAS/TESTING/sblat3.f +++ b/BLAS/TESTING/sblat3.f @@ -19,7 +19,7 @@ *> Test program for the REAL Level 3 Blas. *> *> The program must be driven by a short data file. The first 14 records -*> of the file are read using list-directed input, the last 6 records +*> of the file are read using list-directed input, the last 7 records *> are read using the format ( A6, L2 ). An annotated example of a data *> file can be obtained by deleting the first 3 characters from the *> following 20 lines: @@ -43,6 +43,7 @@ *> STRSM T PUT F FOR NO TEST. SAME COLUMNS. *> SSYRK T PUT F FOR NO TEST. SAME COLUMNS. *> SSYR2K T PUT F FOR NO TEST. SAME COLUMNS. +*> SGEMMT T PUT F FOR NO TEST. SAME COLUMNS. *> *> Further Details *> =============== @@ -90,7 +91,7 @@ PROGRAM SBLAT3 INTEGER NIN PARAMETER ( NIN = 5 ) INTEGER NSUBS - PARAMETER ( NSUBS = 6 ) + PARAMETER ( NSUBS = 7 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0, ONE = 1.0 ) INTEGER NMAX @@ -132,7 +133,7 @@ PROGRAM SBLAT3 COMMON /SRNAMC/SRNAMT * .. Data statements .. DATA SNAMES/'SGEMM ', 'SSYMM ', 'STRMM ', 'STRSM ', - $ 'SSYRK ', 'SSYR2K'/ + $ 'SSYRK ', 'SSYR2K', 'SGEMMT'/ * .. Executable Statements .. * * Read name and unit number for summary output file and open file. @@ -309,7 +310,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 CALL SCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, @@ -338,6 +339,12 @@ PROGRAM SBLAT3 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) GO TO 190 +* Test SGEMMT, 07. + 185 CALL SCHK6( 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 ) + GO TO 190 * 190 IF( FATAL.AND.SFATAL ) $ GO TO 210 @@ -1866,7 +1873,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) REAL A( 2, 1 ), B( 2, 1 ), C( 2, 1 ) * .. External Subroutines .. EXTERNAL CHKXER, SGEMM, SSYMM, SSYR2K, SSYRK, STRMM, - $ STRSM + $ STRSM, SGEMMT * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR * .. Executable Statements .. @@ -1882,7 +1889,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) ALPHA = ONE BETA = TWO * - GO TO ( 10, 20, 30, 40, 50, 60 )ISNUM + GO TO ( 10, 20, 30, 40, 50, 60, 70 )ISNUM 10 INFOT = 1 CALL SGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -1967,7 +1974,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 13 CALL SGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 + GO TO 80 20 INFOT = 1 CALL SSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2034,7 +2041,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 12 CALL SSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 + GO TO 80 30 INFOT = 1 CALL STRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2143,7 +2150,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 11 CALL STRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 + GO TO 80 40 INFOT = 1 CALL STRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2252,7 +2259,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 11 CALL STRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 + GO TO 80 50 INFOT = 1 CALL SSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2307,7 +2314,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 10 CALL SSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 70 + GO TO 80 60 INFOT = 1 CALL SSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2374,8 +2381,78 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 12 CALL SSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + GO TO 80 + 70 INFOT = 1 + CALL SGEMMT( '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGEMMT( 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGEMMT( 'U', '/', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SGEMMT( 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SGEMMT( 'U', 'T', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGEMMT( 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGEMMT( 'U', 'N', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGEMMT( 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGEMMT( 'U', 'T', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SGEMMT( 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SGEMMT( 'U', 'N', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SGEMMT( 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SGEMMT( 'U', 'T', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SGEMMT( 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SGEMMT( 'U', 'N', 'T', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SGEMMT( 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SGEMMT( 'U', 'T', 'N', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SGEMMT( 'U', 'N', 'T', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SGEMMT( 'U', 'T', 'T', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL SGEMMT( 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL SGEMMT( 'U', 'N', 'T', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL SGEMMT( 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL SGEMMT( 'U', 'T', 'T', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) * - 70 IF( OK )THEN + 80 IF( OK )THEN WRITE( NOUT, FMT = 9999 )SRNAMT ELSE WRITE( NOUT, FMT = 9998 )SRNAMT @@ -2865,5 +2942,422 @@ SUBROUTINE XERBLA( SRNAME, INFO ) $ ' *******' ) * * End of XERBLA +* + 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 ) +* +* Tests SGEMMT. +* +* Auxiliary routine for test program for Level 3 Blas. +* +* -- Written on 19-July-2023. +* Martin Koehler, MPI Magdeburg +* +* .. Parameters .. + REAL ZERO + PARAMETER ( ZERO = 0.0D0 ) +* .. Scalar Arguments .. + REAL EPS, THRESH + INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA + LOGICAL FATAL, REWI, TRACE + CHARACTER*6 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 SGEMMT, 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 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 ) + $ WRITE( NTRA, FMT = 9995 )NC, SNAME, + $ UPLO, TRANSA, TRANSB, N, K, ALPHA, LDA, + $ LDB, BETA, LDC + IF( REWI ) + $ REWIND NTRA + CALL SGEMMT( 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', ' ', M, 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 + WRITE( NOUT, FMT = 9999 )SNAME, NC + ELSE + WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX + END IF + GO TO 130 +* + 120 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, TRANSA, TRANSB, N, K, + $ ALPHA, LDA, LDB, BETA, LDC +* + 130 CONTINUE + RETURN +* + 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + $ 'S)' ) + 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, + $ ' - SUSPECT *******' ) + 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A6, '(''',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 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. (SGEMMT) +* +* -- Written on 19-July-2023. +* Martin Koehler, MPI Magdeburg +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. 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 DMMTCH * END diff --git a/BLAS/TESTING/sblat3.in b/BLAS/TESTING/sblat3.in index 5c4e3b83e1..9741a5dd61 100644 --- a/BLAS/TESTING/sblat3.in +++ b/BLAS/TESTING/sblat3.in @@ -18,3 +18,4 @@ STRMM T PUT F FOR NO TEST. SAME COLUMNS. STRSM T PUT F FOR NO TEST. SAME COLUMNS. SSYRK T PUT F FOR NO TEST. SAME COLUMNS. SSYR2K T PUT F FOR NO TEST. SAME COLUMNS. +SGEMMT T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/BLAS/TESTING/zblat3.f b/BLAS/TESTING/zblat3.f index fb4d8019e9..9b54f6be8f 100644 --- a/BLAS/TESTING/zblat3.f +++ b/BLAS/TESTING/zblat3.f @@ -19,7 +19,7 @@ *> Test program for the COMPLEX*16 Level 3 Blas. *> *> The program must be driven by a short data file. The first 14 records -*> of the file are read using list-directed input, the last 9 records +*> of the file are read using list-directed input, the last 10 records *> are read using the format ( A6, L2 ). An annotated example of a data *> file can be obtained by deleting the first 3 characters from the *> following 23 lines: @@ -46,6 +46,7 @@ *> 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. +*> ZGEMMT T PUT F FOR NO TEST. SAME COLUMNS. *> *> *> Further Details @@ -94,7 +95,7 @@ PROGRAM ZBLAT3 INTEGER NIN PARAMETER ( NIN = 5 ) INTEGER NSUBS - PARAMETER ( NSUBS = 9 ) + PARAMETER ( NSUBS = 10 ) COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), $ ONE = ( 1.0D0, 0.0D0 ) ) @@ -128,7 +129,8 @@ PROGRAM ZBLAT3 LOGICAL LZE EXTERNAL DDIFF, LZE * .. External Subroutines .. - EXTERNAL ZCHK1, ZCHK2, ZCHK3, ZCHK4, ZCHK5, ZCHKE, ZMMCH + EXTERNAL ZCHK1, ZCHK2, ZCHK3, ZCHK4, ZCHK5, ZCHK6 + EXTERNAL ZCHKE, ZMMCH * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Scalars in Common .. @@ -141,7 +143,7 @@ PROGRAM ZBLAT3 * .. Data statements .. DATA SNAMES/'ZGEMM ', 'ZHEMM ', 'ZSYMM ', 'ZTRMM ', $ 'ZTRSM ', 'ZHERK ', 'ZSYRK ', 'ZHER2K', - $ 'ZSYR2K'/ + $ 'ZSYR2K', 'ZGEMMT'/ * .. Executable Statements .. * * Read name and unit number for summary output file and open file. @@ -319,7 +321,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 CALL ZCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, @@ -348,6 +350,13 @@ PROGRAM ZBLAT3 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) GO TO 190 +* Test ZGEMMT, 01. + 185 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 ) + GO TO 190 + * 190 IF( FATAL.AND.SFATAL ) $ GO TO 210 @@ -2008,7 +2017,7 @@ SUBROUTINE ZCHKE( ISNUM, SRNAMT, NOUT ) INTEGER INFOT, NOUTC LOGICAL LERR, OK * .. Parameters .. - REAL ONE, TWO + DOUBLE PRECISION ONE, TWO PARAMETER ( ONE = 1.0D0, TWO = 2.0D0 ) * .. Local Scalars .. COMPLEX*16 ALPHA, BETA @@ -2038,7 +2047,7 @@ SUBROUTINE ZCHKE( ISNUM, SRNAMT, NOUT ) RBETA = TWO * GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, - $ 90 )ISNUM + $ 90, 100 )ISNUM 10 INFOT = 1 CALL ZGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2219,7 +2228,7 @@ SUBROUTINE ZCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 13 CALL ZGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 + GO TO 110 20 INFOT = 1 CALL ZHEMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2286,7 +2295,7 @@ SUBROUTINE ZCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 12 CALL ZHEMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 + GO TO 110 30 INFOT = 1 CALL ZSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2353,7 +2362,7 @@ SUBROUTINE ZCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 12 CALL ZSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 + GO TO 110 40 INFOT = 1 CALL ZTRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2510,7 +2519,7 @@ SUBROUTINE ZCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 11 CALL ZTRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 + GO TO 110 50 INFOT = 1 CALL ZTRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2667,7 +2676,7 @@ SUBROUTINE ZCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 11 CALL ZTRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 + GO TO 110 60 INFOT = 1 CALL ZHERK( '/', 'N', 0, 0, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2722,7 +2731,7 @@ SUBROUTINE ZCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 10 CALL ZHERK( 'L', 'C', 2, 0, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 + GO TO 110 70 INFOT = 1 CALL ZSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2777,7 +2786,7 @@ SUBROUTINE ZCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 10 CALL ZSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 + GO TO 110 80 INFOT = 1 CALL ZHER2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2844,7 +2853,7 @@ SUBROUTINE ZCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 12 CALL ZHER2K( 'L', 'C', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 100 + GO TO 110 90 INFOT = 1 CALL ZSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2911,8 +2920,186 @@ SUBROUTINE ZCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 12 CALL ZSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + GO TO 110 + 100 INFOT = 1 + CALL ZGEMMT( '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL ZGEMMT( '/', 'N', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL ZGEMMT( '/', 'N', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL ZGEMMT( '/', 'T', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL ZGEMMT( '/', 'T', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL ZGEMMT( '/', 'T', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL ZGEMMT( '/', 'C', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL ZGEMMT( '/', 'C', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 1 + CALL ZGEMMT( '/', 'C', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + + INFOT = 2 + CALL ZGEMMT( 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGEMMT( 'U', '/', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGEMMT( 'U', '/', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGEMMT( 'L', '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGEMMT( 'L', '/', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGEMMT( 'L', '/', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + + INFOT = 3 + CALL ZGEMMT( 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZGEMMT( 'U', 'C', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZGEMMT( 'U', 'T', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGEMMT( 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGEMMT( 'U', 'N', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGEMMT( 'U', 'N', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGEMMT( 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGEMMT( 'U', 'C', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGEMMT( 'U', 'C', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGEMMT( 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGEMMT( 'U', 'T', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGEMMT( 'U', 'T', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGEMMT( 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGEMMT( 'U', 'N', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGEMMT( 'U', 'N', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGEMMT( 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGEMMT( 'U', 'C', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGEMMT( 'U', 'C', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGEMMT( 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGEMMT( 'U', 'T', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGEMMT( 'U', 'T', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + + INFOT = 8 + CALL ZGEMMT( 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZGEMMT( 'U', 'N', 'C', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZGEMMT( 'U', 'N', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZGEMMT( 'U', 'C', 'N', 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZGEMMT( 'U', 'C', 'C', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZGEMMT( 'U', 'C', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZGEMMT( 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZGEMMT( 'U', 'T', 'C', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZGEMMT( 'U', 'T', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + + INFOT = 10 + CALL ZGEMMT( 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZGEMMT( 'U', 'C', 'N', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZGEMMT( 'U', 'T', 'N', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL ZGEMMT( 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL ZGEMMT( 'U', 'N', 'C', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL ZGEMMT( 'U', 'N', 'T', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL ZGEMMT( 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL ZGEMMT( 'U', 'C', 'C', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL ZGEMMT( 'U', 'C', 'T', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL ZGEMMT( 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL ZGEMMT( 'U', 'T', 'C', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL ZGEMMT( 'U', 'T', 'T', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + GO TO 110 + * - 100 IF( OK )THEN + 110 IF( OK )THEN WRITE( NOUT, FMT = 9999 )SRNAMT ELSE WRITE( NOUT, FMT = 9998 )SRNAMT @@ -3496,3 +3683,498 @@ SUBROUTINE XERBLA( SRNAME, INFO ) * End of XERBLA * 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 ) +* +* Tests ZGEMMT. +* +* Auxiliary routine for test program for Level 3 Blas. +* +* -- Written on 8-February-1989. +* Jack Dongarra, Argonne National Laboratory. +* Iain Duff, AERE Harwell. +* Jeremy Du Croz, Numerical Algorithms Group Ltd. +* Sven Hammarling, Numerical Algorithms Group Ltd. +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0, 0.0 ) ) + DOUBLE PRECISION RZERO + PARAMETER ( RZERO = 0.0D0 ) +* .. Scalar Arguments .. + DOUBLE PRECISION EPS, THRESH + INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA + LOGICAL FATAL, REWI, TRACE + CHARACTER*6 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, IN, K, KS, LAA, + $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M, + $ 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 CGEMM, ZMAKE, CMMCH +* .. 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, ' ', M, 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 ) + $ WRITE( NTRA, FMT = 9995 )NC, SNAME, UPLO + $ TRANSA, TRANSB, N, K, ALPHA, LDA, LDB, + $ BETA, LDC + IF( REWI ) + $ REWIND NTRA + CALL ZGEMMT( 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 ) = UPLOS.EQ.UPLO + 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', ' ', M, 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 + WRITE( NOUT, FMT = 9999 )SNAME, NC + ELSE + WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX + END IF + GO TO 130 +* + 120 CONTINUE + WRITE( NOUT, FMT = 9996 )SNAME + WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, M, N, K, + $ ALPHA, LDA, LDB, BETA, LDC +* + 130 CONTINUE + RETURN +* + 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + $ 'S)' ) + 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', + $ 'ANGED INCORRECTLY *******' ) + 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, + $ ' - SUSPECT *******' ) + 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A6, '(''',A1, ''',''',A1, ''',''', 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 *', + $ '******' ) +* +* End of ZCHK6 +* + 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. +* +* Auxiliary routine for test program for Level 3 Blas. +* +* -- Written on 8-February-1989. +* Jack Dongarra, Argonne National Laboratory. +* Iain Duff, AERE Harwell. +* Jeremy Du Croz, Numerical Algorithms Group Ltd. +* Sven Hammarling, Numerical Algorithms Group Ltd. +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0, 0.0 ) ) + DOUBLE PRECISION RZERO, RONE + PARAMETER ( RZERO = 0.0D0, RONE = 1.0D0 ) +* .. 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 ABS, AIMAG, CONJG, MAX, REAL, SQRT +* .. Statement Functions .. + DOUBLE PRECISION ABS1 +* .. Statement Function definitions .. + ABS1( CL ) = ABS( DBLE( CL ) ) + ABS( 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' +* +* Compute expected result, one column at a time, in CT using data +* in A, B and C. +* Compute gauges in G. +* + ISTART = 1 + ISTOP = 1 + + 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 ZMMTCH +* + END + diff --git a/BLAS/TESTING/zblat3.in b/BLAS/TESTING/zblat3.in index a3618b0f6d..ed6e9dd601 100644 --- a/BLAS/TESTING/zblat3.in +++ b/BLAS/TESTING/zblat3.in @@ -21,3 +21,4 @@ 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. +ZGEMMT T PUT F FOR NO TEST. SAME COLUMNS. From 5daea4888bce21288077b34ab97eea4bfd4005ef Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20K=C3=B6hler?= Date: Thu, 20 Jul 2023 15:31:30 +0200 Subject: [PATCH 02/23] CBLAS routines for xGEMMT added --- CBLAS/include/cblas.h | 21 +++++++ CBLAS/include/cblas_64.h | 22 +++++++ CBLAS/include/cblas_f77.h | 38 ++++++++++++ CBLAS/include/cblas_test.h | 4 ++ CBLAS/src/CMakeLists.txt | 8 +-- CBLAS/src/Makefile | 8 +-- CBLAS/src/cblas_cgemm.c | 2 +- CBLAS/src/cblas_cgemmt.c | 122 ++++++++++++++++++++++++++++++++++++ CBLAS/src/cblas_dgemm.c | 2 +- CBLAS/src/cblas_dgemmt.c | 121 ++++++++++++++++++++++++++++++++++++ CBLAS/src/cblas_sgemm.c | 2 +- CBLAS/src/cblas_sgemmt.c | 123 +++++++++++++++++++++++++++++++++++++ CBLAS/src/cblas_zgemm.c | 2 +- CBLAS/src/cblas_zgemmt.c | 121 ++++++++++++++++++++++++++++++++++++ 14 files changed, 584 insertions(+), 12 deletions(-) create mode 100644 CBLAS/src/cblas_cgemmt.c create mode 100644 CBLAS/src/cblas_dgemmt.c create mode 100644 CBLAS/src/cblas_sgemmt.c create mode 100644 CBLAS/src/cblas_zgemmt.c diff --git a/CBLAS/include/cblas.h b/CBLAS/include/cblas.h index 171ff1d609..dfab386bb6 100644 --- a/CBLAS/include/cblas.h +++ b/CBLAS/include/cblas.h @@ -472,6 +472,12 @@ void cblas_sgemm(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA, const CBLAS_INT K, const float alpha, const float *A, const CBLAS_INT lda, const float *B, const CBLAS_INT ldb, const float beta, float *C, const CBLAS_INT ldc); +void cblas_sgemmt(CBLAS_LAYOUT layout,CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, + CBLAS_TRANSPOSE TransB, const CBLAS_INT N, + const CBLAS_INT K, const float alpha, const float *A, + const CBLAS_INT lda, const float *B, const CBLAS_INT ldb, + const float beta, float *C, const CBLAS_INT ldc); + void cblas_ssymm(CBLAS_LAYOUT layout, CBLAS_SIDE Side, CBLAS_UPLO Uplo, const CBLAS_INT M, const CBLAS_INT N, const float alpha, const float *A, const CBLAS_INT lda, @@ -502,6 +508,11 @@ void cblas_dgemm(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA, const CBLAS_INT K, const double alpha, const double *A, const CBLAS_INT lda, const double *B, const CBLAS_INT ldb, const double beta, double *C, const CBLAS_INT ldc); +void cblas_dgemmt(CBLAS_LAYOUT layout,CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, + CBLAS_TRANSPOSE TransB, const CBLAS_INT N, + const CBLAS_INT K, const double alpha, const double *A, + const CBLAS_INT lda, const double *B, const CBLAS_INT ldb, + const double beta, double *C, const CBLAS_INT ldc); void cblas_dsymm(CBLAS_LAYOUT layout, CBLAS_SIDE Side, CBLAS_UPLO Uplo, const CBLAS_INT M, const CBLAS_INT N, const double alpha, const double *A, const CBLAS_INT lda, @@ -532,6 +543,11 @@ void cblas_cgemm(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA, const CBLAS_INT K, const void *alpha, const void *A, const CBLAS_INT lda, const void *B, const CBLAS_INT ldb, const void *beta, void *C, const CBLAS_INT ldc); +void cblas_cgemmt(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, + CBLAS_TRANSPOSE TransB, const CBLAS_INT M, const CBLAS_INT N, + const CBLAS_INT K, const void *alpha, const void *A, + const CBLAS_INT lda, const void *B, const CBLAS_INT ldb, + const void *beta, void *C, const CBLAS_INT ldc); void cblas_csymm(CBLAS_LAYOUT layout, CBLAS_SIDE Side, CBLAS_UPLO Uplo, const CBLAS_INT M, const CBLAS_INT N, const void *alpha, const void *A, const CBLAS_INT lda, @@ -562,6 +578,11 @@ void cblas_zgemm(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA, const CBLAS_INT K, const void *alpha, const void *A, const CBLAS_INT lda, const void *B, const CBLAS_INT ldb, const void *beta, void *C, const CBLAS_INT ldc); +void cblas_zgemmt(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, + CBLAS_TRANSPOSE TransB, const CBLAS_INT N, + const CBLAS_INT K, const void *alpha, const void *A, + const CBLAS_INT lda, const void *B, const CBLAS_INT ldb, + const void *beta, void *C, const CBLAS_INT ldc); void cblas_zsymm(CBLAS_LAYOUT layout, CBLAS_SIDE Side, CBLAS_UPLO Uplo, const CBLAS_INT M, const CBLAS_INT N, const void *alpha, const void *A, const CBLAS_INT lda, diff --git a/CBLAS/include/cblas_64.h b/CBLAS/include/cblas_64.h index 3901ecf446..aa4125b9bf 100644 --- a/CBLAS/include/cblas_64.h +++ b/CBLAS/include/cblas_64.h @@ -423,6 +423,12 @@ void cblas_sgemm_64(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA, const int64_t K, const float alpha, const float *A, const int64_t lda, const float *B, const int64_t ldb, const float beta, float *C, const int64_t ldc); +void cblas_sgemmt_64(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, + CBLAS_TRANSPOSE TransB, const int64_t N, + const int64_t K, const float alpha, const float *A, + const int64_t lda, const float *B, const int64_t ldb, + const float beta, float *C, const int64_t ldc); + void cblas_ssymm_64(CBLAS_LAYOUT layout, CBLAS_SIDE Side, CBLAS_UPLO Uplo, const int64_t M, const int64_t N, const float alpha, const float *A, const int64_t lda, @@ -453,6 +459,11 @@ void cblas_dgemm_64(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA, const int64_t K, const double alpha, const double *A, const int64_t lda, const double *B, const int64_t ldb, const double beta, double *C, const int64_t ldc); +void cblas_dgemmt_64(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, + CBLAS_TRANSPOSE TransB, const int64_t N, + const int64_t K, const double alpha, const double *A, + const int64_t lda, const double *B, const int64_t ldb, + const double beta, double *C, const int64_t ldc); void cblas_dsymm_64(CBLAS_LAYOUT layout, CBLAS_SIDE Side, CBLAS_UPLO Uplo, const int64_t M, const int64_t N, const double alpha, const double *A, const int64_t lda, @@ -483,6 +494,12 @@ void cblas_cgemm_64(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA, const int64_t K, const void *alpha, const void *A, const int64_t lda, const void *B, const int64_t ldb, const void *beta, void *C, const int64_t ldc); +void cblas_cgemmt_64(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, + CBLAS_TRANSPOSE TransB, const int64_t N, + const int64_t K, const void *alpha, const void *A, + const int64_t lda, const void *B, const int64_t ldb, + const void *beta, void *C, const int64_t ldc); + void cblas_csymm_64(CBLAS_LAYOUT layout, CBLAS_SIDE Side, CBLAS_UPLO Uplo, const int64_t M, const int64_t N, const void *alpha, const void *A, const int64_t lda, @@ -513,6 +530,11 @@ void cblas_zgemm_64(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA, const int64_t K, const void *alpha, const void *A, const int64_t lda, const void *B, const int64_t ldb, const void *beta, void *C, const int64_t ldc); +void cblas_zgemmt_64(CBLAS_LAYOUT layout,CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, + CBLAS_TRANSPOSE TransB, const int64_t N, + const int64_t K, const void *alpha, const void *A, + const int64_t lda, const void *B, const int64_t ldb, + const void *beta, void *C, const int64_t ldc); void cblas_zsymm_64(CBLAS_LAYOUT layout, CBLAS_SIDE Side, CBLAS_UPLO Uplo, const int64_t M, const int64_t N, const void *alpha, const void *A, const int64_t lda, diff --git a/CBLAS/include/cblas_f77.h b/CBLAS/include/cblas_f77.h index c25bc621b5..35bd315336 100644 --- a/CBLAS/include/cblas_f77.h +++ b/CBLAS/include/cblas_f77.h @@ -197,24 +197,28 @@ #define F77_zherk_base F77_GLOBAL_SUFFIX(zherk,ZHERK) #define F77_zher2k_base F77_GLOBAL_SUFFIX(zher2k,ZHER2K) #define F77_sgemm_base F77_GLOBAL_SUFFIX(sgemm,SGEMM) +#define F77_sgemmt_base F77_GLOBAL_SUFFIX(sgemmt,SGEMMT) #define F77_ssymm_base F77_GLOBAL_SUFFIX(ssymm,SSYMM) #define F77_ssyrk_base F77_GLOBAL_SUFFIX(ssyrk,SSYRK) #define F77_ssyr2k_base F77_GLOBAL_SUFFIX(ssyr2k,SSYR2K) #define F77_strmm_base F77_GLOBAL_SUFFIX(strmm,STRMM) #define F77_strsm_base F77_GLOBAL_SUFFIX(strsm,STRSM) #define F77_dgemm_base F77_GLOBAL_SUFFIX(dgemm,DGEMM) +#define F77_dgemmt_base F77_GLOBAL_SUFFIX(dgemmt,DGEMMT) #define F77_dsymm_base F77_GLOBAL_SUFFIX(dsymm,DSYMM) #define F77_dsyrk_base F77_GLOBAL_SUFFIX(dsyrk,DSYRK) #define F77_dsyr2k_base F77_GLOBAL_SUFFIX(dsyr2k,DSYR2K) #define F77_dtrmm_base F77_GLOBAL_SUFFIX(dtrmm,DTRMM) #define F77_dtrsm_base F77_GLOBAL_SUFFIX(dtrsm,DTRSM) #define F77_cgemm_base F77_GLOBAL_SUFFIX(cgemm,CGEMM) +#define F77_cgemmt_base F77_GLOBAL_SUFFIX(cgemmt,CGEMMT) #define F77_csymm_base F77_GLOBAL_SUFFIX(csymm,CSYMM) #define F77_csyrk_base F77_GLOBAL_SUFFIX(csyrk,CSYRK) #define F77_csyr2k_base F77_GLOBAL_SUFFIX(csyr2k,CSYR2K) #define F77_ctrmm_base F77_GLOBAL_SUFFIX(ctrmm,CTRMM) #define F77_ctrsm_base F77_GLOBAL_SUFFIX(ctrsm,CTRSM) #define F77_zgemm_base F77_GLOBAL_SUFFIX(zgemm,ZGEMM) +#define F77_zgemmt_base F77_GLOBAL_SUFFIX(zgemmt,ZGEMMT) #define F77_zsymm_base F77_GLOBAL_SUFFIX(zsymm,ZSYMM) #define F77_zsyrk_base F77_GLOBAL_SUFFIX(zsyrk,ZSYRK) #define F77_zsyr2k_base F77_GLOBAL_SUFFIX(zsyr2k,ZSYR2K) @@ -389,6 +393,7 @@ /* Single Precision */ #define F77_sgemm(...) F77_sgemm_base(__VA_ARGS__, 1, 1) + #define F77_sgemmt(...) F77_sgemmt_base(__VA_ARGS__, 1, 1, 1) #define F77_ssymm(...) F77_ssymm_base(__VA_ARGS__, 1, 1) #define F77_ssyrk(...) F77_ssyrk_base(__VA_ARGS__, 1, 1) #define F77_ssyr2k(...) F77_ssyr2k_base(__VA_ARGS__, 1, 1) @@ -398,6 +403,7 @@ /* Double Precision */ #define F77_dgemm(...) F77_dgemm_base(__VA_ARGS__, 1, 1) + #define F77_dgemmt(...) F77_dgemmt_base(__VA_ARGS__, 1, 1, 1) #define F77_dsymm(...) F77_dsymm_base(__VA_ARGS__, 1, 1) #define F77_dsyrk(...) F77_dsyrk_base(__VA_ARGS__, 1, 1) #define F77_dsyr2k(...) F77_dsyr2k_base(__VA_ARGS__, 1, 1) @@ -407,6 +413,7 @@ /* Single Complex Precision */ #define F77_cgemm(...) F77_cgemm_base(__VA_ARGS__, 1, 1) + #define F77_cgemmt(...) F77_cgemmt_base(__VA_ARGS__, 1, 1, 1) #define F77_csymm(...) F77_csymm_base(__VA_ARGS__, 1, 1) #define F77_chemm(...) F77_chemm_base(__VA_ARGS__, 1, 1) #define F77_csyrk(...) F77_csyrk_base(__VA_ARGS__, 1, 1) @@ -419,6 +426,7 @@ /* Double Complex Precision */ #define F77_zgemm(...) F77_zgemm_base(__VA_ARGS__, 1, 1) + #define F77_zgemmt(...) F77_zgemmt_base(__VA_ARGS__, 1, 1, 1) #define F77_zsymm(...) F77_zsymm_base(__VA_ARGS__, 1, 1) #define F77_zhemm(...) F77_zhemm_base(__VA_ARGS__, 1, 1) #define F77_zsyrk(...) F77_zsyrk_base(__VA_ARGS__, 1, 1) @@ -513,6 +521,7 @@ /* Single Precision */ #define F77_sgemm(...) F77_sgemm_base(__VA_ARGS__) + #define F77_sgemmt(...) F77_sgemmt_base(__VA_ARGS__) #define F77_ssymm(...) F77_ssymm_base(__VA_ARGS__) #define F77_ssyrk(...) F77_ssyrk_base(__VA_ARGS__) #define F77_ssyr2k(...) F77_ssyr2k_base(__VA_ARGS__) @@ -522,6 +531,7 @@ /* Double Precision */ #define F77_dgemm(...) F77_dgemm_base(__VA_ARGS__) + #define F77_dgemmt(...) F77_dgemmt_base(__VA_ARGS__) #define F77_dsymm(...) F77_dsymm_base(__VA_ARGS__) #define F77_dsyrk(...) F77_dsyrk_base(__VA_ARGS__) #define F77_dsyr2k(...) F77_dsyr2k_base(__VA_ARGS__) @@ -531,6 +541,7 @@ /* Single Complex Precision */ #define F77_cgemm(...) F77_cgemm_base(__VA_ARGS__) + #define F77_cgemmt(...) F77_cgemmt_base(__VA_ARGS__) #define F77_csymm(...) F77_csymm_base(__VA_ARGS__) #define F77_chemm(...) F77_chemm_base(__VA_ARGS__) #define F77_csyrk(...) F77_csyrk_base(__VA_ARGS__) @@ -543,6 +554,7 @@ /* Double Complex Precision */ #define F77_zgemm(...) F77_zgemm_base(__VA_ARGS__) + #define F77_zgemmt(...) F77_zgemmt_base(__VA_ARGS__) #define F77_zsymm(...) F77_zsymm_base(__VA_ARGS__) #define F77_zhemm(...) F77_zhemm_base(__VA_ARGS__) #define F77_zsyrk(...) F77_zsyrk_base(__VA_ARGS__) @@ -981,6 +993,12 @@ void F77_sgemm_base(FCHAR, FCHAR, FINT, FINT, FINT, const float *, const float * , FORTRAN_STRLEN, FORTRAN_STRLEN #endif ); +void F77_sgemmt_base(FCHAR, FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT +#ifdef BLAS_FORTRAN_STRLEN_END + , size_t, size_t, size_t +#endif +); + void F77_ssymm_base(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT #ifdef BLAS_FORTRAN_STRLEN_END , FORTRAN_STRLEN, FORTRAN_STRLEN @@ -1014,6 +1032,12 @@ void F77_dgemm_base(FCHAR, FCHAR, FINT, FINT, FINT, const double *, const double , FORTRAN_STRLEN, FORTRAN_STRLEN #endif ); +void F77_dgemmt_base(FCHAR, FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT +#ifdef BLAS_FORTRAN_STRLEN_END + , size_t, size_t, size_t +#endif +); + void F77_dsymm_base(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT #ifdef BLAS_FORTRAN_STRLEN_END , FORTRAN_STRLEN, FORTRAN_STRLEN @@ -1047,6 +1071,13 @@ void F77_cgemm_base(FCHAR, FCHAR, FINT, FINT, FINT, const void *, const void *, , FORTRAN_STRLEN, FORTRAN_STRLEN #endif ); + +void F77_cgemmt_base(FCHAR, FCHAR, FCHAR, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT +#ifdef BLAS_FORTRAN_STRLEN_END + , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN +#endif +); + void F77_csymm_base(FCHAR, FCHAR, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT #ifdef BLAS_FORTRAN_STRLEN_END , FORTRAN_STRLEN, FORTRAN_STRLEN @@ -1095,6 +1126,13 @@ void F77_zgemm_base(FCHAR, FCHAR, FINT, FINT, FINT, const void *, const void *, , FORTRAN_STRLEN, FORTRAN_STRLEN #endif ); + +void F77_zgemmt_base(FCHAR, FCHAR, FCHAR, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT +#ifdef BLAS_FORTRAN_STRLEN_END + , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN +#endif +); + void F77_zsymm_base(FCHAR, FCHAR, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT #ifdef BLAS_FORTRAN_STRLEN_END , FORTRAN_STRLEN, FORTRAN_STRLEN diff --git a/CBLAS/include/cblas_test.h b/CBLAS/include/cblas_test.h index 663176f9b5..9da8c28a0e 100644 --- a/CBLAS/include/cblas_test.h +++ b/CBLAS/include/cblas_test.h @@ -167,24 +167,28 @@ typedef struct { double real; double imag; } CBLAS_TEST_ZOMPLEX; #define F77_zherk F77_GLOBAL(czherk,CZHERK) #define F77_zher2k F77_GLOBAL(czher2k,CZHER2K) #define F77_sgemm F77_GLOBAL(csgemm,CSGEMM) +#define F77_sgemmt F77_GLOBAL(csgemmt,CSGEMMT) #define F77_ssymm F77_GLOBAL(cssymm,CSSYMM) #define F77_ssyrk F77_GLOBAL(cssyrk,CSSYRK) #define F77_ssyr2k F77_GLOBAL(cssyr2k,CSSYR2K) #define F77_strmm F77_GLOBAL(cstrmm,CSTRMM) #define F77_strsm F77_GLOBAL(cstrsm,CSTRSM) #define F77_dgemm F77_GLOBAL(cdgemm,CDGEMM) +#define F77_dgemmt F77_GLOBAL(cdgemmt,CDGEMMT) #define F77_dsymm F77_GLOBAL(cdsymm,CDSYMM) #define F77_dsyrk F77_GLOBAL(cdsyrk,CDSYRK) #define F77_dsyr2k F77_GLOBAL(cdsyr2k,CDSYR2K) #define F77_dtrmm F77_GLOBAL(cdtrmm,CDTRMM) #define F77_dtrsm F77_GLOBAL(cdtrsm,CDTRSM) #define F77_cgemm F77_GLOBAL(ccgemm,CCGEMM) +#define F77_cgemmt F77_GLOBAL(ccgemmt,CCGEMMT) #define F77_csymm F77_GLOBAL(ccsymm,CCSYMM) #define F77_csyrk F77_GLOBAL(ccsyrk,CCSYRK) #define F77_csyr2k F77_GLOBAL(ccsyr2k,CCSYR2K) #define F77_ctrmm F77_GLOBAL(cctrmm,CCTRMM) #define F77_ctrsm F77_GLOBAL(cctrsm,CCTRSM) #define F77_zgemm F77_GLOBAL(czgemm,CZGEMM) +#define F77_zgemmt F77_GLOBAL(czgemmt,CZGEMMT) #define F77_zsymm F77_GLOBAL(czsymm,CZSYMM) #define F77_zsyrk F77_GLOBAL(czsyrk,CZSYRK) #define F77_zsyr2k F77_GLOBAL(czsyr2k,CZSYR2K) diff --git a/CBLAS/src/CMakeLists.txt b/CBLAS/src/CMakeLists.txt index 3724852007..67926534e9 100644 --- a/CBLAS/src/CMakeLists.txt +++ b/CBLAS/src/CMakeLists.txt @@ -85,21 +85,21 @@ set(ZLEV2 cblas_zgemv.c cblas_zgbmv.c cblas_zhemv.c cblas_zhbmv.c cblas_zhpmv.c # Files for level 3 single precision real set(SLEV3 cblas_sgemm.c cblas_ssymm.c cblas_ssyrk.c cblas_ssyr2k.c cblas_strmm.c - cblas_strsm.c) + cblas_strsm.c cblas_sgemmt.c) # Files for level 3 double precision real set(DLEV3 cblas_dgemm.c cblas_dsymm.c cblas_dsyrk.c cblas_dsyr2k.c cblas_dtrmm.c - cblas_dtrsm.c) + cblas_dtrsm.c cblas_cgemmt.c) # Files for level 3 single precision complex set(CLEV3 cblas_cgemm.c cblas_csymm.c cblas_chemm.c cblas_cherk.c cblas_cher2k.c cblas_ctrmm.c cblas_ctrsm.c cblas_csyrk.c - cblas_csyr2k.c) + cblas_csyr2k.c cblas_cgemmt.c) # Files for level 3 double precision complex set(ZLEV3 cblas_zgemm.c cblas_zsymm.c cblas_zhemm.c cblas_zherk.c cblas_zher2k.c cblas_ztrmm.c cblas_ztrsm.c cblas_zsyrk.c - cblas_zsyr2k.c) + cblas_zsyr2k.c cblas_zgemmt.c) set(SOURCES) diff --git a/CBLAS/src/Makefile b/CBLAS/src/Makefile index a455cd66be..ba0b63a487 100644 --- a/CBLAS/src/Makefile +++ b/CBLAS/src/Makefile @@ -137,21 +137,21 @@ zlib2: $(zlev2) $(errhand) # Files for level 3 single precision real slev3 = cblas_sgemm.o cblas_ssymm.o cblas_ssyrk.o cblas_ssyr2k.o cblas_strmm.o \ - cblas_strsm.o + cblas_strsm.o cblas_sgemmt.o # Files for level 3 double precision real dlev3 = cblas_dgemm.o cblas_dsymm.o cblas_dsyrk.o cblas_dsyr2k.o cblas_dtrmm.o \ - cblas_dtrsm.o + cblas_dtrsm.o cblas_dgemmt.o # Files for level 3 single precision complex clev3 = cblas_cgemm.o cblas_csymm.o cblas_chemm.o cblas_cherk.o \ cblas_cher2k.o cblas_ctrmm.o cblas_ctrsm.o cblas_csyrk.o \ - cblas_csyr2k.o + cblas_csyr2k.o cblas_cgemmt.o # Files for level 3 double precision complex zlev3 = cblas_zgemm.o cblas_zsymm.o cblas_zhemm.o cblas_zherk.o \ cblas_zher2k.o cblas_ztrmm.o cblas_ztrsm.o cblas_zsyrk.o \ - cblas_zsyr2k.o + cblas_zsyr2k.o cblas_zgemmt.o .PHONY: slib3 dlib3 clib3 zlib3 # Single precision real diff --git a/CBLAS/src/cblas_cgemm.c b/CBLAS/src/cblas_cgemm.c index fe4b599a19..5950ed1f8c 100644 --- a/CBLAS/src/cblas_cgemm.c +++ b/CBLAS/src/cblas_cgemm.c @@ -89,7 +89,7 @@ void API_SUFFIX(cblas_cgemm)(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE Tr else if ( TransB == CblasNoTrans ) TA='N'; else { - API_SUFFIX(cblas_xerbla)(2, "cblas_cgemm", "Illegal TransB setting, %d\n", TransB); + API_SUFFIX(cblas_xerbla)(3, "cblas_cgemm", "Illegal TransB setting, %d\n", TransB); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; diff --git a/CBLAS/src/cblas_cgemmt.c b/CBLAS/src/cblas_cgemmt.c new file mode 100644 index 0000000000..4d63dd284d --- /dev/null +++ b/CBLAS/src/cblas_cgemmt.c @@ -0,0 +1,122 @@ +/* + * + * cblas_cgemm.c + * This program is a C interface to cgemm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void API_SUFFIX(cblas_cgemm_t)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, + const CBLAS_TRANSPOSE TransB, const CBLAS_INT N, + const CBLAS_INT K, const void *alpha, const void *A, + const CBLAS_INT lda, const void *B, const CBLAS_INT ldb, + const void *beta, void *C, const CBLAS_INT ldc) +{ + char TA, TB; + char UL; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_TB, F77_UL; +#else + #define F77_TA &TA + #define F77_TB &TB + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if ( Uplo == CblasUpper ) UL = 'U'; + else if (Uplo == CblasLower) UL= 'L'; + else { + API_SUFFIX(cblas_xerbla)(2, "cblas_cgemmt", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( layout == CblasColMajor ) + { + if(TransA == CblasTrans) TA='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + API_SUFFIX(cblas_xerbla)(3, "cblas_cgemmt", "Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if(TransB == CblasTrans) TB='T'; + else if ( TransB == CblasConjTrans ) TB='C'; + else if ( TransB == CblasNoTrans ) TB='N'; + else + { + API_SUFFIX(cblas_xerbla)(4, "cblas_cgemmt", "Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + F77_UL = C2F_CHAR(&UL); + #endif + + F77_cgemmt(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, alpha, A, + &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if(TransA == CblasTrans) TB='T'; + else if ( TransA == CblasConjTrans ) TB='C'; + else if ( TransA == CblasNoTrans ) TB='N'; + else + { + API_SUFFIX(cblas_xerbla)(3, "cblas_cgemmt", "Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(TransB == CblasTrans) TA='T'; + else if ( TransB == CblasConjTrans ) TA='C'; + else if ( TransB == CblasNoTrans ) TA='N'; + else + { + API_SUFFIX(cblas_xerbla)(4, "cblas_cgemmt", "Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + F77_UL = C2F_CHAR(&UL); + + #endif + + F77_cgemmt(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, alpha, B, + &F77_ldb, A, &F77_lda, beta, C, &F77_ldc); + } + else API_SUFFIX(cblas_xerbla)(1, "cblas_cgemmt", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/CBLAS/src/cblas_dgemm.c b/CBLAS/src/cblas_dgemm.c index bee9aa8a68..c4ae0275c2 100644 --- a/CBLAS/src/cblas_dgemm.c +++ b/CBLAS/src/cblas_dgemm.c @@ -89,7 +89,7 @@ void API_SUFFIX(cblas_dgemm)(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE Tr else if ( TransB == CblasNoTrans ) TA='N'; else { - API_SUFFIX(cblas_xerbla)(2, "cblas_dgemm","Illegal TransB setting, %d\n", TransB); + API_SUFFIX(cblas_xerbla)(3, "cblas_dgemm","Illegal TransB setting, %d\n", TransB); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; diff --git a/CBLAS/src/cblas_dgemmt.c b/CBLAS/src/cblas_dgemmt.c new file mode 100644 index 0000000000..84242f5c83 --- /dev/null +++ b/CBLAS/src/cblas_dgemmt.c @@ -0,0 +1,121 @@ +/* + * + * cblas_dgemm.c + * This program is a C interface to dgemm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void API_SUFFIX(cblas_dgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, + const CBLAS_TRANSPOSE TransB, const CBLAS_INT N, + const CBLAS_INT K, const double alpha, const double *A, + const CBLAS_INT lda, const double *B, const CBLAS_INT ldb, + const double beta, double *C, const CBLAS_INT ldc) +{ + char TA, TB, UL; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_TB. F77_UL; +#else + #define F77_TA &TA + #define F77_TB &TB + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if ( Uplo == CblasUpper ) UL = 'U'; + else if (Uplo == CblasLower) UL= 'L'; + else { + API_SUFFIX(cblas_xerbla)(2, "cblas_dgemmt", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + + if( layout == CblasColMajor ) + { + if(TransA == CblasTrans) TA='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + API_SUFFIX(cblas_xerbla)(3, "cblas_dgemmt","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if(TransB == CblasTrans) TB='T'; + else if ( TransB == CblasConjTrans ) TB='C'; + else if ( TransB == CblasNoTrans ) TB='N'; + else + { + API_SUFFIX(cblas_xerbla)(4, "cblas_dgemmt","Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + F77_UL = C2F_CHAR(&UL); + #endif + + F77_dgemmt(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, &alpha, A, + &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if(TransA == CblasTrans) TB='T'; + else if ( TransA == CblasConjTrans ) TB='C'; + else if ( TransA == CblasNoTrans ) TB='N'; + else + { + API_SUFFIX(cblas_xerbla)(3, "cblas_dgemmt","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(TransB == CblasTrans) TA='T'; + else if ( TransB == CblasConjTrans ) TA='C'; + else if ( TransB == CblasNoTrans ) TA='N'; + else + { + API_SUFFIX(cblas_xerbla)(4, "cblas_dgemmt","Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + F77_UL = C2F_CHAR(&UL); + #endif + + F77_dgemmt( F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, &alpha, B, + &F77_ldb, A, &F77_lda, &beta, C, &F77_ldc); + } + else API_SUFFIX(cblas_xerbla)(1, "cblas_dgemmt", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/CBLAS/src/cblas_sgemm.c b/CBLAS/src/cblas_sgemm.c index a7b21fb58b..26be2a8f0a 100644 --- a/CBLAS/src/cblas_sgemm.c +++ b/CBLAS/src/cblas_sgemm.c @@ -90,7 +90,7 @@ void API_SUFFIX(cblas_sgemm)(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE Tr else if ( TransB == CblasNoTrans ) TA='N'; else { - API_SUFFIX(cblas_xerbla)(2, "cblas_sgemm", + API_SUFFIX(cblas_xerbla)(3, "cblas_sgemm", "Illegal TransB setting, %d\n", TransB); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/CBLAS/src/cblas_sgemmt.c b/CBLAS/src/cblas_sgemmt.c new file mode 100644 index 0000000000..89024c8998 --- /dev/null +++ b/CBLAS/src/cblas_sgemmt.c @@ -0,0 +1,123 @@ +/* + * + * cblas_sgemm.c + * This program is a C interface to sgemm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void API_SUFFIX(cblas_sgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, + const CBLAS_TRANSPOSE TransB, const CBLAS_INT N, + const CBLAS_INT K, const float alpha, const float *A, + const CBLAS_INT lda, const float *B, const CBLAS_INT ldb, + const float beta, float *C, const CBLAS_INT ldc) +{ + char TA, TB, UL; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_TB, F77_UL; +#else + #define F77_TA &TA + #define F77_TB &TB + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if ( Uplo == CblasUpper ) UL = 'U'; + else if (Uplo == CblasLower) UL= 'L'; + else { + API_SUFFIX(cblas_xerbla)(2, "cblas_sgemmt", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + + if( layout == CblasColMajor ) + { + if(TransA == CblasTrans) TA='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + API_SUFFIX(cblas_xerbla)(3, "cblas_sgemmt", + "Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if(TransB == CblasTrans) TB='T'; + else if ( TransB == CblasConjTrans ) TB='C'; + else if ( TransB == CblasNoTrans ) TB='N'; + else + { + API_SUFFIX(cblas_xerbla)(4, "cblas_sgemmt", + "Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + F77_UL = C2F_CHAR(&UL); + #endif + + F77_sgemmt(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, &alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if(TransA == CblasTrans) TB='T'; + else if ( TransA == CblasConjTrans ) TB='C'; + else if ( TransA == CblasNoTrans ) TB='N'; + else + { + API_SUFFIX(cblas_xerbla)(3, "cblas_sgemmt", + "Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(TransB == CblasTrans) TA='T'; + else if ( TransB == CblasConjTrans ) TA='C'; + else if ( TransB == CblasNoTrans ) TA='N'; + else + { + API_SUFFIX(cblas_xerbla)(4, "cblas_sgemmt", + "Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + F77_UL = C2F_CHAR(&UL); + #endif + + F77_sgemmt(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, &alpha, B, &F77_ldb, A, &F77_lda, &beta, C, &F77_ldc); + } else + API_SUFFIX(cblas_xerbla)(1, "cblas_sgemmt", + "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; +} diff --git a/CBLAS/src/cblas_zgemm.c b/CBLAS/src/cblas_zgemm.c index 3aaf59abc7..9b3b66e568 100644 --- a/CBLAS/src/cblas_zgemm.c +++ b/CBLAS/src/cblas_zgemm.c @@ -89,7 +89,7 @@ void API_SUFFIX(cblas_zgemm)(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE Tr else if ( TransB == CblasNoTrans ) TA='N'; else { - API_SUFFIX(cblas_xerbla)(2, "cblas_zgemm","Illegal TransB setting, %d\n", TransB); + API_SUFFIX(cblas_xerbla)(3, "cblas_zgemm","Illegal TransB setting, %d\n", TransB); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; diff --git a/CBLAS/src/cblas_zgemmt.c b/CBLAS/src/cblas_zgemmt.c new file mode 100644 index 0000000000..1bfe59e33c --- /dev/null +++ b/CBLAS/src/cblas_zgemmt.c @@ -0,0 +1,121 @@ +/* + * + * cblas_zgemm.c + * This program is a C interface to zgemm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void API_SUFFIX(cblas_zgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, + const CBLAS_TRANSPOSE TransB, const CBLAS_INT N, + const CBLAS_INT K, const void *alpha, const void *A, + const CBLAS_INT lda, const void *B, const CBLAS_INT ldb, + const void *beta, void *C, const CBLAS_INT ldc) +{ + char TA, TB, UL; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_TB, F77_UL; +#else + #define F77_TA &TA + #define F77_TB &TB + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if ( Uplo == CblasUpper ) UL = 'U'; + else if (Uplo == CblasLower) UL= 'L'; + else { + API_SUFFIX(cblas_xerbla)(2, "cblas_zgemmt", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + + if( layout == CblasColMajor ) + { + if(TransA == CblasTrans) TA='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + API_SUFFIX(cblas_xerbla)(3, "cblas_zgemmt","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if(TransB == CblasTrans) TB='T'; + else if ( TransB == CblasConjTrans ) TB='C'; + else if ( TransB == CblasNoTrans ) TB='N'; + else + { + API_SUFFIX(cblas_xerbla)(4, "cblas_zgemmt","Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + F77_UL = C2F_CHAR(&UL); + #endif + + F77_zgemmt(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, alpha, A, + &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if(TransA == CblasTrans) TB='T'; + else if ( TransA == CblasConjTrans ) TB='C'; + else if ( TransA == CblasNoTrans ) TB='N'; + else + { + API_SUFFIX(cblas_xerbla)(3, "cblas_zgemmt","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(TransB == CblasTrans) TA='T'; + else if ( TransB == CblasConjTrans ) TA='C'; + else if ( TransB == CblasNoTrans ) TA='N'; + else + { + API_SUFFIX(cblas_xerbla)(4, "cblas_zgemmt","Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + F77_UL = C2F_CHAR(&UL); + #endif + + F77_zgemmt(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, alpha, B, + &F77_ldb, A, &F77_lda, beta, C, &F77_ldc); + } + else API_SUFFIX(cblas_xerbla)(1, "cblas_zgemmt", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} From 630fb5b85c88ed5592704497bf315f8cb10c676a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20K=C3=B6hler?= Date: Fri, 21 Jul 2023 14:00:46 +0200 Subject: [PATCH 03/23] Tests for cblas_cgemmt --- CBLAS/include/cblas.h | 2 +- CBLAS/src/cblas_cgemm.c | 2 +- CBLAS/src/cblas_cgemmt.c | 29 +- CBLAS/testing/c_c3chke.c | 227 +++++++++++++++ CBLAS/testing/c_cblas3.c | 81 ++++++ CBLAS/testing/c_cblat3.f | 580 ++++++++++++++++++++++++++++++++++++++- CBLAS/testing/cin3 | 1 + 7 files changed, 901 insertions(+), 21 deletions(-) diff --git a/CBLAS/include/cblas.h b/CBLAS/include/cblas.h index dfab386bb6..c323e9e5aa 100644 --- a/CBLAS/include/cblas.h +++ b/CBLAS/include/cblas.h @@ -544,7 +544,7 @@ void cblas_cgemm(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA, const CBLAS_INT lda, const void *B, const CBLAS_INT ldb, const void *beta, void *C, const CBLAS_INT ldc); void cblas_cgemmt(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_TRANSPOSE TransB, const CBLAS_INT M, const CBLAS_INT N, + CBLAS_TRANSPOSE TransB, const CBLAS_INT N, const CBLAS_INT K, const void *alpha, const void *A, const CBLAS_INT lda, const void *B, const CBLAS_INT ldb, const void *beta, void *C, const CBLAS_INT ldc); diff --git a/CBLAS/src/cblas_cgemm.c b/CBLAS/src/cblas_cgemm.c index 5950ed1f8c..fe4b599a19 100644 --- a/CBLAS/src/cblas_cgemm.c +++ b/CBLAS/src/cblas_cgemm.c @@ -89,7 +89,7 @@ void API_SUFFIX(cblas_cgemm)(const CBLAS_LAYOUT layout, const CBLAS_TRANSPOSE Tr else if ( TransB == CblasNoTrans ) TA='N'; else { - API_SUFFIX(cblas_xerbla)(3, "cblas_cgemm", "Illegal TransB setting, %d\n", TransB); + API_SUFFIX(cblas_xerbla)(2, "cblas_cgemm", "Illegal TransB setting, %d\n", TransB); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; diff --git a/CBLAS/src/cblas_cgemmt.c b/CBLAS/src/cblas_cgemmt.c index 4d63dd284d..2d2fae25e7 100644 --- a/CBLAS/src/cblas_cgemmt.c +++ b/CBLAS/src/cblas_cgemmt.c @@ -9,7 +9,7 @@ #include "cblas.h" #include "cblas_f77.h" -void API_SUFFIX(cblas_cgemm_t)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, +void API_SUFFIX(cblas_cgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, const CBLAS_TRANSPOSE TransB, const CBLAS_INT N, const CBLAS_INT K, const void *alpha, const void *A, const CBLAS_INT lda, const void *B, const CBLAS_INT ldb, @@ -41,17 +41,18 @@ void API_SUFFIX(cblas_cgemm_t)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, RowMajorStrg = 0; CBLAS_CallFromC = 1; - if ( Uplo == CblasUpper ) UL = 'U'; - else if (Uplo == CblasLower) UL= 'L'; - else { - API_SUFFIX(cblas_xerbla)(2, "cblas_cgemmt", "Illegal Uplo setting, %d\n", Uplo); - CBLAS_CallFromC = 0; - RowMajorStrg = 0; - return; - } if( layout == CblasColMajor ) { + if ( Uplo == CblasUpper ) UL = 'U'; + else if (Uplo == CblasLower) UL= 'L'; + else { + API_SUFFIX(cblas_xerbla)(2, "cblas_cgemmt", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(TransA == CblasTrans) TA='T'; else if ( TransA == CblasConjTrans ) TA='C'; else if ( TransA == CblasNoTrans ) TA='N'; @@ -85,6 +86,16 @@ void API_SUFFIX(cblas_cgemm_t)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, } else if (layout == CblasRowMajor) { RowMajorStrg = 1; + + if ( Uplo == CblasUpper ) UL = 'L'; + else if (Uplo == CblasLower) UL= 'U'; + else { + API_SUFFIX(cblas_xerbla)(2, "cblas_cgemmt", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(TransA == CblasTrans) TB='T'; else if ( TransA == CblasConjTrans ) TB='C'; else if ( TransA == CblasNoTrans ) TB='N'; diff --git a/CBLAS/testing/c_c3chke.c b/CBLAS/testing/c_c3chke.c index 7f28f09106..6cbfcdd97d 100644 --- a/CBLAS/testing/c_c3chke.c +++ b/CBLAS/testing/c_c3chke.c @@ -282,6 +282,233 @@ void F77_c3chke(char * rout cblas_cgemm( CblasRowMajor, CblasTrans, CblasTrans, 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); + } else if (strncmp( sf,"cblas_cgemmt" ,12)==0) { + cblas_rout = "cblas_cgemmt" ; + + cblas_info = 1; + cblas_cgemm( INVALID, CblasNoTrans, CblasNoTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_cgemm( INVALID, CblasNoTrans, CblasTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_cgemm( INVALID, CblasTrans, CblasNoTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_cgemm( INVALID, CblasTrans, CblasTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, INVALID, CblasNoTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, INVALID, CblasTrans, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasNoTrans, INVALID, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasTrans, INVALID, 0, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasNoTrans, CblasTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasTrans, CblasNoTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasTrans, CblasTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasNoTrans, CblasTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasTrans, CblasNoTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasTrans, CblasTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasNoTrans, CblasTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasTrans, CblasNoTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasTrans, CblasTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 2, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasNoTrans, CblasTrans, 2, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasTrans, CblasNoTrans, 0, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasTrans, CblasTrans, 0, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 0, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasTrans, CblasNoTrans, 0, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasNoTrans, CblasTrans, 0, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasTrans, CblasTrans, 0, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 2, 0, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasNoTrans, CblasTrans, 2, 0, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasTrans, CblasNoTrans, 2, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_cgemm( CblasColMajor, CblasTrans, CblasTrans, 2, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasTrans, CblasNoTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasTrans, CblasTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasTrans, CblasTrans, 0, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasTrans, CblasTrans, 0, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 2, 0, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasTrans, CblasTrans, 2, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 0, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasTrans, CblasTrans, 0, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 0, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_cgemm( CblasRowMajor, CblasTrans, CblasTrans, 0, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); } else if (strncmp( sf,"cblas_chemm" ,11)==0) { cblas_rout = "cblas_chemm" ; diff --git a/CBLAS/testing/c_cblas3.c b/CBLAS/testing/c_cblas3.c index c8e4705cc1..eb07aaa1c5 100644 --- a/CBLAS/testing/c_cblas3.c +++ b/CBLAS/testing/c_cblas3.c @@ -91,6 +91,87 @@ void F77_cgemm(CBLAS_INT *layout, char *transpa, char *transpb, CBLAS_INT *m, CB cblas_cgemm( UNDEFINED, transa, transb, *m, *n, *k, alpha, a, *lda, b, *ldb, beta, c, *ldc ); } + +void F77_cgemmt(CBLAS_INT *layout, char *uplop, char *transpa, char *transpb, CBLAS_INT *n, + CBLAS_INT *k, CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, CBLAS_INT *lda, + CBLAS_TEST_COMPLEX *b, CBLAS_INT *ldb, CBLAS_TEST_COMPLEX *beta, + CBLAS_TEST_COMPLEX *c, CBLAS_INT *ldc ) { + + CBLAS_TEST_COMPLEX *A, *B, *C; + CBLAS_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_cgemmt( 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_cgemmt( CblasColMajor, uplo, transa, transb, *n, *k, alpha, a, *lda, + b, *ldb, beta, c, *ldc ); + else + cblas_cgemmt( UNDEFINED, uplo, transa, transb, *n, *k, alpha, a, *lda, + b, *ldb, beta, c, *ldc ); +} + + void F77_chemm(CBLAS_INT *layout, char *rtlf, char *uplow, CBLAS_INT *m, CBLAS_INT *n, CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, CBLAS_INT *lda, CBLAS_TEST_COMPLEX *b, CBLAS_INT *ldb, CBLAS_TEST_COMPLEX *beta, diff --git a/CBLAS/testing/c_cblat3.f b/CBLAS/testing/c_cblat3.f index 94144b8750..eb4e1124ba 100644 --- a/CBLAS/testing/c_cblat3.f +++ b/CBLAS/testing/c_cblat3.f @@ -3,10 +3,10 @@ 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 +* of the file are read using list-directed input, the last 10 records * are read using the format ( A12, L2 ). An annotated example of a data * file can be obtained by deleting the first 3 characters from the -* following 22 lines: +* 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. @@ -29,6 +29,7 @@ PROGRAM CBLAT3 * 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_cgemmt 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 @@ -83,7 +84,7 @@ PROGRAM CBLAT3 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 .. @@ -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_cgemmt' / * .. Executable Statements .. * NOUTC = NOUT @@ -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 CGEMMT, 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 @@ -2785,3 +2801,547 @@ 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 CGEMMT. +* +* Auxiliary routine for test program for Level 3 Blas. +* +* -- Written on 8-February-1989. +* Jack Dongarra, Argonne National Laboratory. +* Iain Duff, AERE Harwell. +* Jeremy Du Croz, Numerical Algorithms Group Ltd. +* Sven Hammarling, Numerical Algorithms Group Ltd. +* +* .. Parameters .. + 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*12 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 CCGEMM, CMAKE, CMMCH +* .. 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 CCGEMMT(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( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', + $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', + $ 'RATIO ', F8.2, ' - SUSPECT *******' ) +10002 FORMAT( ' ', A12,' 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', + $ ' (', I6, ' CALL', 'S)' ) +10000 FORMAT( ' ', A12,' 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:' ) + 9995 FORMAT( 1X, I6, ': ', A12,'(''', 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*12 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, ': ', A12,'(', 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. +* +* Auxiliary routine for test program for Level 3 Blas. +* +* -- Written on 8-February-1989. +* Jack Dongarra, Argonne National Laboratory. +* Iain Duff, AERE Harwell. +* Jeremy Du Croz, Numerical Algorithms Group Ltd. +* Sven Hammarling, Numerical Algorithms Group Ltd. +* +* .. Parameters .. + 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 CMMCH. +* + END + diff --git a/CBLAS/testing/cin3 b/CBLAS/testing/cin3 index 7b34f267bb..3854aef885 100644 --- a/CBLAS/testing/cin3 +++ b/CBLAS/testing/cin3 @@ -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_cgemmt T PUT F FOR NO TEST. SAME COLUMNS. From b25cf2c8d4aae92748b0694d179b9b75c101648f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20K=C3=B6hler?= Date: Tue, 22 Aug 2023 09:42:06 +0200 Subject: [PATCH 04/23] Update documentation of xGEMMT --- BLAS/SRC/cgemmt.f | 4 ++-- BLAS/SRC/dgemmt.f | 2 +- BLAS/SRC/sgemmt.f | 2 +- BLAS/SRC/zgemmt.f | 4 ++-- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/BLAS/SRC/cgemmt.f b/BLAS/SRC/cgemmt.f index e6071a345b..653e9877c1 100644 --- a/BLAS/SRC/cgemmt.f +++ b/BLAS/SRC/cgemmt.f @@ -37,8 +37,8 @@ *> alpha and beta are scalars, and A, B and C are matrices, with op( A ) *> an n by k matrix, op( B ) a k by n matrix and C an n by n matrix. *> Thereby, the routine only accesses and updates the upper or lower -*> triangular part of the result matrix C. This behaviour can be used, -*> the resulting matrix C is known to be symmetric. +*> triangular part of the result matrix C. This behaviour can be used if +*> the resulting matrix C is known to be Hermitian or symmetric. *> \endverbatim * * Arguments: diff --git a/BLAS/SRC/dgemmt.f b/BLAS/SRC/dgemmt.f index 718fafb17f..5d767ee607 100644 --- a/BLAS/SRC/dgemmt.f +++ b/BLAS/SRC/dgemmt.f @@ -37,7 +37,7 @@ *> alpha and beta are scalars, and A, B and C are matrices, with op( A ) *> an n by k matrix, op( B ) a k by n matrix and C an n by n matrix. *> Thereby, the routine only accesses and updates the upper or lower -*> triangular part of the result matrix C. This behaviour can be used, +*> triangular part of the result matrix C. This behaviour can be used if *> the resulting matrix C is known to be symmetric. *> \endverbatim * diff --git a/BLAS/SRC/sgemmt.f b/BLAS/SRC/sgemmt.f index 3875e63664..b2ad38e275 100644 --- a/BLAS/SRC/sgemmt.f +++ b/BLAS/SRC/sgemmt.f @@ -37,7 +37,7 @@ *> alpha and beta are scalars, and A, B and C are matrices, with op( A ) *> an n by k matrix, op( B ) a k by n matrix and C an n by n matrix. *> Thereby, the routine only accesses and updates the upper or lower -*> triangular part of the result matrix C. This behaviour can be used, +*> triangular part of the result matrix C. This behaviour can be used if *> the resulting matrix C is known to be symmetric. *> \endverbatim * diff --git a/BLAS/SRC/zgemmt.f b/BLAS/SRC/zgemmt.f index 37828abaad..5533c780a7 100644 --- a/BLAS/SRC/zgemmt.f +++ b/BLAS/SRC/zgemmt.f @@ -37,8 +37,8 @@ *> alpha and beta are scalars, and A, B and C are matrices, with op( A ) *> an n by k matrix, op( B ) a k by n matrix and C an n by n matrix. *> Thereby, the routine only accesses and updates the upper or lower -*> triangular part of the result matrix C. This behaviour can be used, -*> the resulting matrix C is known to be symmetric. +*> triangular part of the result matrix C. This behaviour can be used if +*> the resulting matrix C is known to be Hermitian or symmetric. *> \endverbatim * * Arguments: From fb5325d58d3252ef5dd8be633ba2b0d2195da155 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20K=C3=B6hler?= Date: Tue, 22 Aug 2023 09:48:10 +0200 Subject: [PATCH 05/23] Fix implicit variable --- BLAS/TESTING/sblat3.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/BLAS/TESTING/sblat3.f b/BLAS/TESTING/sblat3.f index a0522d96e8..fb396775a0 100644 --- a/BLAS/TESTING/sblat3.f +++ b/BLAS/TESTING/sblat3.f @@ -3146,7 +3146,7 @@ SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, IF( NULL )THEN ISAME( 12 ) = LSE( CS, CC, LCC ) ELSE - ISAME( 12 ) = LSERES( 'GE', ' ', M, N, + ISAME( 12 ) = LSERES( 'GE', ' ', N, N, $ CS, CC, LDC ) END IF ISAME( 13 ) = LDCS.EQ.LDC From 2f80551ce3a3c24237b038e3e5d126ad772e1dc2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20K=C3=B6hler?= Date: Tue, 22 Aug 2023 09:52:51 +0200 Subject: [PATCH 06/23] Fix further implicit variables --- BLAS/TESTING/cblat3.f | 2 +- BLAS/TESTING/dblat3.f | 2 +- BLAS/TESTING/zblat3.f | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/BLAS/TESTING/cblat3.f b/BLAS/TESTING/cblat3.f index a8cd24c123..efe798add7 100644 --- a/BLAS/TESTING/cblat3.f +++ b/BLAS/TESTING/cblat3.f @@ -3879,7 +3879,7 @@ SUBROUTINE CCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, IF( NULL )THEN ISAME( 12 ) = LCE( CS, CC, LCC ) ELSE - ISAME( 12 ) = LCERES( 'GE', ' ', M, N, CS, + ISAME( 12 ) = LCERES( 'GE', ' ', N, N, CS, $ CC, LDC ) END IF ISAME( 13 ) = LDCS.EQ.LDC diff --git a/BLAS/TESTING/dblat3.f b/BLAS/TESTING/dblat3.f index ddfbbfbd6a..24c5eb7782 100644 --- a/BLAS/TESTING/dblat3.f +++ b/BLAS/TESTING/dblat3.f @@ -3145,7 +3145,7 @@ SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, IF( NULL )THEN ISAME( 12 ) = LDE( CS, CC, LCC ) ELSE - ISAME( 12 ) = LDERES( 'GE', ' ', M, N, + ISAME( 12 ) = LDERES( 'GE', ' ', N, N, $ CS, CC, LDC ) END IF ISAME( 13 ) = LDCS.EQ.LDC diff --git a/BLAS/TESTING/zblat3.f b/BLAS/TESTING/zblat3.f index 9b54f6be8f..ca974cfb77 100644 --- a/BLAS/TESTING/zblat3.f +++ b/BLAS/TESTING/zblat3.f @@ -3893,7 +3893,7 @@ SUBROUTINE ZCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, IF( NULL )THEN ISAME( 12 ) = LZE( CS, CC, LCC ) ELSE - ISAME( 12 ) = LZERES( 'GE', ' ', M, N, CS, + ISAME( 12 ) = LZERES( 'GE', ' ', N, N, CS, $ CC, LDC ) END IF ISAME( 13 ) = LDCS.EQ.LDC From 05d01da9f2281ef0e49382b6cd37757dc67eb534 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20K=C3=B6hler?= Date: Tue, 22 Aug 2023 09:58:58 +0200 Subject: [PATCH 07/23] Fix missing comma --- BLAS/TESTING/cblat3.f | 2 +- BLAS/TESTING/zblat3.f | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/BLAS/TESTING/cblat3.f b/BLAS/TESTING/cblat3.f index efe798add7..1e8c40ae64 100644 --- a/BLAS/TESTING/cblat3.f +++ b/BLAS/TESTING/cblat3.f @@ -3846,7 +3846,7 @@ SUBROUTINE CCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * Call the subroutine. * IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, UPLO + $ WRITE( NTRA, FMT = 9995 )NC, SNAME, UPLO, $ TRANSA, TRANSB, N, K, ALPHA, LDA, LDB, $ BETA, LDC IF( REWI ) diff --git a/BLAS/TESTING/zblat3.f b/BLAS/TESTING/zblat3.f index ca974cfb77..3e6e338ce2 100644 --- a/BLAS/TESTING/zblat3.f +++ b/BLAS/TESTING/zblat3.f @@ -3860,7 +3860,7 @@ SUBROUTINE ZCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * Call the subroutine. * IF( TRACE ) - $ WRITE( NTRA, FMT = 9995 )NC, SNAME, UPLO + $ WRITE( NTRA, FMT = 9995 )NC, SNAME, UPLO, $ TRANSA, TRANSB, N, K, ALPHA, LDA, LDB, $ BETA, LDC IF( REWI ) From 6f66c83ae0c2c0aeb7de5637d661cb5673ca2146 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20K=C3=B6hler?= Date: Tue, 22 Aug 2023 10:24:26 +0200 Subject: [PATCH 08/23] Remove useless variable --- BLAS/TESTING/cblat3.f | 4 ++-- BLAS/TESTING/zblat3.f | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/BLAS/TESTING/cblat3.f b/BLAS/TESTING/cblat3.f index 1e8c40ae64..1d11c1554d 100644 --- a/BLAS/TESTING/cblat3.f +++ b/BLAS/TESTING/cblat3.f @@ -3708,7 +3708,7 @@ SUBROUTINE CCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, COMPLEX ALPHA, ALS, BETA, BLS REAL ERR, ERRMAX INTEGER I, IA, IB, ICA, ICB, IK, IN, K, KS, LAA, - $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M, + $ 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 @@ -3815,7 +3815,7 @@ SUBROUTINE CCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * * Generate the matrix C. * - CALL CMAKE( 'GE', UPLO, ' ', M, N, C, NMAX, + CALL CMAKE( 'GE', UPLO, ' ', N, N, C, NMAX, $ CC, LDC, RESET, ZERO ) * NC = NC + 1 diff --git a/BLAS/TESTING/zblat3.f b/BLAS/TESTING/zblat3.f index 3e6e338ce2..96a6928bfb 100644 --- a/BLAS/TESTING/zblat3.f +++ b/BLAS/TESTING/zblat3.f @@ -3722,7 +3722,7 @@ SUBROUTINE ZCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, COMPLEX*16 ALPHA, ALS, BETA, BLS DOUBLE PRECISION ERR, ERRMAX INTEGER I, IA, IB, ICA, ICB, IK, IN, K, KS, LAA, - $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M, + $ 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 @@ -3829,7 +3829,7 @@ SUBROUTINE ZCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * * Generate the matrix C. * - CALL ZMAKE( 'GE', UPLO, ' ', M, N, C, NMAX, + CALL ZMAKE( 'GE', UPLO, ' ', N, N, C, NMAX, $ CC, LDC, RESET, ZERO ) * NC = NC + 1 From 785d734bf5677acaa439dce53c76f45664b55cb8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20K=C3=B6hler?= Date: Tue, 22 Aug 2023 11:04:51 +0200 Subject: [PATCH 09/23] Fix wrong write --- BLAS/TESTING/cblat3.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/BLAS/TESTING/cblat3.f b/BLAS/TESTING/cblat3.f index 1d11c1554d..7d60c1d1f2 100644 --- a/BLAS/TESTING/cblat3.f +++ b/BLAS/TESTING/cblat3.f @@ -3938,7 +3938,7 @@ SUBROUTINE CCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * 120 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, M, N, K, + WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, N, K, $ ALPHA, LDA, LDB, BETA, LDC * 130 CONTINUE From 6173b6e47447b463806e4f6e0b84afec0c25d0d8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20K=C3=B6hler?= Date: Tue, 22 Aug 2023 11:12:35 +0200 Subject: [PATCH 10/23] Fix another variable --- BLAS/TESTING/zblat3.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/BLAS/TESTING/zblat3.f b/BLAS/TESTING/zblat3.f index 96a6928bfb..1b7c98e96a 100644 --- a/BLAS/TESTING/zblat3.f +++ b/BLAS/TESTING/zblat3.f @@ -3952,7 +3952,7 @@ SUBROUTINE ZCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * 120 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME - WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, M, N, K, + WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, N, K, $ ALPHA, LDA, LDB, BETA, LDC * 130 CONTINUE From 327869db1b83eb82b19aca657cdc9eee235e0053 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20K=C3=B6hler?= Date: Fri, 21 Jun 2024 09:27:51 +0200 Subject: [PATCH 11/23] Rename GEMMT to GEMMTR in BLAS/ After the discussion on /~https://github.com/Reference-LAPACK/lapack/pull/887 the name changed from xGEMMT to xGEMMTR. --- BLAS/SRC/CMakeLists.txt | 8 +- BLAS/SRC/Makefile | 8 +- BLAS/SRC/{cgemmt.f => cgemmtr.f} | 12 +-- BLAS/SRC/{dgemmt.f => dgemmtr.f} | 10 +-- BLAS/SRC/{sgemmt.f => sgemmtr.f} | 12 +-- BLAS/SRC/{zgemmt.f => zgemmtr.f} | 12 +-- BLAS/TESTING/cblat3.f | 122 +++++++++++++++--------------- BLAS/TESTING/cblat3.in | 2 +- BLAS/TESTING/dblat3.f | 60 +++++++-------- BLAS/TESTING/dblat3.in | 2 +- BLAS/TESTING/sblat3.f | 62 ++++++++-------- BLAS/TESTING/sblat3.in | 2 +- BLAS/TESTING/zblat3.f | 124 +++++++++++++++---------------- BLAS/TESTING/zblat3.in | 2 +- 14 files changed, 219 insertions(+), 219 deletions(-) rename BLAS/SRC/{cgemmt.f => cgemmtr.f} (98%) rename BLAS/SRC/{dgemmt.f => dgemmtr.f} (97%) rename BLAS/SRC/{sgemmt.f => sgemmtr.f} (97%) rename BLAS/SRC/{zgemmt.f => zgemmtr.f} (98%) diff --git a/BLAS/SRC/CMakeLists.txt b/BLAS/SRC/CMakeLists.txt index 7af9f451c8..b9e6f7c4a5 100644 --- a/BLAS/SRC/CMakeLists.txt +++ b/BLAS/SRC/CMakeLists.txt @@ -82,15 +82,15 @@ set(ZBLAS2 zgemv.f zgbmv.f zhemv.f zhbmv.f zhpmv.f #--------------------------------------------------------- # Level 3 BLAS #--------------------------------------------------------- -set(SBLAS3 sgemm.f ssymm.f ssyrk.f ssyr2k.f strmm.f strsm.f sgemmt.f) +set(SBLAS3 sgemm.f ssymm.f ssyrk.f ssyr2k.f strmm.f strsm.f sgemmtr.f) set(CBLAS3 cgemm.f csymm.f csyrk.f csyr2k.f ctrmm.f ctrsm.f - chemm.f cherk.f cher2k.f cgemmt.f) + chemm.f cherk.f cher2k.f cgemmtr.f) -set(DBLAS3 dgemm.f dsymm.f dsyrk.f dsyr2k.f dtrmm.f dtrsm.f dgemmt.f) +set(DBLAS3 dgemm.f dsymm.f dsyrk.f dsyr2k.f dtrmm.f dtrsm.f dgemmtr.f) set(ZBLAS3 zgemm.f zsymm.f zsyrk.f zsyr2k.f ztrmm.f ztrsm.f - zhemm.f zherk.f zher2k.f zgemmt.f) + zhemm.f zherk.f zher2k.f zgemmtr.f) set(SOURCES) diff --git a/BLAS/SRC/Makefile b/BLAS/SRC/Makefile index 145f40ff42..486571fec6 100644 --- a/BLAS/SRC/Makefile +++ b/BLAS/SRC/Makefile @@ -127,18 +127,18 @@ $(ZBLAS2): $(FRC) # Comment out the next 4 definitions if you already have # the Level 3 BLAS. #--------------------------------------------------------- -SBLAS3 = sgemm.o ssymm.o ssyrk.o ssyr2k.o strmm.o strsm.o sgemmt.o +SBLAS3 = sgemm.o ssymm.o ssyrk.o ssyr2k.o strmm.o strsm.o sgemmtr.o $(SBLAS3): $(FRC) CBLAS3 = cgemm.o csymm.o csyrk.o csyr2k.o ctrmm.o ctrsm.o \ - chemm.o cherk.o cher2k.o cgemmt.o + chemm.o cherk.o cher2k.o cgemmtr.o $(CBLAS3): $(FRC) -DBLAS3 = dgemm.o dsymm.o dsyrk.o dsyr2k.o dtrmm.o dtrsm.o dgemmt.o +DBLAS3 = dgemm.o dsymm.o dsyrk.o dsyr2k.o dtrmm.o dtrsm.o dgemmtr.o $(DBLAS3): $(FRC) ZBLAS3 = zgemm.o zsymm.o zsyrk.o zsyr2k.o ztrmm.o ztrsm.o \ - zhemm.o zherk.o zher2k.o zgemmt.o + zhemm.o zherk.o zher2k.o zgemmtr.o $(ZBLAS3): $(FRC) ALLOBJ = $(SBLAS1) $(SBLAS2) $(SBLAS3) $(DBLAS1) $(DBLAS2) $(DBLAS3) \ diff --git a/BLAS/SRC/cgemmt.f b/BLAS/SRC/cgemmtr.f similarity index 98% rename from BLAS/SRC/cgemmt.f rename to BLAS/SRC/cgemmtr.f index 653e9877c1..5124a4a195 100644 --- a/BLAS/SRC/cgemmt.f +++ b/BLAS/SRC/cgemmtr.f @@ -1,4 +1,4 @@ -*> \brief \b CGEMMT +*> \brief \b CGEMMTR * * =========== DOCUMENTATION =========== * @@ -8,7 +8,7 @@ * Definition: * =========== * -* SUBROUTINE CGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA, +* SUBROUTINE CGEMMTR(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA, * C,LDC) * * .. Scalar Arguments .. @@ -26,7 +26,7 @@ *> *> \verbatim *> -*> CGEMMT performs one of the matrix-matrix operations +*> CGEMMTR performs one of the matrix-matrix operations *> *> C := alpha*op( A )*op( B ) + beta*C, *> @@ -186,7 +186,7 @@ *> \endverbatim *> * ===================================================================== - SUBROUTINE CGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB, + SUBROUTINE CGEMMTR(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB, + BETA,C,LDC) IMPLICIT NONE * @@ -272,7 +272,7 @@ SUBROUTINE CGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB, INFO = 13 END IF IF (INFO.NE.0) THEN - CALL XERBLA('CGEMMT',INFO) + CALL XERBLA('CGEMMTR',INFO) RETURN END IF * @@ -565,6 +565,6 @@ SUBROUTINE CGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB, * RETURN * -* End of CGEMMT +* End of CGEMMTR * END diff --git a/BLAS/SRC/dgemmt.f b/BLAS/SRC/dgemmtr.f similarity index 97% rename from BLAS/SRC/dgemmt.f rename to BLAS/SRC/dgemmtr.f index 5d767ee607..3a54f17b6f 100644 --- a/BLAS/SRC/dgemmt.f +++ b/BLAS/SRC/dgemmtr.f @@ -1,4 +1,4 @@ -*> \brief \b DGEMMT +*> \brief \b DGEMMTR * * =========== DOCUMENTATION =========== * @@ -8,7 +8,7 @@ * Definition: * =========== * -* SUBROUTINE DGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA, +* SUBROUTINE DGEMMTR(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA, * C,LDC) * * .. Scalar Arguments .. @@ -26,7 +26,7 @@ *> *> \verbatim *> -*> DGEMMT performs one of the matrix-matrix operations +*> DGEMMTR performs one of the matrix-matrix operations *> *> C := alpha*op( A )*op( B ) + beta*C, *> @@ -186,7 +186,7 @@ *> \endverbatim *> * ===================================================================== - SUBROUTINE DGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB, + SUBROUTINE DGEMMTR(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB, + BETA,C,LDC) IMPLICIT NONE * @@ -266,7 +266,7 @@ SUBROUTINE DGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB, INFO = 13 END IF IF (INFO.NE.0) THEN - CALL XERBLA('DGEMMT',INFO) + CALL XERBLA('DGEMMTR',INFO) RETURN END IF * diff --git a/BLAS/SRC/sgemmt.f b/BLAS/SRC/sgemmtr.f similarity index 97% rename from BLAS/SRC/sgemmt.f rename to BLAS/SRC/sgemmtr.f index b2ad38e275..053075f2ff 100644 --- a/BLAS/SRC/sgemmt.f +++ b/BLAS/SRC/sgemmtr.f @@ -1,4 +1,4 @@ -*> \brief \b SGEMMT +*> \brief \b SGEMMTR * * =========== DOCUMENTATION =========== * @@ -8,7 +8,7 @@ * Definition: * =========== * -* SUBROUTINE SGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA, +* SUBROUTINE SGEMMTR(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA, * C,LDC) * * .. Scalar Arguments .. @@ -26,7 +26,7 @@ *> *> \verbatim *> -*> SGEMMT performs one of the matrix-matrix operations +*> SGEMMTR performs one of the matrix-matrix operations *> *> C := alpha*op( A )*op( B ) + beta*C, *> @@ -186,7 +186,7 @@ *> \endverbatim *> * ===================================================================== - SUBROUTINE SGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB, + SUBROUTINE SGEMMTR(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB, + BETA,C,LDC) IMPLICIT NONE * @@ -266,7 +266,7 @@ SUBROUTINE SGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB, INFO = 13 END IF IF (INFO.NE.0) THEN - CALL XERBLA('SGEMMT',INFO) + CALL XERBLA('SGEMMTR',INFO) RETURN END IF * @@ -427,6 +427,6 @@ SUBROUTINE SGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB, * RETURN * -* End of SGEMMT +* End of SGEMMTR * END diff --git a/BLAS/SRC/zgemmt.f b/BLAS/SRC/zgemmtr.f similarity index 98% rename from BLAS/SRC/zgemmt.f rename to BLAS/SRC/zgemmtr.f index 5533c780a7..18adf02dd7 100644 --- a/BLAS/SRC/zgemmt.f +++ b/BLAS/SRC/zgemmtr.f @@ -1,4 +1,4 @@ -*> \brief \b ZGEMMT +*> \brief \b ZGEMMTR * * =========== DOCUMENTATION =========== * @@ -8,7 +8,7 @@ * Definition: * =========== * -* SUBROUTINE ZGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA, +* SUBROUTINE ZGEMMTR(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB,BETA, * C,LDC) * * .. Scalar Arguments .. @@ -26,7 +26,7 @@ *> *> \verbatim *> -*> ZGEMMT performs one of the matrix-matrix operations +*> ZGEMMTR performs one of the matrix-matrix operations *> *> C := alpha*op( A )*op( B ) + beta*C, *> @@ -186,7 +186,7 @@ *> \endverbatim *> * ===================================================================== - SUBROUTINE ZGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB, + SUBROUTINE ZGEMMTR(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB, + BETA,C,LDC) IMPLICIT NONE * @@ -272,7 +272,7 @@ SUBROUTINE ZGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB, INFO = 13 END IF IF (INFO.NE.0) THEN - CALL XERBLA('ZGEMMT',INFO) + CALL XERBLA('ZGEMMTR',INFO) RETURN END IF * @@ -565,6 +565,6 @@ SUBROUTINE ZGEMMT(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB, * RETURN * -* End of ZGEMMT +* End of ZGEMMTR * END diff --git a/BLAS/TESTING/cblat3.f b/BLAS/TESTING/cblat3.f index 7d60c1d1f2..3d9ed49d52 100644 --- a/BLAS/TESTING/cblat3.f +++ b/BLAS/TESTING/cblat3.f @@ -46,7 +46,7 @@ *> CSYRK T PUT F FOR NO TEST. SAME COLUMNS. *> CHER2K T PUT F FOR NO TEST. SAME COLUMNS. *> CSYR2K T PUT F FOR NO TEST. SAME COLUMNS. -*> CGEMMT T PUT F FOR NO TEST. SAME COLUMNS. +*> CGEMMTR T PUT F FOR NO TEST. SAME COLUMNS. *> *> Further Details *> =============== @@ -141,7 +141,7 @@ PROGRAM CBLAT3 * .. Data statements .. DATA SNAMES/'CGEMM ', 'CHEMM ', 'CSYMM ', 'CTRMM ', $ 'CTRSM ', 'CHERK ', 'CSYRK ', 'CHER2K', - $ 'CSYR2K', 'CGEMMT'/ + $ 'CSYR2K', 'CGEMMTR'/ * .. Executable Statements .. * * Read name and unit number for summary output file and open file. @@ -2913,179 +2913,179 @@ SUBROUTINE CCHKE( ISNUM, SRNAMT, NOUT ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 110 100 INFOT = 1 - CALL CGEMMT( '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 1 - CALL CGEMMT( '/', 'N', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( '/', 'N', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 1 - CALL CGEMMT( '/', 'N', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( '/', 'N', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 1 - CALL CGEMMT( '/', 'T', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( '/', 'T', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 1 - CALL CGEMMT( '/', 'T', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( '/', 'T', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 1 - CALL CGEMMT( '/', 'T', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( '/', 'T', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 1 - CALL CGEMMT( '/', 'C', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( '/', 'C', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 1 - CALL CGEMMT( '/', 'C', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( '/', 'C', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 1 - CALL CGEMMT( '/', 'C', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( '/', 'C', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL CGEMMT( 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL CGEMMT( 'U', '/', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', '/', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL CGEMMT( 'U', '/', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', '/', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL CGEMMT( 'L', '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'L', '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL CGEMMT( 'L', '/', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'L', '/', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL CGEMMT( 'L', '/', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'L', '/', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 - CALL CGEMMT( 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 - CALL CGEMMT( 'U', 'C', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'C', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 - CALL CGEMMT( 'U', 'T', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'T', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL CGEMMT( 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL CGEMMT( 'U', 'N', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'N', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL CGEMMT( 'U', 'N', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'N', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL CGEMMT( 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL CGEMMT( 'U', 'C', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'C', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL CGEMMT( 'U', 'C', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'C', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL CGEMMT( 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL CGEMMT( 'U', 'T', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'T', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL CGEMMT( 'U', 'T', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'T', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL CGEMMT( 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL CGEMMT( 'U', 'N', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'N', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL CGEMMT( 'U', 'N', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'N', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL CGEMMT( 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL CGEMMT( 'U', 'C', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'C', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL CGEMMT( 'U', 'C', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'C', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL CGEMMT( 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL CGEMMT( 'U', 'T', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'T', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL CGEMMT( 'U', 'T', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'T', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL CGEMMT( 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) + CALL CGEMMTR( 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL CGEMMT( 'U', 'N', 'C', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) + CALL CGEMMTR( 'U', 'N', 'C', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL CGEMMT( 'U', 'N', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) + CALL CGEMMTR( 'U', 'N', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL CGEMMT( 'U', 'C', 'N', 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'C', 'N', 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL CGEMMT( 'U', 'C', 'C', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'C', 'C', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL CGEMMT( 'U', 'C', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'C', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL CGEMMT( 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL CGEMMT( 'U', 'T', 'C', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'T', 'C', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL CGEMMT( 'U', 'T', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'T', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL CGEMMT( 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL CGEMMT( 'U', 'C', 'N', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'C', 'N', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL CGEMMT( 'U', 'T', 'N', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'T', 'N', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL CGEMMT( 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL CGEMMT( 'U', 'N', 'C', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'N', 'C', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL CGEMMT( 'U', 'N', 'T', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'N', 'T', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL CGEMMT( 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL CGEMMT( 'U', 'C', 'C', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'C', 'C', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL CGEMMT( 'U', 'C', 'T', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'C', 'T', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL CGEMMT( 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL CGEMMT( 'U', 'T', 'C', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'T', 'C', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL CGEMMT( 'U', 'T', 'T', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'T', 'T', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 110 @@ -3676,7 +3676,7 @@ 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 ) * -* Tests CGEMMT. +* Tests CGEMMTR. * * Auxiliary routine for test program for Level 3 Blas. * @@ -3851,7 +3851,7 @@ SUBROUTINE CCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ BETA, LDC IF( REWI ) $ REWIND NTRA - CALL CGEMMT( UPLO, TRANSA, TRANSB, N, K, + CALL CGEMMTR( UPLO, TRANSA, TRANSB, N, K, $ ALPHA, AA, LDA, BB, LDB, BETA, $ CC, LDC ) * diff --git a/BLAS/TESTING/cblat3.in b/BLAS/TESTING/cblat3.in index 686fe64084..a98873cfc7 100644 --- a/BLAS/TESTING/cblat3.in +++ b/BLAS/TESTING/cblat3.in @@ -21,4 +21,4 @@ CHERK T PUT F FOR NO TEST. SAME COLUMNS. CSYRK T PUT F FOR NO TEST. SAME COLUMNS. CHER2K T PUT F FOR NO TEST. SAME COLUMNS. CSYR2K T PUT F FOR NO TEST. SAME COLUMNS. -CGEMMT T PUT F FOR NO TEST. SAME COLUMNS. +CGEMMTR T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/BLAS/TESTING/dblat3.f b/BLAS/TESTING/dblat3.f index 24c5eb7782..011cf5f45a 100644 --- a/BLAS/TESTING/dblat3.f +++ b/BLAS/TESTING/dblat3.f @@ -43,7 +43,7 @@ *> DTRSM T PUT F FOR NO TEST. SAME COLUMNS. *> DSYRK T PUT F FOR NO TEST. SAME COLUMNS. *> DSYR2K T PUT F FOR NO TEST. SAME COLUMNS. -*> DGEMMT T PUT F FOR NO TEST. SAME COLUMNS. +*> DGEMMTR T PUT F FOR NO TEST. SAME COLUMNS. *> *> Further Details *> =============== @@ -133,7 +133,7 @@ PROGRAM DBLAT3 COMMON /SRNAMC/SRNAMT * .. Data statements .. DATA SNAMES/'DGEMM ', 'DSYMM ', 'DTRMM ', 'DTRSM ', - $ 'DSYRK ', 'DSYR2K', 'DGEMMT'/ + $ 'DSYRK ', 'DSYR2K', 'DGEMMTR'/ * .. Executable Statements .. * * Read name and unit number for summary output file and open file. @@ -339,7 +339,7 @@ PROGRAM DBLAT3 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) GO TO 190 -* Test DGEMMT, 07. +* Test DGEMMTR, 07. 185 CALL DCHK6( 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, @@ -2383,73 +2383,73 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 80 70 INFOT = 1 - CALL DGEMMT( '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL DGEMMTR( '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL DGEMMT( 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL DGEMMTR( 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL DGEMMT( 'U', '/', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL DGEMMTR( 'U', '/', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 - CALL DGEMMT( 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL DGEMMTR( 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 - CALL DGEMMT( 'U', 'T', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL DGEMMTR( 'U', 'T', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL DGEMMT( 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL DGEMMTR( 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL DGEMMT( 'U', 'N', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL DGEMMTR( 'U', 'N', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL DGEMMT( 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL DGEMMTR( 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL DGEMMT( 'U', 'T', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL DGEMMTR( 'U', 'T', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL DGEMMT( 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL DGEMMTR( 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL DGEMMT( 'U', 'N', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL DGEMMTR( 'U', 'N', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL DGEMMT( 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL DGEMMTR( 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL DGEMMT( 'U', 'T', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL DGEMMTR( 'U', 'T', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL DGEMMT( 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) + CALL DGEMMTR( 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL DGEMMT( 'U', 'N', 'T', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) + CALL DGEMMTR( 'U', 'N', 'T', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL DGEMMT( 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL DGEMMTR( 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL DGEMMT( 'U', 'T', 'N', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL DGEMMTR( 'U', 'T', 'N', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL DGEMMT( 'U', 'N', 'T', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL DGEMMTR( 'U', 'N', 'T', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL DGEMMT( 'U', 'T', 'T', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL DGEMMTR( 'U', 'T', 'T', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL DGEMMT( 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL DGEMMTR( 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL DGEMMT( 'U', 'N', 'T', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL DGEMMTR( 'U', 'N', 'T', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL DGEMMT( 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL DGEMMTR( 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL DGEMMT( 'U', 'T', 'T', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL DGEMMTR( 'U', 'T', 'T', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) * 80 IF( OK )THEN @@ -2949,7 +2949,7 @@ 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 ) * -* Tests DGEMMT. +* Tests DGEMMTR. * * Auxiliary routine for test program for Level 3 Blas. * @@ -2986,7 +2986,7 @@ SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, LOGICAL LDE, LDERES EXTERNAL LDE, LDERES * .. External Subroutines .. - EXTERNAL DGEMMT, DMAKE, DMMTCH + EXTERNAL DGEMMTR, DMAKE, DMMTCH * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. @@ -3117,7 +3117,7 @@ SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ LDB, BETA, LDC IF( REWI ) $ REWIND NTRA - CALL DGEMMT( UPLO, TRANSA, TRANSB, N, + CALL DGEMMTR( UPLO, TRANSA, TRANSB, N, $ K, ALPHA, AA, LDA, BB, LDB, $ BETA, CC, LDC ) * @@ -3236,7 +3236,7 @@ SUBROUTINE DMMTCH( UPLO, TRANSA, TRANSB, N, KK, ALPHA, A, LDA, * * Checks the results of the computational tests. * -* Auxiliary routine for test program for Level 3 Blas. (DGEMMT) +* Auxiliary routine for test program for Level 3 Blas. (DGEMMTR) * * -- Written on 19-July-2023. * Martin Koehler, MPI Magdeburg diff --git a/BLAS/TESTING/dblat3.in b/BLAS/TESTING/dblat3.in index 82e571ee84..839163fa45 100644 --- a/BLAS/TESTING/dblat3.in +++ b/BLAS/TESTING/dblat3.in @@ -18,4 +18,4 @@ DTRMM T PUT F FOR NO TEST. SAME COLUMNS. DTRSM T PUT F FOR NO TEST. SAME COLUMNS. DSYRK T PUT F FOR NO TEST. SAME COLUMNS. DSYR2K T PUT F FOR NO TEST. SAME COLUMNS. -DGEMMT T PUT F FOR NO TEST. SAME COLUMNS. +DGEMMTR T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/BLAS/TESTING/sblat3.f b/BLAS/TESTING/sblat3.f index fb396775a0..94a1961dab 100644 --- a/BLAS/TESTING/sblat3.f +++ b/BLAS/TESTING/sblat3.f @@ -43,7 +43,7 @@ *> STRSM T PUT F FOR NO TEST. SAME COLUMNS. *> SSYRK T PUT F FOR NO TEST. SAME COLUMNS. *> SSYR2K T PUT F FOR NO TEST. SAME COLUMNS. -*> SGEMMT T PUT F FOR NO TEST. SAME COLUMNS. +*> SGEMMTR T PUT F FOR NO TEST. SAME COLUMNS. *> *> Further Details *> =============== @@ -133,7 +133,7 @@ PROGRAM SBLAT3 COMMON /SRNAMC/SRNAMT * .. Data statements .. DATA SNAMES/'SGEMM ', 'SSYMM ', 'STRMM ', 'STRSM ', - $ 'SSYRK ', 'SSYR2K', 'SGEMMT'/ + $ 'SSYRK ', 'SSYR2K', 'SGEMMTR'/ * .. Executable Statements .. * * Read name and unit number for summary output file and open file. @@ -339,7 +339,7 @@ PROGRAM SBLAT3 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) GO TO 190 -* Test SGEMMT, 07. +* Test SGEMMTR, 07. 185 CALL SCHK6( 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, @@ -1873,7 +1873,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) REAL A( 2, 1 ), B( 2, 1 ), C( 2, 1 ) * .. External Subroutines .. EXTERNAL CHKXER, SGEMM, SSYMM, SSYR2K, SSYRK, STRMM, - $ STRSM, SGEMMT + $ STRSM, SGEMMTR * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR * .. Executable Statements .. @@ -2383,73 +2383,73 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 80 70 INFOT = 1 - CALL SGEMMT( '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL SGEMMTR( '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL SGEMMT( 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL SGEMMTR( 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL SGEMMT( 'U', '/', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL SGEMMTR( 'U', '/', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 - CALL SGEMMT( 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL SGEMMTR( 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 - CALL SGEMMT( 'U', 'T', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL SGEMMTR( 'U', 'T', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL SGEMMT( 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL SGEMMTR( 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL SGEMMT( 'U', 'N', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL SGEMMTR( 'U', 'N', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL SGEMMT( 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL SGEMMTR( 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL SGEMMT( 'U', 'T', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL SGEMMTR( 'U', 'T', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL SGEMMT( 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL SGEMMTR( 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL SGEMMT( 'U', 'N', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL SGEMMTR( 'U', 'N', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL SGEMMT( 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL SGEMMTR( 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL SGEMMT( 'U', 'T', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL SGEMMTR( 'U', 'T', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL SGEMMT( 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) + CALL SGEMMTR( 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL SGEMMT( 'U', 'N', 'T', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) + CALL SGEMMTR( 'U', 'N', 'T', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL SGEMMT( 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL SGEMMTR( 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL SGEMMT( 'U', 'T', 'N', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL SGEMMTR( 'U', 'T', 'N', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL SGEMMT( 'U', 'N', 'T', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL SGEMMTR( 'U', 'N', 'T', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL SGEMMT( 'U', 'T', 'T', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL SGEMMTR( 'U', 'T', 'T', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL SGEMMT( 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL SGEMMTR( 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL SGEMMT( 'U', 'N', 'T', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL SGEMMTR( 'U', 'N', 'T', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL SGEMMT( 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL SGEMMTR( 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL SGEMMT( 'U', 'T', 'T', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL SGEMMTR( 'U', 'T', 'T', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) * 80 IF( OK )THEN @@ -2950,7 +2950,7 @@ 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 ) * -* Tests SGEMMT. +* Tests SGEMMTR. * * Auxiliary routine for test program for Level 3 Blas. * @@ -2987,7 +2987,7 @@ SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, LOGICAL LSE, LSERES EXTERNAL LSE, LSERES * .. External Subroutines .. - EXTERNAL SGEMMT, DMAKE, DMMTCH + EXTERNAL SGEMMTR, DMAKE, DMMTCH * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. @@ -3118,7 +3118,7 @@ SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ LDB, BETA, LDC IF( REWI ) $ REWIND NTRA - CALL SGEMMT( UPLO, TRANSA, TRANSB, N, + CALL SGEMMTR( UPLO, TRANSA, TRANSB, N, $ K, ALPHA, AA, LDA, BB, LDB, $ BETA, CC, LDC ) * @@ -3237,7 +3237,7 @@ SUBROUTINE SMMTCH( UPLO, TRANSA, TRANSB, N, KK, ALPHA, A, LDA, * * Checks the results of the computational tests. * -* Auxiliary routine for test program for Level 3 Blas. (SGEMMT) +* Auxiliary routine for test program for Level 3 Blas. (SGEMMTR) * * -- Written on 19-July-2023. * Martin Koehler, MPI Magdeburg diff --git a/BLAS/TESTING/sblat3.in b/BLAS/TESTING/sblat3.in index 9741a5dd61..2013046003 100644 --- a/BLAS/TESTING/sblat3.in +++ b/BLAS/TESTING/sblat3.in @@ -18,4 +18,4 @@ STRMM T PUT F FOR NO TEST. SAME COLUMNS. STRSM T PUT F FOR NO TEST. SAME COLUMNS. SSYRK T PUT F FOR NO TEST. SAME COLUMNS. SSYR2K T PUT F FOR NO TEST. SAME COLUMNS. -SGEMMT T PUT F FOR NO TEST. SAME COLUMNS. +SGEMMTR T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/BLAS/TESTING/zblat3.f b/BLAS/TESTING/zblat3.f index 1b7c98e96a..a2b85ce961 100644 --- a/BLAS/TESTING/zblat3.f +++ b/BLAS/TESTING/zblat3.f @@ -46,7 +46,7 @@ *> 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. -*> ZGEMMT T PUT F FOR NO TEST. SAME COLUMNS. +*> ZGEMMTR T PUT F FOR NO TEST. SAME COLUMNS. *> *> *> Further Details @@ -143,7 +143,7 @@ PROGRAM ZBLAT3 * .. Data statements .. DATA SNAMES/'ZGEMM ', 'ZHEMM ', 'ZSYMM ', 'ZTRMM ', $ 'ZTRSM ', 'ZHERK ', 'ZSYRK ', 'ZHER2K', - $ 'ZSYR2K', 'ZGEMMT'/ + $ 'ZSYR2K', 'ZGEMMTR'/ * .. Executable Statements .. * * Read name and unit number for summary output file and open file. @@ -350,7 +350,7 @@ PROGRAM ZBLAT3 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) GO TO 190 -* Test ZGEMMT, 01. +* Test ZGEMMTR, 01. 185 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, @@ -2922,179 +2922,179 @@ SUBROUTINE ZCHKE( ISNUM, SRNAMT, NOUT ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 110 100 INFOT = 1 - CALL ZGEMMT( '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 1 - CALL ZGEMMT( '/', 'N', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( '/', 'N', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 1 - CALL ZGEMMT( '/', 'N', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( '/', 'N', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 1 - CALL ZGEMMT( '/', 'T', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( '/', 'T', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 1 - CALL ZGEMMT( '/', 'T', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( '/', 'T', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 1 - CALL ZGEMMT( '/', 'T', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( '/', 'T', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 1 - CALL ZGEMMT( '/', 'C', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( '/', 'C', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 1 - CALL ZGEMMT( '/', 'C', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( '/', 'C', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 1 - CALL ZGEMMT( '/', 'C', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( '/', 'C', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL ZGEMMT( 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL ZGEMMT( 'U', '/', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', '/', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL ZGEMMT( 'U', '/', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', '/', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL ZGEMMT( 'L', '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'L', '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL ZGEMMT( 'L', '/', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'L', '/', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL ZGEMMT( 'L', '/', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'L', '/', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 - CALL ZGEMMT( 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 - CALL ZGEMMT( 'U', 'C', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'C', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 - CALL ZGEMMT( 'U', 'T', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'T', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL ZGEMMT( 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL ZGEMMT( 'U', 'N', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'N', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL ZGEMMT( 'U', 'N', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'N', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL ZGEMMT( 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL ZGEMMT( 'U', 'C', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'C', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL ZGEMMT( 'U', 'C', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'C', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL ZGEMMT( 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL ZGEMMT( 'U', 'T', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'T', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL ZGEMMT( 'U', 'T', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'T', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL ZGEMMT( 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL ZGEMMT( 'U', 'N', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'N', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL ZGEMMT( 'U', 'N', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'N', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL ZGEMMT( 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL ZGEMMT( 'U', 'C', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'C', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL ZGEMMT( 'U', 'C', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'C', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL ZGEMMT( 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL ZGEMMT( 'U', 'T', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'T', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL ZGEMMT( 'U', 'T', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'T', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL ZGEMMT( 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) + CALL ZGEMMTR( 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL ZGEMMT( 'U', 'N', 'C', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) + CALL ZGEMMTR( 'U', 'N', 'C', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL ZGEMMT( 'U', 'N', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) + CALL ZGEMMTR( 'U', 'N', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL ZGEMMT( 'U', 'C', 'N', 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'C', 'N', 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL ZGEMMT( 'U', 'C', 'C', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'C', 'C', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL ZGEMMT( 'U', 'C', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'C', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL ZGEMMT( 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL ZGEMMT( 'U', 'T', 'C', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'T', 'C', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL ZGEMMT( 'U', 'T', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'T', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL ZGEMMT( 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL ZGEMMT( 'U', 'C', 'N', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'C', 'N', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL ZGEMMT( 'U', 'T', 'N', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'T', 'N', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL ZGEMMT( 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL ZGEMMT( 'U', 'N', 'C', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'N', 'C', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL ZGEMMT( 'U', 'N', 'T', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'N', 'T', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL ZGEMMT( 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL ZGEMMT( 'U', 'C', 'C', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'C', 'C', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL ZGEMMT( 'U', 'C', 'T', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'C', 'T', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL ZGEMMT( 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL ZGEMMT( 'U', 'T', 'C', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'T', 'C', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 - CALL ZGEMMT( 'U', 'T', 'T', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'T', 'T', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 110 @@ -3690,7 +3690,7 @@ 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 ) * -* Tests ZGEMMT. +* Tests ZGEMMTR. * * Auxiliary routine for test program for Level 3 Blas. * @@ -3865,7 +3865,7 @@ SUBROUTINE ZCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ BETA, LDC IF( REWI ) $ REWIND NTRA - CALL ZGEMMT( UPLO, TRANSA, TRANSB, N, K, + CALL ZGEMMTR( UPLO, TRANSA, TRANSB, N, K, $ ALPHA, AA, LDA, BB, LDB, BETA, $ CC, LDC ) * diff --git a/BLAS/TESTING/zblat3.in b/BLAS/TESTING/zblat3.in index ed6e9dd601..6160d7af99 100644 --- a/BLAS/TESTING/zblat3.in +++ b/BLAS/TESTING/zblat3.in @@ -21,4 +21,4 @@ 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. -ZGEMMT T PUT F FOR NO TEST. SAME COLUMNS. +ZGEMMTR T PUT F FOR NO TEST. SAME COLUMNS. From 81b3767a5a782b9986cbb4048d336142f9987de2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20K=C3=B6hler?= Date: Fri, 21 Jun 2024 09:32:20 +0200 Subject: [PATCH 12/23] Change xGEMMT to xGEMMTR in CBLAS/ --- CBLAS/include/cblas.h | 8 ++--- CBLAS/include/cblas_64.h | 8 ++--- CBLAS/include/cblas_f77.h | 32 +++++++++---------- CBLAS/include/cblas_test.h | 8 ++--- CBLAS/src/CMakeLists.txt | 8 ++--- CBLAS/src/Makefile | 8 ++--- CBLAS/src/{cblas_cgemmt.c => cblas_cgemmtr.c} | 20 ++++++------ CBLAS/src/{cblas_dgemmt.c => cblas_dgemmtr.c} | 18 +++++------ CBLAS/src/{cblas_sgemmt.c => cblas_sgemmtr.c} | 18 +++++------ CBLAS/src/{cblas_zgemmt.c => cblas_zgemmtr.c} | 18 +++++------ CBLAS/testing/c_c3chke.c | 4 +-- CBLAS/testing/c_cblas3.c | 8 ++--- CBLAS/testing/c_cblat3.f | 10 +++--- CBLAS/testing/cin3 | 2 +- 14 files changed, 85 insertions(+), 85 deletions(-) rename CBLAS/src/{cblas_cgemmt.c => cblas_cgemmtr.c} (75%) rename CBLAS/src/{cblas_dgemmt.c => cblas_dgemmtr.c} (76%) rename CBLAS/src/{cblas_sgemmt.c => cblas_sgemmtr.c} (80%) rename CBLAS/src/{cblas_zgemmt.c => cblas_zgemmtr.c} (76%) diff --git a/CBLAS/include/cblas.h b/CBLAS/include/cblas.h index c323e9e5aa..b8baf4eca5 100644 --- a/CBLAS/include/cblas.h +++ b/CBLAS/include/cblas.h @@ -472,7 +472,7 @@ void cblas_sgemm(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA, const CBLAS_INT K, const float alpha, const float *A, const CBLAS_INT lda, const float *B, const CBLAS_INT ldb, const float beta, float *C, const CBLAS_INT ldc); -void cblas_sgemmt(CBLAS_LAYOUT layout,CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, +void cblas_sgemmtr(CBLAS_LAYOUT layout,CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, CBLAS_TRANSPOSE TransB, const CBLAS_INT N, const CBLAS_INT K, const float alpha, const float *A, const CBLAS_INT lda, const float *B, const CBLAS_INT ldb, @@ -508,7 +508,7 @@ void cblas_dgemm(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA, const CBLAS_INT K, const double alpha, const double *A, const CBLAS_INT lda, const double *B, const CBLAS_INT ldb, const double beta, double *C, const CBLAS_INT ldc); -void cblas_dgemmt(CBLAS_LAYOUT layout,CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, +void cblas_dgemmtr(CBLAS_LAYOUT layout,CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, CBLAS_TRANSPOSE TransB, const CBLAS_INT N, const CBLAS_INT K, const double alpha, const double *A, const CBLAS_INT lda, const double *B, const CBLAS_INT ldb, @@ -543,7 +543,7 @@ void cblas_cgemm(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA, const CBLAS_INT K, const void *alpha, const void *A, const CBLAS_INT lda, const void *B, const CBLAS_INT ldb, const void *beta, void *C, const CBLAS_INT ldc); -void cblas_cgemmt(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, +void cblas_cgemmtr(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, CBLAS_TRANSPOSE TransB, const CBLAS_INT N, const CBLAS_INT K, const void *alpha, const void *A, const CBLAS_INT lda, const void *B, const CBLAS_INT ldb, @@ -578,7 +578,7 @@ void cblas_zgemm(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA, const CBLAS_INT K, const void *alpha, const void *A, const CBLAS_INT lda, const void *B, const CBLAS_INT ldb, const void *beta, void *C, const CBLAS_INT ldc); -void cblas_zgemmt(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, +void cblas_zgemmtr(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, CBLAS_TRANSPOSE TransB, const CBLAS_INT N, const CBLAS_INT K, const void *alpha, const void *A, const CBLAS_INT lda, const void *B, const CBLAS_INT ldb, diff --git a/CBLAS/include/cblas_64.h b/CBLAS/include/cblas_64.h index aa4125b9bf..16504d9142 100644 --- a/CBLAS/include/cblas_64.h +++ b/CBLAS/include/cblas_64.h @@ -423,7 +423,7 @@ void cblas_sgemm_64(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA, const int64_t K, const float alpha, const float *A, const int64_t lda, const float *B, const int64_t ldb, const float beta, float *C, const int64_t ldc); -void cblas_sgemmt_64(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, +void cblas_sgemmtr_64(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, CBLAS_TRANSPOSE TransB, const int64_t N, const int64_t K, const float alpha, const float *A, const int64_t lda, const float *B, const int64_t ldb, @@ -459,7 +459,7 @@ void cblas_dgemm_64(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA, const int64_t K, const double alpha, const double *A, const int64_t lda, const double *B, const int64_t ldb, const double beta, double *C, const int64_t ldc); -void cblas_dgemmt_64(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, +void cblas_dgemmtr_64(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, CBLAS_TRANSPOSE TransB, const int64_t N, const int64_t K, const double alpha, const double *A, const int64_t lda, const double *B, const int64_t ldb, @@ -494,7 +494,7 @@ void cblas_cgemm_64(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA, const int64_t K, const void *alpha, const void *A, const int64_t lda, const void *B, const int64_t ldb, const void *beta, void *C, const int64_t ldc); -void cblas_cgemmt_64(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, +void cblas_cgemmtr_64(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, CBLAS_TRANSPOSE TransB, const int64_t N, const int64_t K, const void *alpha, const void *A, const int64_t lda, const void *B, const int64_t ldb, @@ -530,7 +530,7 @@ void cblas_zgemm_64(CBLAS_LAYOUT layout, CBLAS_TRANSPOSE TransA, const int64_t K, const void *alpha, const void *A, const int64_t lda, const void *B, const int64_t ldb, const void *beta, void *C, const int64_t ldc); -void cblas_zgemmt_64(CBLAS_LAYOUT layout,CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, +void cblas_zgemmtr_64(CBLAS_LAYOUT layout,CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, CBLAS_TRANSPOSE TransB, const int64_t N, const int64_t K, const void *alpha, const void *A, const int64_t lda, const void *B, const int64_t ldb, diff --git a/CBLAS/include/cblas_f77.h b/CBLAS/include/cblas_f77.h index 35bd315336..4880690f6f 100644 --- a/CBLAS/include/cblas_f77.h +++ b/CBLAS/include/cblas_f77.h @@ -197,28 +197,28 @@ #define F77_zherk_base F77_GLOBAL_SUFFIX(zherk,ZHERK) #define F77_zher2k_base F77_GLOBAL_SUFFIX(zher2k,ZHER2K) #define F77_sgemm_base F77_GLOBAL_SUFFIX(sgemm,SGEMM) -#define F77_sgemmt_base F77_GLOBAL_SUFFIX(sgemmt,SGEMMT) +#define F77_sgemmtr_base F77_GLOBAL_SUFFIX(sgemmtr,SGEMMTR) #define F77_ssymm_base F77_GLOBAL_SUFFIX(ssymm,SSYMM) #define F77_ssyrk_base F77_GLOBAL_SUFFIX(ssyrk,SSYRK) #define F77_ssyr2k_base F77_GLOBAL_SUFFIX(ssyr2k,SSYR2K) #define F77_strmm_base F77_GLOBAL_SUFFIX(strmm,STRMM) #define F77_strsm_base F77_GLOBAL_SUFFIX(strsm,STRSM) #define F77_dgemm_base F77_GLOBAL_SUFFIX(dgemm,DGEMM) -#define F77_dgemmt_base F77_GLOBAL_SUFFIX(dgemmt,DGEMMT) +#define F77_dgemmtr_base F77_GLOBAL_SUFFIX(dgemmtr,DGEMMTR) #define F77_dsymm_base F77_GLOBAL_SUFFIX(dsymm,DSYMM) #define F77_dsyrk_base F77_GLOBAL_SUFFIX(dsyrk,DSYRK) #define F77_dsyr2k_base F77_GLOBAL_SUFFIX(dsyr2k,DSYR2K) #define F77_dtrmm_base F77_GLOBAL_SUFFIX(dtrmm,DTRMM) #define F77_dtrsm_base F77_GLOBAL_SUFFIX(dtrsm,DTRSM) #define F77_cgemm_base F77_GLOBAL_SUFFIX(cgemm,CGEMM) -#define F77_cgemmt_base F77_GLOBAL_SUFFIX(cgemmt,CGEMMT) +#define F77_cgemmtr_base F77_GLOBAL_SUFFIX(cgemmtr,CGEMMTR) #define F77_csymm_base F77_GLOBAL_SUFFIX(csymm,CSYMM) #define F77_csyrk_base F77_GLOBAL_SUFFIX(csyrk,CSYRK) #define F77_csyr2k_base F77_GLOBAL_SUFFIX(csyr2k,CSYR2K) #define F77_ctrmm_base F77_GLOBAL_SUFFIX(ctrmm,CTRMM) #define F77_ctrsm_base F77_GLOBAL_SUFFIX(ctrsm,CTRSM) #define F77_zgemm_base F77_GLOBAL_SUFFIX(zgemm,ZGEMM) -#define F77_zgemmt_base F77_GLOBAL_SUFFIX(zgemmt,ZGEMMT) +#define F77_zgemmtr_base F77_GLOBAL_SUFFIX(zgemmtr,ZGEMMTR) #define F77_zsymm_base F77_GLOBAL_SUFFIX(zsymm,ZSYMM) #define F77_zsyrk_base F77_GLOBAL_SUFFIX(zsyrk,ZSYRK) #define F77_zsyr2k_base F77_GLOBAL_SUFFIX(zsyr2k,ZSYR2K) @@ -393,7 +393,7 @@ /* Single Precision */ #define F77_sgemm(...) F77_sgemm_base(__VA_ARGS__, 1, 1) - #define F77_sgemmt(...) F77_sgemmt_base(__VA_ARGS__, 1, 1, 1) + #define F77_sgemmtr(...) F77_sgemmtr_base(__VA_ARGS__, 1, 1, 1) #define F77_ssymm(...) F77_ssymm_base(__VA_ARGS__, 1, 1) #define F77_ssyrk(...) F77_ssyrk_base(__VA_ARGS__, 1, 1) #define F77_ssyr2k(...) F77_ssyr2k_base(__VA_ARGS__, 1, 1) @@ -403,7 +403,7 @@ /* Double Precision */ #define F77_dgemm(...) F77_dgemm_base(__VA_ARGS__, 1, 1) - #define F77_dgemmt(...) F77_dgemmt_base(__VA_ARGS__, 1, 1, 1) + #define F77_dgemmtr(...) F77_dgemmtr_base(__VA_ARGS__, 1, 1, 1) #define F77_dsymm(...) F77_dsymm_base(__VA_ARGS__, 1, 1) #define F77_dsyrk(...) F77_dsyrk_base(__VA_ARGS__, 1, 1) #define F77_dsyr2k(...) F77_dsyr2k_base(__VA_ARGS__, 1, 1) @@ -413,7 +413,7 @@ /* Single Complex Precision */ #define F77_cgemm(...) F77_cgemm_base(__VA_ARGS__, 1, 1) - #define F77_cgemmt(...) F77_cgemmt_base(__VA_ARGS__, 1, 1, 1) + #define F77_cgemmtr(...) F77_cgemmtr_base(__VA_ARGS__, 1, 1, 1) #define F77_csymm(...) F77_csymm_base(__VA_ARGS__, 1, 1) #define F77_chemm(...) F77_chemm_base(__VA_ARGS__, 1, 1) #define F77_csyrk(...) F77_csyrk_base(__VA_ARGS__, 1, 1) @@ -426,7 +426,7 @@ /* Double Complex Precision */ #define F77_zgemm(...) F77_zgemm_base(__VA_ARGS__, 1, 1) - #define F77_zgemmt(...) F77_zgemmt_base(__VA_ARGS__, 1, 1, 1) + #define F77_zgemmtr(...) F77_zgemmtr_base(__VA_ARGS__, 1, 1, 1) #define F77_zsymm(...) F77_zsymm_base(__VA_ARGS__, 1, 1) #define F77_zhemm(...) F77_zhemm_base(__VA_ARGS__, 1, 1) #define F77_zsyrk(...) F77_zsyrk_base(__VA_ARGS__, 1, 1) @@ -521,7 +521,7 @@ /* Single Precision */ #define F77_sgemm(...) F77_sgemm_base(__VA_ARGS__) - #define F77_sgemmt(...) F77_sgemmt_base(__VA_ARGS__) + #define F77_sgemmtr(...) F77_sgemmtr_base(__VA_ARGS__) #define F77_ssymm(...) F77_ssymm_base(__VA_ARGS__) #define F77_ssyrk(...) F77_ssyrk_base(__VA_ARGS__) #define F77_ssyr2k(...) F77_ssyr2k_base(__VA_ARGS__) @@ -531,7 +531,7 @@ /* Double Precision */ #define F77_dgemm(...) F77_dgemm_base(__VA_ARGS__) - #define F77_dgemmt(...) F77_dgemmt_base(__VA_ARGS__) + #define F77_dgemmtr(...) F77_dgemmtr_base(__VA_ARGS__) #define F77_dsymm(...) F77_dsymm_base(__VA_ARGS__) #define F77_dsyrk(...) F77_dsyrk_base(__VA_ARGS__) #define F77_dsyr2k(...) F77_dsyr2k_base(__VA_ARGS__) @@ -541,7 +541,7 @@ /* Single Complex Precision */ #define F77_cgemm(...) F77_cgemm_base(__VA_ARGS__) - #define F77_cgemmt(...) F77_cgemmt_base(__VA_ARGS__) + #define F77_cgemmtr(...) F77_cgemmtr_base(__VA_ARGS__) #define F77_csymm(...) F77_csymm_base(__VA_ARGS__) #define F77_chemm(...) F77_chemm_base(__VA_ARGS__) #define F77_csyrk(...) F77_csyrk_base(__VA_ARGS__) @@ -554,7 +554,7 @@ /* Double Complex Precision */ #define F77_zgemm(...) F77_zgemm_base(__VA_ARGS__) - #define F77_zgemmt(...) F77_zgemmt_base(__VA_ARGS__) + #define F77_zgemmtr(...) F77_zgemmtr_base(__VA_ARGS__) #define F77_zsymm(...) F77_zsymm_base(__VA_ARGS__) #define F77_zhemm(...) F77_zhemm_base(__VA_ARGS__) #define F77_zsyrk(...) F77_zsyrk_base(__VA_ARGS__) @@ -993,7 +993,7 @@ void F77_sgemm_base(FCHAR, FCHAR, FINT, FINT, FINT, const float *, const float * , FORTRAN_STRLEN, FORTRAN_STRLEN #endif ); -void F77_sgemmt_base(FCHAR, FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT +void F77_sgemmtr_base(FCHAR, FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT #ifdef BLAS_FORTRAN_STRLEN_END , size_t, size_t, size_t #endif @@ -1032,7 +1032,7 @@ void F77_dgemm_base(FCHAR, FCHAR, FINT, FINT, FINT, const double *, const double , FORTRAN_STRLEN, FORTRAN_STRLEN #endif ); -void F77_dgemmt_base(FCHAR, FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT +void F77_dgemmtr_base(FCHAR, FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT #ifdef BLAS_FORTRAN_STRLEN_END , size_t, size_t, size_t #endif @@ -1072,7 +1072,7 @@ void F77_cgemm_base(FCHAR, FCHAR, FINT, FINT, FINT, const void *, const void *, #endif ); -void F77_cgemmt_base(FCHAR, FCHAR, FCHAR, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT +void F77_cgemmtr_base(FCHAR, FCHAR, FCHAR, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT #ifdef BLAS_FORTRAN_STRLEN_END , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN #endif @@ -1127,7 +1127,7 @@ void F77_zgemm_base(FCHAR, FCHAR, FINT, FINT, FINT, const void *, const void *, #endif ); -void F77_zgemmt_base(FCHAR, FCHAR, FCHAR, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT +void F77_zgemmtr_base(FCHAR, FCHAR, FCHAR, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT #ifdef BLAS_FORTRAN_STRLEN_END , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN #endif diff --git a/CBLAS/include/cblas_test.h b/CBLAS/include/cblas_test.h index 9da8c28a0e..4374cb378f 100644 --- a/CBLAS/include/cblas_test.h +++ b/CBLAS/include/cblas_test.h @@ -167,28 +167,28 @@ typedef struct { double real; double imag; } CBLAS_TEST_ZOMPLEX; #define F77_zherk F77_GLOBAL(czherk,CZHERK) #define F77_zher2k F77_GLOBAL(czher2k,CZHER2K) #define F77_sgemm F77_GLOBAL(csgemm,CSGEMM) -#define F77_sgemmt F77_GLOBAL(csgemmt,CSGEMMT) +#define F77_sgemmtr F77_GLOBAL(csgemmtr,CSGEMMTR) #define F77_ssymm F77_GLOBAL(cssymm,CSSYMM) #define F77_ssyrk F77_GLOBAL(cssyrk,CSSYRK) #define F77_ssyr2k F77_GLOBAL(cssyr2k,CSSYR2K) #define F77_strmm F77_GLOBAL(cstrmm,CSTRMM) #define F77_strsm F77_GLOBAL(cstrsm,CSTRSM) #define F77_dgemm F77_GLOBAL(cdgemm,CDGEMM) -#define F77_dgemmt F77_GLOBAL(cdgemmt,CDGEMMT) +#define F77_dgemmtr F77_GLOBAL(cdgemmtr,CDGEMMTR) #define F77_dsymm F77_GLOBAL(cdsymm,CDSYMM) #define F77_dsyrk F77_GLOBAL(cdsyrk,CDSYRK) #define F77_dsyr2k F77_GLOBAL(cdsyr2k,CDSYR2K) #define F77_dtrmm F77_GLOBAL(cdtrmm,CDTRMM) #define F77_dtrsm F77_GLOBAL(cdtrsm,CDTRSM) #define F77_cgemm F77_GLOBAL(ccgemm,CCGEMM) -#define F77_cgemmt F77_GLOBAL(ccgemmt,CCGEMMT) +#define F77_cgemmtr F77_GLOBAL(ccgemmtr,CCGEMMTR) #define F77_csymm F77_GLOBAL(ccsymm,CCSYMM) #define F77_csyrk F77_GLOBAL(ccsyrk,CCSYRK) #define F77_csyr2k F77_GLOBAL(ccsyr2k,CCSYR2K) #define F77_ctrmm F77_GLOBAL(cctrmm,CCTRMM) #define F77_ctrsm F77_GLOBAL(cctrsm,CCTRSM) #define F77_zgemm F77_GLOBAL(czgemm,CZGEMM) -#define F77_zgemmt F77_GLOBAL(czgemmt,CZGEMMT) +#define F77_zgemmtr F77_GLOBAL(czgemmtr,CZGEMMTR) #define F77_zsymm F77_GLOBAL(czsymm,CZSYMM) #define F77_zsyrk F77_GLOBAL(czsyrk,CZSYRK) #define F77_zsyr2k F77_GLOBAL(czsyr2k,CZSYR2K) diff --git a/CBLAS/src/CMakeLists.txt b/CBLAS/src/CMakeLists.txt index 67926534e9..2979d91a6d 100644 --- a/CBLAS/src/CMakeLists.txt +++ b/CBLAS/src/CMakeLists.txt @@ -85,21 +85,21 @@ set(ZLEV2 cblas_zgemv.c cblas_zgbmv.c cblas_zhemv.c cblas_zhbmv.c cblas_zhpmv.c # Files for level 3 single precision real set(SLEV3 cblas_sgemm.c cblas_ssymm.c cblas_ssyrk.c cblas_ssyr2k.c cblas_strmm.c - cblas_strsm.c cblas_sgemmt.c) + cblas_strsm.c cblas_sgemmtr.c) # Files for level 3 double precision real set(DLEV3 cblas_dgemm.c cblas_dsymm.c cblas_dsyrk.c cblas_dsyr2k.c cblas_dtrmm.c - cblas_dtrsm.c cblas_cgemmt.c) + cblas_dtrsm.c cblas_cgemmtr.c) # Files for level 3 single precision complex set(CLEV3 cblas_cgemm.c cblas_csymm.c cblas_chemm.c cblas_cherk.c cblas_cher2k.c cblas_ctrmm.c cblas_ctrsm.c cblas_csyrk.c - cblas_csyr2k.c cblas_cgemmt.c) + cblas_csyr2k.c cblas_cgemmtr.c) # Files for level 3 double precision complex set(ZLEV3 cblas_zgemm.c cblas_zsymm.c cblas_zhemm.c cblas_zherk.c cblas_zher2k.c cblas_ztrmm.c cblas_ztrsm.c cblas_zsyrk.c - cblas_zsyr2k.c cblas_zgemmt.c) + cblas_zsyr2k.c cblas_zgemmtr.c) set(SOURCES) diff --git a/CBLAS/src/Makefile b/CBLAS/src/Makefile index ba0b63a487..abc3192c6a 100644 --- a/CBLAS/src/Makefile +++ b/CBLAS/src/Makefile @@ -137,21 +137,21 @@ zlib2: $(zlev2) $(errhand) # Files for level 3 single precision real slev3 = cblas_sgemm.o cblas_ssymm.o cblas_ssyrk.o cblas_ssyr2k.o cblas_strmm.o \ - cblas_strsm.o cblas_sgemmt.o + cblas_strsm.o cblas_sgemmtr.o # Files for level 3 double precision real dlev3 = cblas_dgemm.o cblas_dsymm.o cblas_dsyrk.o cblas_dsyr2k.o cblas_dtrmm.o \ - cblas_dtrsm.o cblas_dgemmt.o + cblas_dtrsm.o cblas_dgemmtr.o # Files for level 3 single precision complex clev3 = cblas_cgemm.o cblas_csymm.o cblas_chemm.o cblas_cherk.o \ cblas_cher2k.o cblas_ctrmm.o cblas_ctrsm.o cblas_csyrk.o \ - cblas_csyr2k.o cblas_cgemmt.o + cblas_csyr2k.o cblas_cgemmtr.o # Files for level 3 double precision complex zlev3 = cblas_zgemm.o cblas_zsymm.o cblas_zhemm.o cblas_zherk.o \ cblas_zher2k.o cblas_ztrmm.o cblas_ztrsm.o cblas_zsyrk.o \ - cblas_zsyr2k.o cblas_zgemmt.o + cblas_zsyr2k.o cblas_zgemmtr.o .PHONY: slib3 dlib3 clib3 zlib3 # Single precision real diff --git a/CBLAS/src/cblas_cgemmt.c b/CBLAS/src/cblas_cgemmtr.c similarity index 75% rename from CBLAS/src/cblas_cgemmt.c rename to CBLAS/src/cblas_cgemmtr.c index 2d2fae25e7..9eb3592ca3 100644 --- a/CBLAS/src/cblas_cgemmt.c +++ b/CBLAS/src/cblas_cgemmtr.c @@ -9,7 +9,7 @@ #include "cblas.h" #include "cblas_f77.h" -void API_SUFFIX(cblas_cgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, +void API_SUFFIX(cblas_cgemmtr)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, const CBLAS_TRANSPOSE TransB, const CBLAS_INT N, const CBLAS_INT K, const void *alpha, const void *A, const CBLAS_INT lda, const void *B, const CBLAS_INT ldb, @@ -47,7 +47,7 @@ void API_SUFFIX(cblas_cgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if ( Uplo == CblasUpper ) UL = 'U'; else if (Uplo == CblasLower) UL= 'L'; else { - API_SUFFIX(cblas_xerbla)(2, "cblas_cgemmt", "Illegal Uplo setting, %d\n", Uplo); + API_SUFFIX(cblas_xerbla)(2, "cblas_cgemmtr", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; @@ -58,7 +58,7 @@ void API_SUFFIX(cblas_cgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, else if ( TransA == CblasNoTrans ) TA='N'; else { - API_SUFFIX(cblas_xerbla)(3, "cblas_cgemmt", "Illegal TransA setting, %d\n", TransA); + API_SUFFIX(cblas_xerbla)(3, "cblas_cgemmtr", "Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; @@ -69,7 +69,7 @@ void API_SUFFIX(cblas_cgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, else if ( TransB == CblasNoTrans ) TB='N'; else { - API_SUFFIX(cblas_xerbla)(4, "cblas_cgemmt", "Illegal TransB setting, %d\n", TransB); + API_SUFFIX(cblas_xerbla)(4, "cblas_cgemmtr", "Illegal TransB setting, %d\n", TransB); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; @@ -81,7 +81,7 @@ void API_SUFFIX(cblas_cgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, F77_UL = C2F_CHAR(&UL); #endif - F77_cgemmt(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, alpha, A, + F77_cgemmtr(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, alpha, A, &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); } else if (layout == CblasRowMajor) { @@ -90,7 +90,7 @@ void API_SUFFIX(cblas_cgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if ( Uplo == CblasUpper ) UL = 'L'; else if (Uplo == CblasLower) UL= 'U'; else { - API_SUFFIX(cblas_xerbla)(2, "cblas_cgemmt", "Illegal Uplo setting, %d\n", Uplo); + API_SUFFIX(cblas_xerbla)(2, "cblas_cgemmtr", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; @@ -101,7 +101,7 @@ void API_SUFFIX(cblas_cgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, else if ( TransA == CblasNoTrans ) TB='N'; else { - API_SUFFIX(cblas_xerbla)(3, "cblas_cgemmt", "Illegal TransA setting, %d\n", TransA); + API_SUFFIX(cblas_xerbla)(3, "cblas_cgemmtr", "Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; @@ -111,7 +111,7 @@ void API_SUFFIX(cblas_cgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, else if ( TransB == CblasNoTrans ) TA='N'; else { - API_SUFFIX(cblas_xerbla)(4, "cblas_cgemmt", "Illegal TransB setting, %d\n", TransB); + API_SUFFIX(cblas_xerbla)(4, "cblas_cgemmtr", "Illegal TransB setting, %d\n", TransB); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; @@ -123,10 +123,10 @@ void API_SUFFIX(cblas_cgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, #endif - F77_cgemmt(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, alpha, B, + F77_cgemmtr(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, alpha, B, &F77_ldb, A, &F77_lda, beta, C, &F77_ldc); } - else API_SUFFIX(cblas_xerbla)(1, "cblas_cgemmt", "Illegal layout setting, %d\n", layout); + else API_SUFFIX(cblas_xerbla)(1, "cblas_cgemmtr", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; diff --git a/CBLAS/src/cblas_dgemmt.c b/CBLAS/src/cblas_dgemmtr.c similarity index 76% rename from CBLAS/src/cblas_dgemmt.c rename to CBLAS/src/cblas_dgemmtr.c index 84242f5c83..99a2fa81a8 100644 --- a/CBLAS/src/cblas_dgemmt.c +++ b/CBLAS/src/cblas_dgemmtr.c @@ -9,7 +9,7 @@ #include "cblas.h" #include "cblas_f77.h" -void API_SUFFIX(cblas_dgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, +void API_SUFFIX(cblas_dgemmtr)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, const CBLAS_TRANSPOSE TransB, const CBLAS_INT N, const CBLAS_INT K, const double alpha, const double *A, const CBLAS_INT lda, const double *B, const CBLAS_INT ldb, @@ -43,7 +43,7 @@ void API_SUFFIX(cblas_dgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if ( Uplo == CblasUpper ) UL = 'U'; else if (Uplo == CblasLower) UL= 'L'; else { - API_SUFFIX(cblas_xerbla)(2, "cblas_dgemmt", "Illegal Uplo setting, %d\n", Uplo); + API_SUFFIX(cblas_xerbla)(2, "cblas_dgemmtr", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; @@ -57,7 +57,7 @@ void API_SUFFIX(cblas_dgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, else if ( TransA == CblasNoTrans ) TA='N'; else { - API_SUFFIX(cblas_xerbla)(3, "cblas_dgemmt","Illegal TransA setting, %d\n", TransA); + API_SUFFIX(cblas_xerbla)(3, "cblas_dgemmtr","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; @@ -68,7 +68,7 @@ void API_SUFFIX(cblas_dgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, else if ( TransB == CblasNoTrans ) TB='N'; else { - API_SUFFIX(cblas_xerbla)(4, "cblas_dgemmt","Illegal TransB setting, %d\n", TransB); + API_SUFFIX(cblas_xerbla)(4, "cblas_dgemmtr","Illegal TransB setting, %d\n", TransB); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; @@ -80,7 +80,7 @@ void API_SUFFIX(cblas_dgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, F77_UL = C2F_CHAR(&UL); #endif - F77_dgemmt(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, &alpha, A, + F77_dgemmtr(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, &alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); } else if (layout == CblasRowMajor) { @@ -90,7 +90,7 @@ void API_SUFFIX(cblas_dgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, else if ( TransA == CblasNoTrans ) TB='N'; else { - API_SUFFIX(cblas_xerbla)(3, "cblas_dgemmt","Illegal TransA setting, %d\n", TransA); + API_SUFFIX(cblas_xerbla)(3, "cblas_dgemmtr","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; @@ -100,7 +100,7 @@ void API_SUFFIX(cblas_dgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, else if ( TransB == CblasNoTrans ) TA='N'; else { - API_SUFFIX(cblas_xerbla)(4, "cblas_dgemmt","Illegal TransB setting, %d\n", TransB); + API_SUFFIX(cblas_xerbla)(4, "cblas_dgemmtr","Illegal TransB setting, %d\n", TransB); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; @@ -111,10 +111,10 @@ void API_SUFFIX(cblas_dgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, F77_UL = C2F_CHAR(&UL); #endif - F77_dgemmt( F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, &alpha, B, + F77_dgemmtr( F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, &alpha, B, &F77_ldb, A, &F77_lda, &beta, C, &F77_ldc); } - else API_SUFFIX(cblas_xerbla)(1, "cblas_dgemmt", "Illegal layout setting, %d\n", layout); + else API_SUFFIX(cblas_xerbla)(1, "cblas_dgemmtr", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; diff --git a/CBLAS/src/cblas_sgemmt.c b/CBLAS/src/cblas_sgemmtr.c similarity index 80% rename from CBLAS/src/cblas_sgemmt.c rename to CBLAS/src/cblas_sgemmtr.c index 89024c8998..f2f9528ee9 100644 --- a/CBLAS/src/cblas_sgemmt.c +++ b/CBLAS/src/cblas_sgemmtr.c @@ -9,7 +9,7 @@ #include "cblas.h" #include "cblas_f77.h" -void API_SUFFIX(cblas_sgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, +void API_SUFFIX(cblas_sgemmtr)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, const CBLAS_TRANSPOSE TransB, const CBLAS_INT N, const CBLAS_INT K, const float alpha, const float *A, const CBLAS_INT lda, const float *B, const CBLAS_INT ldb, @@ -43,7 +43,7 @@ void API_SUFFIX(cblas_sgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if ( Uplo == CblasUpper ) UL = 'U'; else if (Uplo == CblasLower) UL= 'L'; else { - API_SUFFIX(cblas_xerbla)(2, "cblas_sgemmt", "Illegal Uplo setting, %d\n", Uplo); + API_SUFFIX(cblas_xerbla)(2, "cblas_sgemmtr", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; @@ -57,7 +57,7 @@ void API_SUFFIX(cblas_sgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, else if ( TransA == CblasNoTrans ) TA='N'; else { - API_SUFFIX(cblas_xerbla)(3, "cblas_sgemmt", + API_SUFFIX(cblas_xerbla)(3, "cblas_sgemmtr", "Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; RowMajorStrg = 0; @@ -69,7 +69,7 @@ void API_SUFFIX(cblas_sgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, else if ( TransB == CblasNoTrans ) TB='N'; else { - API_SUFFIX(cblas_xerbla)(4, "cblas_sgemmt", + API_SUFFIX(cblas_xerbla)(4, "cblas_sgemmtr", "Illegal TransB setting, %d\n", TransB); CBLAS_CallFromC = 0; RowMajorStrg = 0; @@ -82,7 +82,7 @@ void API_SUFFIX(cblas_sgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, F77_UL = C2F_CHAR(&UL); #endif - F77_sgemmt(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, &alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); + F77_sgemmtr(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, &alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); } else if (layout == CblasRowMajor) { RowMajorStrg = 1; @@ -91,7 +91,7 @@ void API_SUFFIX(cblas_sgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, else if ( TransA == CblasNoTrans ) TB='N'; else { - API_SUFFIX(cblas_xerbla)(3, "cblas_sgemmt", + API_SUFFIX(cblas_xerbla)(3, "cblas_sgemmtr", "Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; RowMajorStrg = 0; @@ -102,7 +102,7 @@ void API_SUFFIX(cblas_sgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, else if ( TransB == CblasNoTrans ) TA='N'; else { - API_SUFFIX(cblas_xerbla)(4, "cblas_sgemmt", + API_SUFFIX(cblas_xerbla)(4, "cblas_sgemmtr", "Illegal TransB setting, %d\n", TransB); CBLAS_CallFromC = 0; RowMajorStrg = 0; @@ -114,9 +114,9 @@ void API_SUFFIX(cblas_sgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, F77_UL = C2F_CHAR(&UL); #endif - F77_sgemmt(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, &alpha, B, &F77_ldb, A, &F77_lda, &beta, C, &F77_ldc); + F77_sgemmtr(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, &alpha, B, &F77_ldb, A, &F77_lda, &beta, C, &F77_ldc); } else - API_SUFFIX(cblas_xerbla)(1, "cblas_sgemmt", + API_SUFFIX(cblas_xerbla)(1, "cblas_sgemmtr", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; diff --git a/CBLAS/src/cblas_zgemmt.c b/CBLAS/src/cblas_zgemmtr.c similarity index 76% rename from CBLAS/src/cblas_zgemmt.c rename to CBLAS/src/cblas_zgemmtr.c index 1bfe59e33c..c01ecb2d1d 100644 --- a/CBLAS/src/cblas_zgemmt.c +++ b/CBLAS/src/cblas_zgemmtr.c @@ -9,7 +9,7 @@ #include "cblas.h" #include "cblas_f77.h" -void API_SUFFIX(cblas_zgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, +void API_SUFFIX(cblas_zgemmtr)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, const CBLAS_TRANSPOSE TransB, const CBLAS_INT N, const CBLAS_INT K, const void *alpha, const void *A, const CBLAS_INT lda, const void *B, const CBLAS_INT ldb, @@ -43,7 +43,7 @@ void API_SUFFIX(cblas_zgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, if ( Uplo == CblasUpper ) UL = 'U'; else if (Uplo == CblasLower) UL= 'L'; else { - API_SUFFIX(cblas_xerbla)(2, "cblas_zgemmt", "Illegal Uplo setting, %d\n", Uplo); + API_SUFFIX(cblas_xerbla)(2, "cblas_zgemmtr", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; @@ -57,7 +57,7 @@ void API_SUFFIX(cblas_zgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, else if ( TransA == CblasNoTrans ) TA='N'; else { - API_SUFFIX(cblas_xerbla)(3, "cblas_zgemmt","Illegal TransA setting, %d\n", TransA); + API_SUFFIX(cblas_xerbla)(3, "cblas_zgemmtr","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; @@ -68,7 +68,7 @@ void API_SUFFIX(cblas_zgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, else if ( TransB == CblasNoTrans ) TB='N'; else { - API_SUFFIX(cblas_xerbla)(4, "cblas_zgemmt","Illegal TransB setting, %d\n", TransB); + API_SUFFIX(cblas_xerbla)(4, "cblas_zgemmtr","Illegal TransB setting, %d\n", TransB); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; @@ -80,7 +80,7 @@ void API_SUFFIX(cblas_zgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, F77_UL = C2F_CHAR(&UL); #endif - F77_zgemmt(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, alpha, A, + F77_zgemmtr(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, alpha, A, &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); } else if (layout == CblasRowMajor) { @@ -90,7 +90,7 @@ void API_SUFFIX(cblas_zgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, else if ( TransA == CblasNoTrans ) TB='N'; else { - API_SUFFIX(cblas_xerbla)(3, "cblas_zgemmt","Illegal TransA setting, %d\n", TransA); + API_SUFFIX(cblas_xerbla)(3, "cblas_zgemmtr","Illegal TransA setting, %d\n", TransA); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; @@ -100,7 +100,7 @@ void API_SUFFIX(cblas_zgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, else if ( TransB == CblasNoTrans ) TA='N'; else { - API_SUFFIX(cblas_xerbla)(4, "cblas_zgemmt","Illegal TransB setting, %d\n", TransB); + API_SUFFIX(cblas_xerbla)(4, "cblas_zgemmtr","Illegal TransB setting, %d\n", TransB); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; @@ -111,10 +111,10 @@ void API_SUFFIX(cblas_zgemmt)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, F77_UL = C2F_CHAR(&UL); #endif - F77_zgemmt(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, alpha, B, + F77_zgemmtr(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, alpha, B, &F77_ldb, A, &F77_lda, beta, C, &F77_ldc); } - else API_SUFFIX(cblas_xerbla)(1, "cblas_zgemmt", "Illegal layout setting, %d\n", layout); + else API_SUFFIX(cblas_xerbla)(1, "cblas_zgemmtr", "Illegal layout setting, %d\n", layout); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; diff --git a/CBLAS/testing/c_c3chke.c b/CBLAS/testing/c_c3chke.c index 6cbfcdd97d..d9d2e12158 100644 --- a/CBLAS/testing/c_c3chke.c +++ b/CBLAS/testing/c_c3chke.c @@ -282,8 +282,8 @@ void F77_c3chke(char * rout cblas_cgemm( CblasRowMajor, CblasTrans, CblasTrans, 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); - } else if (strncmp( sf,"cblas_cgemmt" ,12)==0) { - cblas_rout = "cblas_cgemmt" ; + } else if (strncmp( sf,"cblas_cgemmtr" ,12)==0) { + cblas_rout = "cblas_cgemmtr" ; cblas_info = 1; cblas_cgemm( INVALID, CblasNoTrans, CblasNoTrans, 0, 0, 0, diff --git a/CBLAS/testing/c_cblas3.c b/CBLAS/testing/c_cblas3.c index eb07aaa1c5..ae5f3936b2 100644 --- a/CBLAS/testing/c_cblas3.c +++ b/CBLAS/testing/c_cblas3.c @@ -92,7 +92,7 @@ void F77_cgemm(CBLAS_INT *layout, char *transpa, char *transpb, CBLAS_INT *m, CB b, *ldb, beta, c, *ldc ); } -void F77_cgemmt(CBLAS_INT *layout, char *uplop, char *transpa, char *transpb, CBLAS_INT *n, +void F77_cgemmtr(CBLAS_INT *layout, char *uplop, char *transpa, char *transpb, CBLAS_INT *n, CBLAS_INT *k, CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, CBLAS_INT *lda, CBLAS_TEST_COMPLEX *b, CBLAS_INT *ldb, CBLAS_TEST_COMPLEX *beta, CBLAS_TEST_COMPLEX *c, CBLAS_INT *ldc ) { @@ -152,7 +152,7 @@ void F77_cgemmt(CBLAS_INT *layout, char *uplop, char *transpa, char *transpb, CB C[i*LDC+j].real=c[j*(*ldc)+i].real; C[i*LDC+j].imag=c[j*(*ldc)+i].imag; } - cblas_cgemmt( CblasRowMajor, uplo, transa, transb, *n, *k, alpha, A, LDA, + 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++ ) { @@ -164,10 +164,10 @@ void F77_cgemmt(CBLAS_INT *layout, char *uplop, char *transpa, char *transpb, CB free(C); } else if (*layout == TEST_COL_MJR) - cblas_cgemmt( CblasColMajor, uplo, transa, transb, *n, *k, alpha, a, *lda, + cblas_cgemmtr( CblasColMajor, uplo, transa, transb, *n, *k, alpha, a, *lda, b, *ldb, beta, c, *ldc ); else - cblas_cgemmt( UNDEFINED, uplo, transa, transb, *n, *k, alpha, a, *lda, + cblas_cgemmtr( UNDEFINED, uplo, transa, transb, *n, *k, alpha, a, *lda, b, *ldb, beta, c, *ldc ); } diff --git a/CBLAS/testing/c_cblat3.f b/CBLAS/testing/c_cblat3.f index eb4e1124ba..88a077350a 100644 --- a/CBLAS/testing/c_cblat3.f +++ b/CBLAS/testing/c_cblat3.f @@ -29,7 +29,7 @@ PROGRAM CBLAT3 * 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_cgemmt T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_cgemmtr T PUT F FOR NO TEST. SAME COLUMNS. * * See: * @@ -98,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_cgemmt' / + $ 'cblas_csyr2k', 'cblas_cgemmtr' / * .. Executable Statements .. * NOUTC = NOUT @@ -367,7 +367,7 @@ PROGRAM CBLAT3 $ 1 ) END IF GO TO 190 -* Test CGEMMT, 10. +* Test CGEMMTR, 10. 185 IF (CORDER) THEN CALL CCHK6(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, @@ -2808,7 +2808,7 @@ SUBROUTINE CCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ IORDER ) IMPLICIT NONE * -* Tests CGEMMT. +* Tests CGEMMTR. * * Auxiliary routine for test program for Level 3 Blas. * @@ -2981,7 +2981,7 @@ SUBROUTINE CCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ LDB, BETA, LDC) IF( REWI ) $ REWIND NTRA - CALL CCGEMMT(IORDER, UPLO, TRANSA, TRANSB, N, + CALL CCGEMMTR(IORDER, UPLO, TRANSA, TRANSB, N, $ K, ALPHA, AA, LDA, BB, LDB, $ BETA, CC, LDC ) * diff --git a/CBLAS/testing/cin3 b/CBLAS/testing/cin3 index 3854aef885..093bf8e26a 100644 --- a/CBLAS/testing/cin3 +++ b/CBLAS/testing/cin3 @@ -20,4 +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_cgemmt T PUT F FOR NO TEST. SAME COLUMNS. +cblas_cgemmtr T PUT F FOR NO TEST. SAME COLUMNS. From cb81e003b8a9defe2dbae8f1783143488914130b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20K=C3=B6hler?= Date: Fri, 21 Jun 2024 12:37:09 +0200 Subject: [PATCH 13/23] Adjust BLAS test for routine names with at most 7 characters --- BLAS/TESTING/cblat3.f | 84 ++++++++++++++++----------- BLAS/TESTING/cblat3.in | 18 +++--- BLAS/TESTING/dblat3.f | 57 +++++++++++-------- BLAS/TESTING/dblat3.in | 12 ++-- BLAS/TESTING/sblat3.f | 125 ++++++++++++++++++++++------------------- BLAS/TESTING/sblat3.in | 12 ++-- BLAS/TESTING/zblat3.f | 84 ++++++++++++++++----------- BLAS/TESTING/zblat3.in | 18 +++--- 8 files changed, 232 insertions(+), 178 deletions(-) diff --git a/BLAS/TESTING/cblat3.f b/BLAS/TESTING/cblat3.f index 3d9ed49d52..294fba674c 100644 --- a/BLAS/TESTING/cblat3.f +++ b/BLAS/TESTING/cblat3.f @@ -109,7 +109,7 @@ PROGRAM CBLAT3 LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, $ TSTERR CHARACTER*1 TRANSA, TRANSB - CHARACTER*6 SNAMET + CHARACTER*7 SNAMET CHARACTER*32 SNAPS, SUMMRY * .. Local Arrays .. COMPLEX AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ), @@ -121,7 +121,7 @@ PROGRAM CBLAT3 REAL G( NMAX ) INTEGER IDIM( NIDMAX ) LOGICAL LTEST( NSUBS ) - CHARACTER*6 SNAMES( NSUBS ) + CHARACTER*7 SNAMES( NSUBS ) * .. External Functions .. REAL SDIFF LOGICAL LCE @@ -134,7 +134,7 @@ PROGRAM CBLAT3 * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK - CHARACTER*6 SRNAMT + CHARACTER*7 SRNAMT * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR COMMON /SRNAMC/SRNAMT @@ -397,8 +397,8 @@ PROGRAM CBLAT3 $ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ', $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ', $ '*******' ) - 9988 FORMAT( A6, L2 ) - 9987 FORMAT( 1X, A6, ' WAS NOT TESTED' ) + 9988 FORMAT( A7, L2 ) + 9987 FORMAT( 1X, A7, ' WAS NOT TESTED' ) 9986 FORMAT( /' END OF TESTS' ) 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) @@ -429,7 +429,7 @@ SUBROUTINE CCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, REAL EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*7 SNAME * .. Array Arguments .. COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), @@ -714,7 +714,7 @@ SUBROUTINE CCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, REAL EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*7 SNAME * .. Array Arguments .. COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), @@ -993,7 +993,7 @@ SUBROUTINE CCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, REAL EPS, THRESH INTEGER NALF, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*7 SNAME * .. Array Arguments .. COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), @@ -1303,7 +1303,7 @@ SUBROUTINE CCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, REAL EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*7 SNAME * .. Array Arguments .. COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), @@ -1635,7 +1635,7 @@ SUBROUTINE CCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, REAL EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*7 SNAME * .. Array Arguments .. COMPLEX AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ), $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ), @@ -2005,7 +2005,7 @@ SUBROUTINE CCHKE( ISNUM, SRNAMT, NOUT ) * * .. Scalar Arguments .. INTEGER ISNUM, NOUT - CHARACTER*6 SRNAMT + CHARACTER*7 SRNAMT * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK @@ -2969,58 +2969,76 @@ SUBROUTINE CCHKE( ISNUM, SRNAMT, NOUT ) CALL CGEMMTR( 'U', 'T', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL CGEMMTR( 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL CGEMMTR( 'U', 'N', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'N', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL CGEMMTR( 'U', 'N', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'N', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL CGEMMTR( 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL CGEMMTR( 'U', 'C', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'C', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL CGEMMTR( 'U', 'C', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'C', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL CGEMMTR( 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL CGEMMTR( 'U', 'T', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'T', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL CGEMMTR( 'U', 'T', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'T', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL CGEMMTR( 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL CGEMMTR( 'U', 'N', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'N', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL CGEMMTR( 'U', 'N', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'N', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL CGEMMTR( 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL CGEMMTR( 'U', 'C', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'C', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL CGEMMTR( 'U', 'C', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'C', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL CGEMMTR( 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL CGEMMTR( 'U', 'T', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'T', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL CGEMMTR( 'U', 'T', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CGEMMTR( 'U', 'T', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 @@ -3601,7 +3619,7 @@ SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) * .. Scalar Arguments .. INTEGER INFOT, NOUT LOGICAL LERR, OK - CHARACTER*6 SRNAMT + CHARACTER*7 SRNAMT * .. Executable Statements .. IF( .NOT.LERR )THEN WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT @@ -3637,11 +3655,11 @@ SUBROUTINE XERBLA( SRNAME, INFO ) * * .. Scalar Arguments .. INTEGER INFO - CHARACTER*6 SRNAME + CHARACTER*(*) SRNAME * .. Scalars in Common .. INTEGER INFOT, NOUT LOGICAL LERR, OK - CHARACTER*6 SRNAMT + CHARACTER*7 SRNAMT * .. Common blocks .. COMMON /INFOC/INFOT, NOUT, OK, LERR COMMON /SRNAMC/SRNAMT @@ -3695,7 +3713,7 @@ SUBROUTINE CCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, REAL EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*7 SNAME * .. Array Arguments .. COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), diff --git a/BLAS/TESTING/cblat3.in b/BLAS/TESTING/cblat3.in index a98873cfc7..701180f550 100644 --- a/BLAS/TESTING/cblat3.in +++ b/BLAS/TESTING/cblat3.in @@ -12,13 +12,13 @@ T LOGICAL FLAG, T TO TEST ERROR EXITS. (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 -CGEMM T PUT F FOR NO TEST. SAME COLUMNS. -CHEMM T PUT F FOR NO TEST. SAME COLUMNS. -CSYMM T PUT F FOR NO TEST. SAME COLUMNS. -CTRMM T PUT F FOR NO TEST. SAME COLUMNS. -CTRSM T PUT F FOR NO TEST. SAME COLUMNS. -CHERK T PUT F FOR NO TEST. SAME COLUMNS. -CSYRK T PUT F FOR NO TEST. SAME COLUMNS. -CHER2K T PUT F FOR NO TEST. SAME COLUMNS. -CSYR2K T PUT F FOR NO TEST. SAME COLUMNS. +CGEMM T PUT F FOR NO TEST. SAME COLUMNS. +CHEMM T PUT F FOR NO TEST. SAME COLUMNS. +CSYMM T PUT F FOR NO TEST. SAME COLUMNS. +CTRMM T PUT F FOR NO TEST. SAME COLUMNS. +CTRSM T PUT F FOR NO TEST. SAME COLUMNS. +CHERK T PUT F FOR NO TEST. SAME COLUMNS. +CSYRK T PUT F FOR NO TEST. SAME COLUMNS. +CHER2K T PUT F FOR NO TEST. SAME COLUMNS. +CSYR2K T PUT F FOR NO TEST. SAME COLUMNS. CGEMMTR T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/BLAS/TESTING/dblat3.f b/BLAS/TESTING/dblat3.f index 011cf5f45a..e45a1f91da 100644 --- a/BLAS/TESTING/dblat3.f +++ b/BLAS/TESTING/dblat3.f @@ -104,7 +104,7 @@ PROGRAM DBLAT3 LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, $ TSTERR CHARACTER*1 TRANSA, TRANSB - CHARACTER*6 SNAMET + CHARACTER*7 SNAMET CHARACTER*32 SNAPS, SUMMRY * .. Local Arrays .. DOUBLE PRECISION AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ), @@ -115,7 +115,7 @@ PROGRAM DBLAT3 $ G( NMAX ), W( 2*NMAX ) INTEGER IDIM( NIDMAX ) LOGICAL LTEST( NSUBS ) - CHARACTER*6 SNAMES( NSUBS ) + CHARACTER*7 SNAMES( NSUBS ) * .. External Functions .. DOUBLE PRECISION DDIFF LOGICAL LDE @@ -127,7 +127,7 @@ PROGRAM DBLAT3 * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK - CHARACTER*6 SRNAMT + CHARACTER*7 SRNAMT * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR COMMON /SRNAMC/SRNAMT @@ -387,8 +387,8 @@ PROGRAM DBLAT3 $ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ', $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ', $ '*******' ) - 9988 FORMAT( A6, L2 ) - 9987 FORMAT( 1X, A6, ' WAS NOT TESTED' ) + 9988 FORMAT( A7, L2 ) + 9987 FORMAT( 1X, A7, ' WAS NOT TESTED' ) 9986 FORMAT( /' END OF TESTS' ) 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) @@ -417,7 +417,7 @@ SUBROUTINE DCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DOUBLE PRECISION EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*7 SNAME * .. Array Arguments .. DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), @@ -698,7 +698,7 @@ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DOUBLE PRECISION EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*7 SNAME * .. Array Arguments .. DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), @@ -968,7 +968,7 @@ SUBROUTINE DCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DOUBLE PRECISION EPS, THRESH INTEGER NALF, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*7 SNAME * .. Array Arguments .. DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), @@ -1273,7 +1273,7 @@ SUBROUTINE DCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DOUBLE PRECISION EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*7 SNAME * .. Array Arguments .. DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), @@ -1548,7 +1548,7 @@ SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DOUBLE PRECISION EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*7 SNAME * .. Array Arguments .. DOUBLE PRECISION AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ), $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ), @@ -1860,7 +1860,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) * * .. Scalar Arguments .. INTEGER ISNUM, NOUT - CHARACTER*6 SRNAMT + CHARACTER*7 SRNAMT * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK @@ -2398,31 +2398,40 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) CALL DGEMMTR( 'U', 'T', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL DGEMMTR( 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL DGEMMTR( 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL DGEMMTR( 'U', 'N', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL DGEMMTR( 'U', 'N', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL DGEMMTR( 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL DGEMMTR( 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL DGEMMTR( 'U', 'T', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL DGEMMTR( 'U', 'T', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL DGEMMTR( 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL DGEMMTR( 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL DGEMMTR( 'U', 'N', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL DGEMMTR( 'U', 'N', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL DGEMMTR( 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL DGEMMTR( 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL DGEMMTR( 'U', 'T', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL DGEMMTR( 'U', 'T', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL DGEMMTR( 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) + CALL DGEMMTR( 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2, BETA, C, + $ 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 CALL DGEMMTR( 'U', 'N', 'T', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) @@ -2874,7 +2883,7 @@ SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) * .. Scalar Arguments .. INTEGER INFOT, NOUT LOGICAL LERR, OK - CHARACTER*6 SRNAMT + CHARACTER*7 SRNAMT * .. Executable Statements .. IF( .NOT.LERR )THEN WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT @@ -2910,11 +2919,11 @@ SUBROUTINE XERBLA( SRNAME, INFO ) * * .. Scalar Arguments .. INTEGER INFO - CHARACTER*6 SRNAME + CHARACTER*(*) SRNAME * .. Scalars in Common .. INTEGER INFOT, NOUT LOGICAL LERR, OK - CHARACTER*6 SRNAMT + CHARACTER*7 SRNAMT * .. Common blocks .. COMMON /INFOC/INFOT, NOUT, OK, LERR COMMON /SRNAMC/SRNAMT @@ -2963,7 +2972,7 @@ SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DOUBLE PRECISION EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*7 SNAME * .. Array Arguments .. DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), diff --git a/BLAS/TESTING/dblat3.in b/BLAS/TESTING/dblat3.in index 839163fa45..30b74c6e40 100644 --- a/BLAS/TESTING/dblat3.in +++ b/BLAS/TESTING/dblat3.in @@ -12,10 +12,10 @@ T LOGICAL FLAG, T TO TEST ERROR EXITS. 0.0 1.0 0.7 VALUES OF ALPHA 3 NUMBER OF VALUES OF BETA 0.0 1.0 1.3 VALUES OF BETA -DGEMM T PUT F FOR NO TEST. SAME COLUMNS. -DSYMM T PUT F FOR NO TEST. SAME COLUMNS. -DTRMM T PUT F FOR NO TEST. SAME COLUMNS. -DTRSM T PUT F FOR NO TEST. SAME COLUMNS. -DSYRK T PUT F FOR NO TEST. SAME COLUMNS. -DSYR2K T PUT F FOR NO TEST. SAME COLUMNS. +DGEMM T PUT F FOR NO TEST. SAME COLUMNS. +DSYMM T PUT F FOR NO TEST. SAME COLUMNS. +DTRMM T PUT F FOR NO TEST. SAME COLUMNS. +DTRSM T PUT F FOR NO TEST. SAME COLUMNS. +DSYRK T PUT F FOR NO TEST. SAME COLUMNS. +DSYR2K T PUT F FOR NO TEST. SAME COLUMNS. DGEMMTR T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/BLAS/TESTING/sblat3.f b/BLAS/TESTING/sblat3.f index 94a1961dab..d5c2aa7edb 100644 --- a/BLAS/TESTING/sblat3.f +++ b/BLAS/TESTING/sblat3.f @@ -20,7 +20,7 @@ *> *> The program must be driven by a short data file. The first 14 records *> of the file are read using list-directed input, the last 7 records -*> are read using the format ( A6, L2 ). An annotated example of a data +*> are read using the format ( A7, L2 ). An annotated example of a data *> file can be obtained by deleting the first 3 characters from the *> following 20 lines: *> 'sblat3.out' NAME OF SUMMARY OUTPUT FILE @@ -104,7 +104,7 @@ PROGRAM SBLAT3 LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, $ TSTERR CHARACTER*1 TRANSA, TRANSB - CHARACTER*6 SNAMET + CHARACTER*7 SNAMET CHARACTER*32 SNAPS, SUMMRY * .. Local Arrays .. REAL AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ), @@ -115,7 +115,7 @@ PROGRAM SBLAT3 $ G( NMAX ), W( 2*NMAX ) INTEGER IDIM( NIDMAX ) LOGICAL LTEST( NSUBS ) - CHARACTER*6 SNAMES( NSUBS ) + CHARACTER*7 SNAMES( NSUBS ) * .. External Functions .. REAL SDIFF LOGICAL LSE @@ -127,13 +127,13 @@ PROGRAM SBLAT3 * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK - CHARACTER*6 SRNAMT + CHARACTER*7 SRNAMT * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR COMMON /SRNAMC/SRNAMT * .. Data statements .. - DATA SNAMES/'SGEMM ', 'SSYMM ', 'STRMM ', 'STRSM ', - $ 'SSYRK ', 'SSYR2K', 'SGEMMTR'/ + DATA SNAMES/'SGEMM', 'SSYMM ', 'STRMM ', + $ 'STRSM ', 'SSYRK ', 'SSYR2K ', 'SGEMMTR'/ * .. Executable Statements .. * * Read name and unit number for summary output file and open file. @@ -379,7 +379,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 ', A6, ' NOT RECOGNIZED', /' ******* T', + 9990 FORMAT( ' SUBPROGRAM NAME ', A7, ' NOT RECOGNIZED', /' ******* T', $ 'ESTS ABANDONED *******' ) 9989 FORMAT( ' ERROR IN SMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', $ 'ATED WRONGLY.', /' SMMCH WAS CALLED WITH TRANSA = ', A1, @@ -387,8 +387,8 @@ PROGRAM SBLAT3 $ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ', $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ', $ '*******' ) - 9988 FORMAT( A6, L2 ) - 9987 FORMAT( 1X, A6, ' WAS NOT TESTED' ) + 9988 FORMAT( A7, L2 ) + 9987 FORMAT( 1X, A7, ' WAS NOT TESTED' ) 9986 FORMAT( /' END OF TESTS' ) 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) @@ -417,7 +417,7 @@ SUBROUTINE SCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, REAL EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*7 SNAME * .. Array Arguments .. REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), @@ -660,15 +660,15 @@ SUBROUTINE SCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 130 CONTINUE RETURN * - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A7, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A7, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',''', A1, ''',', + 9996 FORMAT( ' ******* ', A7, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A7, '(''', A1, ''',''', A1, ''',', $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ', $ 'C,', I3, ').' ) 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', @@ -698,7 +698,7 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, REAL EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*7 SNAME * .. Array Arguments .. REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), @@ -930,15 +930,15 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 120 CONTINUE RETURN * - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A7, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A7, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), + 9996 FORMAT( ' ******* ', A7, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A7, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', $ ' .' ) 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', @@ -968,7 +968,7 @@ SUBROUTINE SCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, REAL EPS, THRESH INTEGER NALF, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*7 SNAME * .. Array Arguments .. REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), @@ -1236,15 +1236,15 @@ SUBROUTINE SCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 160 CONTINUE RETURN * - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A7, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A7, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(', 4( '''', A1, ''',' ), 2( I3, ',' ), + 9996 FORMAT( ' ******* ', A7, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A7, '(', 4( '''', A1, ''',' ), 2( I3, ',' ), $ F4.1, ', A,', I3, ', B,', I3, ') .' ) 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) @@ -1273,7 +1273,7 @@ SUBROUTINE SCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, REAL EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*7 SNAME * .. Array Arguments .. REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), @@ -1510,16 +1510,16 @@ SUBROUTINE SCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 130 CONTINUE RETURN * - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A7, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A7, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) + 9996 FORMAT( ' ******* ', A7, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), + 9994 FORMAT( 1X, I6, ': ', A7, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' ) 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) @@ -1548,7 +1548,7 @@ SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, REAL EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*7 SNAME * .. Array Arguments .. REAL AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ), $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ), @@ -1823,16 +1823,16 @@ SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 160 CONTINUE RETURN * - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A7, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A7, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) + 9996 FORMAT( ' ******* ', A7, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), + 9994 FORMAT( 1X, I6, ': ', A7, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', $ ' .' ) 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', @@ -1860,7 +1860,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) * * .. Scalar Arguments .. INTEGER ISNUM, NOUT - CHARACTER*6 SRNAMT + CHARACTER*7 SRNAMT * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK @@ -2398,31 +2398,40 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) CALL SGEMMTR( 'U', 'T', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL SGEMMTR( 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL SGEMMTR( 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL SGEMMTR( 'U', 'N', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL SGEMMTR( 'U', 'N', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL SGEMMTR( 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL SGEMMTR( 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL SGEMMTR( 'U', 'T', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL SGEMMTR( 'U', 'T', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL SGEMMTR( 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL SGEMMTR( 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL SGEMMTR( 'U', 'N', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL SGEMMTR( 'U', 'N', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL SGEMMTR( 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL SGEMMTR( 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL SGEMMTR( 'U', 'T', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL SGEMMTR( 'U', 'T', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 - CALL SGEMMTR( 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) + CALL SGEMMTR( 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2, BETA, C, + $ 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 CALL SGEMMTR( 'U', 'N', 'T', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) @@ -2459,8 +2468,8 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) END IF RETURN * - 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) - 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', + 9999 FORMAT( ' ', A7, ' PASSED THE TESTS OF ERROR-EXITS' ) + 9998 FORMAT( ' ******* ', A7, ' FAILED THE TESTS OF ERROR-EXITS *****', $ '**' ) * * End of SCHKE @@ -2874,7 +2883,7 @@ SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) * .. Scalar Arguments .. INTEGER INFOT, NOUT LOGICAL LERR, OK - CHARACTER*6 SRNAMT + CHARACTER*7 SRNAMT * .. Executable Statements .. IF( .NOT.LERR )THEN WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT @@ -2884,7 +2893,7 @@ SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) RETURN * 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', - $ 'ETECTED BY ', A6, ' *****' ) + $ 'ETECTED BY ', A7, ' *****' ) * * End of CHKXER * @@ -2910,11 +2919,11 @@ SUBROUTINE XERBLA( SRNAME, INFO ) * * .. Scalar Arguments .. INTEGER INFO - CHARACTER*6 SRNAME + CHARACTER*(*) SRNAME * .. Scalars in Common .. INTEGER INFOT, NOUT LOGICAL LERR, OK - CHARACTER*6 SRNAMT + CHARACTER*7 SRNAMT * .. Common blocks .. COMMON /INFOC/INFOT, NOUT, OK, LERR COMMON /SRNAMC/SRNAMT @@ -2928,7 +2937,7 @@ SUBROUTINE XERBLA( SRNAME, INFO ) END IF OK = .FALSE. END IF - IF( SRNAME.NE.SRNAMT )THEN + IF( SRNAME .NE. SRNAME ) THEN WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT OK = .FALSE. END IF @@ -2936,8 +2945,8 @@ SUBROUTINE XERBLA( SRNAME, INFO ) * 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD', $ ' OF ', I2, ' *******' ) - 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE', - $ 'AD OF ', A6, ' *******' ) + 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A7, ' INSTE', + $ 'AD OF ', A7, ' *******' ) 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, $ ' *******' ) * @@ -2964,7 +2973,7 @@ SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, REAL EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*7 SNAME * .. Array Arguments .. REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), @@ -3213,15 +3222,15 @@ SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 130 CONTINUE RETURN * - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A7, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A7, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''',A1, ''',''',A1, ''',''', A1,''',', + 9996 FORMAT( ' ******* ', A7, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A7, '(''',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 *', diff --git a/BLAS/TESTING/sblat3.in b/BLAS/TESTING/sblat3.in index 2013046003..ea1a305875 100644 --- a/BLAS/TESTING/sblat3.in +++ b/BLAS/TESTING/sblat3.in @@ -12,10 +12,10 @@ T LOGICAL FLAG, T TO TEST ERROR EXITS. 0.0 1.0 0.7 VALUES OF ALPHA 3 NUMBER OF VALUES OF BETA 0.0 1.0 1.3 VALUES OF BETA -SGEMM T PUT F FOR NO TEST. SAME COLUMNS. -SSYMM T PUT F FOR NO TEST. SAME COLUMNS. -STRMM T PUT F FOR NO TEST. SAME COLUMNS. -STRSM T PUT F FOR NO TEST. SAME COLUMNS. -SSYRK T PUT F FOR NO TEST. SAME COLUMNS. -SSYR2K T PUT F FOR NO TEST. SAME COLUMNS. +SGEMM T PUT F FOR NO TEST. SAME COLUMNS. +SSYMM T PUT F FOR NO TEST. SAME COLUMNS. +STRMM T PUT F FOR NO TEST. SAME COLUMNS. +STRSM T PUT F FOR NO TEST. SAME COLUMNS. +SSYRK T PUT F FOR NO TEST. SAME COLUMNS. +SSYR2K T PUT F FOR NO TEST. SAME COLUMNS. SGEMMTR T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/BLAS/TESTING/zblat3.f b/BLAS/TESTING/zblat3.f index a2b85ce961..06cc23aa68 100644 --- a/BLAS/TESTING/zblat3.f +++ b/BLAS/TESTING/zblat3.f @@ -111,7 +111,7 @@ PROGRAM ZBLAT3 LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, $ TSTERR CHARACTER*1 TRANSA, TRANSB - CHARACTER*6 SNAMET + CHARACTER*7 SNAMET CHARACTER*32 SNAPS, SUMMRY * .. Local Arrays .. COMPLEX*16 AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ), @@ -123,7 +123,7 @@ PROGRAM ZBLAT3 DOUBLE PRECISION G( NMAX ) INTEGER IDIM( NIDMAX ) LOGICAL LTEST( NSUBS ) - CHARACTER*6 SNAMES( NSUBS ) + CHARACTER*7 SNAMES( NSUBS ) * .. External Functions .. DOUBLE PRECISION DDIFF LOGICAL LZE @@ -136,7 +136,7 @@ PROGRAM ZBLAT3 * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK - CHARACTER*6 SRNAMT + CHARACTER*7 SRNAMT * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR COMMON /SRNAMC/SRNAMT @@ -401,8 +401,8 @@ PROGRAM ZBLAT3 $ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ', $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ', $ '*******' ) - 9988 FORMAT( A6, L2 ) - 9987 FORMAT( 1X, A6, ' WAS NOT TESTED' ) + 9988 FORMAT( A7, L2 ) + 9987 FORMAT( 1X, A7, ' WAS NOT TESTED' ) 9986 FORMAT( /' END OF TESTS' ) 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) @@ -433,7 +433,7 @@ SUBROUTINE ZCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DOUBLE PRECISION EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*7 SNAME * .. Array Arguments .. COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), @@ -718,7 +718,7 @@ SUBROUTINE ZCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DOUBLE PRECISION EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*7 SNAME * .. Array Arguments .. COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), @@ -998,7 +998,7 @@ SUBROUTINE ZCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DOUBLE PRECISION EPS, THRESH INTEGER NALF, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*7 SNAME * .. Array Arguments .. COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), @@ -1308,7 +1308,7 @@ SUBROUTINE ZCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DOUBLE PRECISION EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*7 SNAME * .. Array Arguments .. COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), @@ -1641,7 +1641,7 @@ SUBROUTINE ZCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DOUBLE PRECISION EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*7 SNAME * .. Array Arguments .. COMPLEX*16 AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ), $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ), @@ -2012,7 +2012,7 @@ SUBROUTINE ZCHKE( ISNUM, SRNAMT, NOUT ) * * .. Scalar Arguments .. INTEGER ISNUM, NOUT - CHARACTER*6 SRNAMT + CHARACTER*7 SRNAMT * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK @@ -2978,58 +2978,76 @@ SUBROUTINE ZCHKE( ISNUM, SRNAMT, NOUT ) CALL ZGEMMTR( 'U', 'T', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL ZGEMMTR( 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL ZGEMMTR( 'U', 'N', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'N', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL ZGEMMTR( 'U', 'N', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'N', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL ZGEMMTR( 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL ZGEMMTR( 'U', 'C', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'C', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL ZGEMMTR( 'U', 'C', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'C', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL ZGEMMTR( 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL ZGEMMTR( 'U', 'T', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'T', 'C', -1, 0, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL ZGEMMTR( 'U', 'T', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'T', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL ZGEMMTR( 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL ZGEMMTR( 'U', 'N', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'N', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL ZGEMMTR( 'U', 'N', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'N', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL ZGEMMTR( 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL ZGEMMTR( 'U', 'C', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'C', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL ZGEMMTR( 'U', 'C', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'C', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL ZGEMMTR( 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL ZGEMMTR( 'U', 'T', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'T', 'C', 0, -1, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 - CALL ZGEMMTR( 'U', 'T', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL ZGEMMTR( 'U', 'T', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, + $ 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 @@ -3613,7 +3631,7 @@ SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) * .. Scalar Arguments .. INTEGER INFOT, NOUT LOGICAL LERR, OK - CHARACTER*6 SRNAMT + CHARACTER*7 SRNAMT * .. Executable Statements .. IF( .NOT.LERR )THEN WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT @@ -3649,11 +3667,11 @@ SUBROUTINE XERBLA( SRNAME, INFO ) * * .. Scalar Arguments .. INTEGER INFO - CHARACTER*6 SRNAME + CHARACTER*(*) SRNAME * .. Scalars in Common .. INTEGER INFOT, NOUT LOGICAL LERR, OK - CHARACTER*6 SRNAMT + CHARACTER*7 SRNAMT * .. Common blocks .. COMMON /INFOC/INFOT, NOUT, OK, LERR COMMON /SRNAMC/SRNAMT @@ -3709,7 +3727,7 @@ SUBROUTINE ZCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DOUBLE PRECISION EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*7 SNAME * .. Array Arguments .. COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), diff --git a/BLAS/TESTING/zblat3.in b/BLAS/TESTING/zblat3.in index 6160d7af99..7768859c11 100644 --- a/BLAS/TESTING/zblat3.in +++ b/BLAS/TESTING/zblat3.in @@ -12,13 +12,13 @@ T LOGICAL FLAG, T TO TEST ERROR EXITS. (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. +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. ZGEMMTR T PUT F FOR NO TEST. SAME COLUMNS. From f9ea71ef3d10b19d654415e8b62c2a1ed02e3c5e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20K=C3=B6hler?= Date: Fri, 21 Jun 2024 13:14:37 +0200 Subject: [PATCH 14/23] Fix missing arguments in tests --- CBLAS/testing/c_c2chke.c | 4 +- CBLAS/testing/c_c3chke.c | 4 +- CBLAS/testing/c_cblas2.c | 30 ++++----- CBLAS/testing/c_cblas3.c | 18 ++--- CBLAS/testing/c_cblat3.f | 138 +++++++++++++++++++-------------------- CBLAS/testing/c_d2chke.c | 4 +- CBLAS/testing/c_d3chke.c | 4 +- CBLAS/testing/c_dblas2.c | 30 ++++----- CBLAS/testing/c_dblas3.c | 12 ++-- CBLAS/testing/c_s2chke.c | 2 +- CBLAS/testing/c_s3chke.c | 4 +- CBLAS/testing/c_sblas2.c | 30 ++++----- CBLAS/testing/c_sblas3.c | 12 ++-- CBLAS/testing/c_xerbla.c | 2 +- CBLAS/testing/c_z2chke.c | 4 +- CBLAS/testing/c_z3chke.c | 4 +- CBLAS/testing/c_zblas2.c | 30 ++++----- CBLAS/testing/c_zblas3.c | 18 ++--- 18 files changed, 175 insertions(+), 175 deletions(-) diff --git a/CBLAS/testing/c_c2chke.c b/CBLAS/testing/c_c2chke.c index 8d346bd239..e0acfab1fb 100644 --- a/CBLAS/testing/c_c2chke.c +++ b/CBLAS/testing/c_c2chke.c @@ -13,7 +13,7 @@ void F77_xerbla(F77_Char F77_srname, void *vinfo void F77_xerbla(char *srname, void *vinfo #endif #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN srname_len #endif ); @@ -30,7 +30,7 @@ void chkxer(void) { void F77_c2chke(char *rout #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN rout_len #endif ) { char *sf = ( rout ) ; diff --git a/CBLAS/testing/c_c3chke.c b/CBLAS/testing/c_c3chke.c index d9d2e12158..4479469a2f 100644 --- a/CBLAS/testing/c_c3chke.c +++ b/CBLAS/testing/c_c3chke.c @@ -13,7 +13,7 @@ void F77_xerbla(F77_Char F77_srname, void *vinfo void F77_xerbla(char *srname, void *vinfo #endif #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN srname_len #endif ); @@ -30,7 +30,7 @@ void chkxer(void) { void F77_c3chke(char * rout #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN rout_len #endif ) { char *sf = ( rout ) ; diff --git a/CBLAS/testing/c_cblas2.c b/CBLAS/testing/c_cblas2.c index 1c87136743..38a089f0e2 100644 --- a/CBLAS/testing/c_cblas2.c +++ b/CBLAS/testing/c_cblas2.c @@ -13,7 +13,7 @@ void F77_cgemv(CBLAS_INT *layout, char *transp, CBLAS_INT *m, CBLAS_INT *n, CBLAS_TEST_COMPLEX *a, CBLAS_INT *lda, const void *x, CBLAS_INT *incx, const void *beta, void *y, CBLAS_INT *incy #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN transp_len #endif ) { @@ -47,7 +47,7 @@ void F77_cgbmv(CBLAS_INT *layout, char *transp, CBLAS_INT *m, CBLAS_INT *n, CBLA CBLAS_TEST_COMPLEX *x, CBLAS_INT *incx, CBLAS_TEST_COMPLEX *beta, CBLAS_TEST_COMPLEX *y, CBLAS_INT *incy #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN transp_len #endif ) { @@ -154,7 +154,7 @@ void F77_chemv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_TEST_COMPLEX CBLAS_TEST_COMPLEX *a, CBLAS_INT *lda, CBLAS_TEST_COMPLEX *x, CBLAS_INT *incx, CBLAS_TEST_COMPLEX *beta, CBLAS_TEST_COMPLEX *y, CBLAS_INT *incy #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len #endif ){ @@ -189,7 +189,7 @@ void F77_chbmv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_INT *k, CBLAS_TEST_COMPLEX *x, CBLAS_INT *incx, CBLAS_TEST_COMPLEX *beta, CBLAS_TEST_COMPLEX *y, CBLAS_INT *incy #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len #endif ){ @@ -256,7 +256,7 @@ void F77_chpmv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_TEST_COMPLEX CBLAS_TEST_COMPLEX *ap, CBLAS_TEST_COMPLEX *x, CBLAS_INT *incx, CBLAS_TEST_COMPLEX *beta, CBLAS_TEST_COMPLEX *y, CBLAS_INT *incy #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len #endif ){ @@ -316,7 +316,7 @@ void F77_ctbmv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, CBLAS_INT *n, CBLAS_INT *k, CBLAS_TEST_COMPLEX *a, CBLAS_INT *lda, CBLAS_TEST_COMPLEX *x, CBLAS_INT *incx #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { CBLAS_TEST_COMPLEX *A; @@ -383,7 +383,7 @@ void F77_ctbsv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, CBLAS_INT *n, CBLAS_INT *k, CBLAS_TEST_COMPLEX *a, CBLAS_INT *lda, CBLAS_TEST_COMPLEX *x, CBLAS_INT *incx #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { @@ -450,7 +450,7 @@ void F77_ctbsv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, void F77_ctpmv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, CBLAS_INT *n, CBLAS_TEST_COMPLEX *ap, CBLAS_TEST_COMPLEX *x, CBLAS_INT *incx #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len , FORTRAN_STRLEN diagn_len #endif ) { CBLAS_TEST_COMPLEX *A, *AP; @@ -509,7 +509,7 @@ void F77_ctpmv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, void F77_ctpsv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, CBLAS_INT *n, CBLAS_TEST_COMPLEX *ap, CBLAS_TEST_COMPLEX *x, CBLAS_INT *incx #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { CBLAS_TEST_COMPLEX *A, *AP; @@ -569,7 +569,7 @@ void F77_ctrmv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, CBLAS_INT *n, CBLAS_TEST_COMPLEX *a, CBLAS_INT *lda, CBLAS_TEST_COMPLEX *x, CBLAS_INT *incx #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { CBLAS_TEST_COMPLEX *A; @@ -602,7 +602,7 @@ void F77_ctrsv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, CBLAS_INT *n, CBLAS_TEST_COMPLEX *a, CBLAS_INT *lda, CBLAS_TEST_COMPLEX *x, CBLAS_INT *incx #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { CBLAS_TEST_COMPLEX *A; @@ -635,7 +635,7 @@ void F77_ctrsv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, void F77_chpr(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, float *alpha, CBLAS_TEST_COMPLEX *x, CBLAS_INT *incx, CBLAS_TEST_COMPLEX *ap #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len #endif ) { CBLAS_TEST_COMPLEX *A, *AP; @@ -715,7 +715,7 @@ void F77_chpr2(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_TEST_COMPLEX CBLAS_TEST_COMPLEX *x, CBLAS_INT *incx, CBLAS_TEST_COMPLEX *y, CBLAS_INT *incy, CBLAS_TEST_COMPLEX *ap #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len #endif ) { CBLAS_TEST_COMPLEX *A, *AP; @@ -795,7 +795,7 @@ void F77_chpr2(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_TEST_COMPLEX void F77_cher(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, float *alpha, CBLAS_TEST_COMPLEX *x, CBLAS_INT *incx, CBLAS_TEST_COMPLEX *a, CBLAS_INT *lda #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len #endif ) { CBLAS_TEST_COMPLEX *A; @@ -832,7 +832,7 @@ void F77_cher2(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_TEST_COMPLEX CBLAS_TEST_COMPLEX *x, CBLAS_INT *incx, CBLAS_TEST_COMPLEX *y, CBLAS_INT *incy, CBLAS_TEST_COMPLEX *a, CBLAS_INT *lda #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len #endif ) { diff --git a/CBLAS/testing/c_cblas3.c b/CBLAS/testing/c_cblas3.c index ae5f3936b2..4d396fe678 100644 --- a/CBLAS/testing/c_cblas3.c +++ b/CBLAS/testing/c_cblas3.c @@ -16,7 +16,7 @@ void F77_cgemm(CBLAS_INT *layout, char *transpa, char *transpb, CBLAS_INT *m, CB CBLAS_TEST_COMPLEX *b, CBLAS_INT *ldb, CBLAS_TEST_COMPLEX *beta, CBLAS_TEST_COMPLEX *c, CBLAS_INT *ldc #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN transpa_len, FORTRAN_STRLEN transpb_len #endif ) { @@ -177,7 +177,7 @@ void F77_chemm(CBLAS_INT *layout, char *rtlf, char *uplow, CBLAS_INT *m, CBLAS_I CBLAS_TEST_COMPLEX *b, CBLAS_INT *ldb, CBLAS_TEST_COMPLEX *beta, CBLAS_TEST_COMPLEX *c, CBLAS_INT *ldc #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len #endif ) { @@ -245,7 +245,7 @@ void F77_csymm(CBLAS_INT *layout, char *rtlf, char *uplow, CBLAS_INT *m, CBLAS_I CBLAS_TEST_COMPLEX *b, CBLAS_INT *ldb, CBLAS_TEST_COMPLEX *beta, CBLAS_TEST_COMPLEX *c, CBLAS_INT *ldc #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len #endif ) { @@ -303,7 +303,7 @@ void F77_cherk(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLAS float *alpha, CBLAS_TEST_COMPLEX *a, CBLAS_INT *lda, float *beta, CBLAS_TEST_COMPLEX *c, CBLAS_INT *ldc #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len #endif ) { @@ -363,7 +363,7 @@ void F77_csyrk(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLAS CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, CBLAS_INT *lda, CBLAS_TEST_COMPLEX *beta, CBLAS_TEST_COMPLEX *c, CBLAS_INT *ldc #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len #endif ) { @@ -423,7 +423,7 @@ void F77_cher2k(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLA CBLAS_TEST_COMPLEX *b, CBLAS_INT *ldb, float *beta, CBLAS_TEST_COMPLEX *c, CBLAS_INT *ldc #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len #endif ) { CBLAS_INT i,j,LDA,LDB,LDC; @@ -491,7 +491,7 @@ void F77_csyr2k(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLA CBLAS_TEST_COMPLEX *b, CBLAS_INT *ldb, CBLAS_TEST_COMPLEX *beta, CBLAS_TEST_COMPLEX *c, CBLAS_INT *ldc #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len #endif ) { CBLAS_INT i,j,LDA,LDB,LDC; @@ -558,7 +558,7 @@ void F77_ctrmm(CBLAS_INT *layout, char *rtlf, char *uplow, char *transp, char *d CBLAS_INT *m, CBLAS_INT *n, CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, CBLAS_INT *lda, CBLAS_TEST_COMPLEX *b, CBLAS_INT *ldb #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { CBLAS_INT i,j,LDA,LDB; @@ -621,7 +621,7 @@ void F77_ctrsm(CBLAS_INT *layout, char *rtlf, char *uplow, char *transp, char *d CBLAS_INT *m, CBLAS_INT *n, CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, CBLAS_INT *lda, CBLAS_TEST_COMPLEX *b, CBLAS_INT *ldb #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { CBLAS_INT i,j,LDA,LDB; diff --git a/CBLAS/testing/c_cblat3.f b/CBLAS/testing/c_cblat3.f index 88a077350a..ec795fdb63 100644 --- a/CBLAS/testing/c_cblat3.f +++ b/CBLAS/testing/c_cblat3.f @@ -4,7 +4,7 @@ PROGRAM CBLAT3 * * The program must be driven by a short data file. The first 13 records * of the file are read using list-directed input, the last 10 records -* are read using the format ( 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 23 lines: * 'CBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE @@ -66,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 ), @@ -78,7 +78,7 @@ 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 @@ -90,7 +90,7 @@ PROGRAM CBLAT3 * .. 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 @@ -421,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, @@ -429,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' ) @@ -462,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 ), @@ -710,20 +710,20 @@ 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:' ) - 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',', + 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 *', @@ -738,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 @@ -763,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 @@ -792,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 ), @@ -1036,20 +1036,20 @@ 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:' ) - 9995 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( 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 *', @@ -1064,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 @@ -1085,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 @@ -1113,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 ), @@ -1388,20 +1388,20 @@ 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:' ) - 9995 FORMAT(1X, I6, ': ', A12,'(', 4( '''', A1, ''',' ), 2( I3, ',' ), + 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 *', @@ -1416,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 @@ -1449,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 @@ -1478,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 ), @@ -1770,24 +1770,24 @@ 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 ) - 9994 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), + 9994 FORMAT(1X, I6, ': ', A13,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') ', $ ' .' ) - 9993 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( 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 *', @@ -1802,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 @@ -1825,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 @@ -1836,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 @@ -1859,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 @@ -1888,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 ), @@ -2223,24 +2223,24 @@ 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 ) - 9994 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( 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, ': ', A12,'(', 2( '''', A1, ''',' ), 2( 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 *', @@ -2255,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 @@ -2278,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 @@ -2290,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 @@ -2313,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 @@ -2827,7 +2827,7 @@ SUBROUTINE CCHK6( 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 ), @@ -2981,8 +2981,8 @@ SUBROUTINE CCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ LDB, BETA, LDC) IF( REWI ) $ REWIND NTRA - CALL CCGEMMTR(IORDER, UPLO, TRANSA, TRANSB, N, - $ K, ALPHA, AA, LDA, BB, LDB, + CALL CCGEMMTR(IORDER, UPLO, TRANSA, TRANSB, + $ N, K, ALPHA, AA, LDA, BB, LDB, $ BETA, CC, LDC ) * * Check if error-exit was taken incorrectly. @@ -3077,20 +3077,20 @@ SUBROUTINE CCHK6( 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:' ) - 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',', + 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 *', @@ -3106,7 +3106,7 @@ SUBROUTINE CPRCN8(NOUT, NC, SNAME, IORDER, UPLO, INTEGER NOUT, NC, IORDER, N, K, LDA, LDB, LDC COMPLEX ALPHA, BETA CHARACTER*1 TRANSA, TRANSB, UPLO - CHARACTER*12 SNAME + CHARACTER*13 SNAME CHARACTER*14 CRC, CTA,CTB,CUPLO IF (UPLO.EQ.'U') THEN @@ -3136,7 +3136,7 @@ SUBROUTINE CPRCN8(NOUT, NC, SNAME, IORDER, UPLO, 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, ': ', A12,'(', A14, ',', A14, ',', A14, ',', + 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, ').' ) diff --git a/CBLAS/testing/c_d2chke.c b/CBLAS/testing/c_d2chke.c index 6ff1160a98..f02a55dc8b 100644 --- a/CBLAS/testing/c_d2chke.c +++ b/CBLAS/testing/c_d2chke.c @@ -13,7 +13,7 @@ void F77_xerbla(F77_Char F77_srname, void *vinfo void F77_xerbla(char *srname, void *vinfo #endif #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN srname_len #endif ); @@ -30,7 +30,7 @@ void chkxer(void) { void F77_d2chke(char *rout #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN rout_len #endif ) { char *sf = ( rout ) ; diff --git a/CBLAS/testing/c_d3chke.c b/CBLAS/testing/c_d3chke.c index 40e522361d..f8919bf92d 100644 --- a/CBLAS/testing/c_d3chke.c +++ b/CBLAS/testing/c_d3chke.c @@ -13,7 +13,7 @@ void F77_xerbla(F77_Char F77_srname, void *vinfo void F77_xerbla(char *srname, void *vinfo #endif #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN srname_len #endif ); @@ -30,7 +30,7 @@ void chkxer(void) { void F77_d3chke(char *rout #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN rout_len #endif ) { char *sf = ( rout ) ; diff --git a/CBLAS/testing/c_dblas2.c b/CBLAS/testing/c_dblas2.c index 8902e2787f..e8cc2bd23d 100644 --- a/CBLAS/testing/c_dblas2.c +++ b/CBLAS/testing/c_dblas2.c @@ -12,7 +12,7 @@ void F77_dgemv(CBLAS_INT *layout, char *transp, CBLAS_INT *m, CBLAS_INT *n, doub double *a, CBLAS_INT *lda, double *x, CBLAS_INT *incx, double *beta, double *y, CBLAS_INT *incy #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN transp_len #endif ) { @@ -67,7 +67,7 @@ void F77_dger(CBLAS_INT *layout, CBLAS_INT *m, CBLAS_INT *n, double *alpha, doub void F77_dtrmv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, CBLAS_INT *n, double *a, CBLAS_INT *lda, double *x, CBLAS_INT *incx #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { double *A; @@ -99,7 +99,7 @@ void F77_dtrmv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, void F77_dtrsv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, CBLAS_INT *n, double *a, CBLAS_INT *lda, double *x, CBLAS_INT *incx #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { double *A; @@ -128,7 +128,7 @@ void F77_dsymv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, double *alpha, doub CBLAS_INT *lda, double *x, CBLAS_INT *incx, double *beta, double *y, CBLAS_INT *incy #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len #endif ) { double *A; @@ -155,7 +155,7 @@ void F77_dsymv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, double *alpha, doub void F77_dsyr(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, double *alpha, double *x, CBLAS_INT *incx, double *a, CBLAS_INT *lda #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len #endif ) { double *A; @@ -183,7 +183,7 @@ void F77_dsyr(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, double *alpha, doubl void F77_dsyr2(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, double *alpha, double *x, CBLAS_INT *incx, double *y, CBLAS_INT *incy, double *a, CBLAS_INT *lda #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len #endif ) { double *A; @@ -212,7 +212,7 @@ void F77_dgbmv(CBLAS_INT *layout, char *transp, CBLAS_INT *m, CBLAS_INT *n, CBLA double *alpha, double *a, CBLAS_INT *lda, double *x, CBLAS_INT *incx, double *beta, double *y, CBLAS_INT *incy #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN transp_len #endif ) { @@ -253,7 +253,7 @@ void F77_dgbmv(CBLAS_INT *layout, char *transp, CBLAS_INT *m, CBLAS_INT *n, CBLA void F77_dtbmv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, CBLAS_INT *n, CBLAS_INT *k, double *a, CBLAS_INT *lda, double *x, CBLAS_INT *incx #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { double *A; @@ -303,7 +303,7 @@ void F77_dtbmv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, void F77_dtbsv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, CBLAS_INT *n, CBLAS_INT *k, double *a, CBLAS_INT *lda, double *x, CBLAS_INT *incx #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { double *A; @@ -354,7 +354,7 @@ void F77_dsbmv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_INT *k, doubl double *a, CBLAS_INT *lda, double *x, CBLAS_INT *incx, double *beta, double *y, CBLAS_INT *incy #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len #endif ) { double *A; @@ -402,7 +402,7 @@ void F77_dsbmv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_INT *k, doubl void F77_dspmv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, double *alpha, double *ap, double *x, CBLAS_INT *incx, double *beta, double *y, CBLAS_INT *incy #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len #endif ) { double *A,*AP; @@ -444,7 +444,7 @@ void F77_dspmv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, double *alpha, doub void F77_dtpmv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, CBLAS_INT *n, double *ap, double *x, CBLAS_INT *incx #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { double *A, *AP; @@ -488,7 +488,7 @@ void F77_dtpmv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, void F77_dtpsv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, CBLAS_INT *n, double *ap, double *x, CBLAS_INT *incx #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { double *A, *AP; @@ -533,7 +533,7 @@ void F77_dtpsv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, void F77_dspr(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, double *alpha, double *x, CBLAS_INT *incx, double *ap #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len #endif ){ double *A, *AP; @@ -589,7 +589,7 @@ void F77_dspr(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, double *alpha, doubl void F77_dspr2(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, double *alpha, double *x, CBLAS_INT *incx, double *y, CBLAS_INT *incy, double *ap #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len #endif ){ double *A, *AP; diff --git a/CBLAS/testing/c_dblas3.c b/CBLAS/testing/c_dblas3.c index f0bc74af1b..c50b874df1 100644 --- a/CBLAS/testing/c_dblas3.c +++ b/CBLAS/testing/c_dblas3.c @@ -15,7 +15,7 @@ void F77_dgemm(CBLAS_INT *layout, char *transpa, char *transpb, CBLAS_INT *m, CB CBLAS_INT *k, double *alpha, double *a, CBLAS_INT *lda, double *b, CBLAS_INT *ldb, double *beta, double *c, CBLAS_INT *ldc #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN transpa_len, FORTRAN_STRLEN transpb_len #endif ) { @@ -81,7 +81,7 @@ void F77_dsymm(CBLAS_INT *layout, char *rtlf, char *uplow, CBLAS_INT *m, CBLAS_I double *alpha, double *a, CBLAS_INT *lda, double *b, CBLAS_INT *ldb, double *beta, double *c, CBLAS_INT *ldc #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len #endif ) { @@ -139,7 +139,7 @@ void F77_dsyrk(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLAS double *alpha, double *a, CBLAS_INT *lda, double *beta, double *c, CBLAS_INT *ldc #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len #endif ) { @@ -191,7 +191,7 @@ void F77_dsyr2k(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLA double *alpha, double *a, CBLAS_INT *lda, double *b, CBLAS_INT *ldb, double *beta, double *c, CBLAS_INT *ldc #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len #endif ) { CBLAS_INT i,j,LDA,LDB,LDC; @@ -250,7 +250,7 @@ void F77_dtrmm(CBLAS_INT *layout, char *rtlf, char *uplow, char *transp, char *d CBLAS_INT *m, CBLAS_INT *n, double *alpha, double *a, CBLAS_INT *lda, double *b, CBLAS_INT *ldb #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diag_len #endif ) { CBLAS_INT i,j,LDA,LDB; @@ -305,7 +305,7 @@ void F77_dtrsm(CBLAS_INT *layout, char *rtlf, char *uplow, char *transp, char *d CBLAS_INT *m, CBLAS_INT *n, double *alpha, double *a, CBLAS_INT *lda, double *b, CBLAS_INT *ldb #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { CBLAS_INT i,j,LDA,LDB; diff --git a/CBLAS/testing/c_s2chke.c b/CBLAS/testing/c_s2chke.c index 2d7237f0ed..fb3bd16c2a 100644 --- a/CBLAS/testing/c_s2chke.c +++ b/CBLAS/testing/c_s2chke.c @@ -30,7 +30,7 @@ void chkxer(void) { void F77_s2chke(char *rout #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN rout_len #endif ) { char *sf = ( rout ) ; diff --git a/CBLAS/testing/c_s3chke.c b/CBLAS/testing/c_s3chke.c index eb09911a53..f9772bf813 100644 --- a/CBLAS/testing/c_s3chke.c +++ b/CBLAS/testing/c_s3chke.c @@ -13,7 +13,7 @@ void F77_xerbla(F77_Char F77_srname, void *vinfo void F77_xerbla(char *srname, void *vinfo #endif #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN srname_len #endif ); @@ -30,7 +30,7 @@ void chkxer(void) { void F77_s3chke(char *rout #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN rout_len #endif ) { char *sf = ( rout ) ; diff --git a/CBLAS/testing/c_sblas2.c b/CBLAS/testing/c_sblas2.c index a56893b4dd..dd1a949ef9 100644 --- a/CBLAS/testing/c_sblas2.c +++ b/CBLAS/testing/c_sblas2.c @@ -12,7 +12,7 @@ void F77_sgemv(CBLAS_INT *layout, char *transp, CBLAS_INT *m, CBLAS_INT *n, floa float *a, CBLAS_INT *lda, float *x, CBLAS_INT *incx, float *beta, float *y, CBLAS_INT *incy #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN transp_len #endif ) { @@ -67,7 +67,7 @@ void F77_sger(CBLAS_INT *layout, CBLAS_INT *m, CBLAS_INT *n, float *alpha, float void F77_strmv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, CBLAS_INT *n, float *a, CBLAS_INT *lda, float *x, CBLAS_INT *incx #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { float *A; @@ -99,7 +99,7 @@ void F77_strmv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, void F77_strsv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, CBLAS_INT *n, float *a, CBLAS_INT *lda, float *x, CBLAS_INT *incx #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { float *A; @@ -128,7 +128,7 @@ void F77_ssymv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, float *alpha, float CBLAS_INT *lda, float *x, CBLAS_INT *incx, float *beta, float *y, CBLAS_INT *incy #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len #endif ) { float *A; @@ -155,7 +155,7 @@ void F77_ssymv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, float *alpha, float void F77_ssyr(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, float *alpha, float *x, CBLAS_INT *incx, float *a, CBLAS_INT *lda #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len #endif ) { float *A; @@ -183,7 +183,7 @@ void F77_ssyr(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, float *alpha, float void F77_ssyr2(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, float *alpha, float *x, CBLAS_INT *incx, float *y, CBLAS_INT *incy, float *a, CBLAS_INT *lda #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len #endif ) { float *A; @@ -212,7 +212,7 @@ void F77_sgbmv(CBLAS_INT *layout, char *transp, CBLAS_INT *m, CBLAS_INT *n, CBLA float *alpha, float *a, CBLAS_INT *lda, float *x, CBLAS_INT *incx, float *beta, float *y, CBLAS_INT *incy #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN transp_len #endif ) { @@ -253,7 +253,7 @@ void F77_sgbmv(CBLAS_INT *layout, char *transp, CBLAS_INT *m, CBLAS_INT *n, CBLA void F77_stbmv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, CBLAS_INT *n, CBLAS_INT *k, float *a, CBLAS_INT *lda, float *x, CBLAS_INT *incx #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { float *A; @@ -303,7 +303,7 @@ void F77_stbmv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, void F77_stbsv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, CBLAS_INT *n, CBLAS_INT *k, float *a, CBLAS_INT *lda, float *x, CBLAS_INT *incx #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { float *A; @@ -354,7 +354,7 @@ void F77_ssbmv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_INT *k, float float *a, CBLAS_INT *lda, float *x, CBLAS_INT *incx, float *beta, float *y, CBLAS_INT *incy #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len #endif ) { float *A; @@ -402,7 +402,7 @@ void F77_ssbmv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_INT *k, float void F77_sspmv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, float *alpha, float *ap, float *x, CBLAS_INT *incx, float *beta, float *y, CBLAS_INT *incy #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len #endif ) { float *A,*AP; @@ -443,7 +443,7 @@ void F77_sspmv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, float *alpha, float void F77_stpmv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, CBLAS_INT *n, float *ap, float *x, CBLAS_INT *incx #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { float *A, *AP; @@ -486,7 +486,7 @@ void F77_stpmv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, void F77_stpsv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, CBLAS_INT *n, float *ap, float *x, CBLAS_INT *incx #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { float *A, *AP; @@ -530,7 +530,7 @@ void F77_stpsv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, void F77_sspr(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, float *alpha, float *x, CBLAS_INT *incx, float *ap #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len #endif ){ float *A, *AP; @@ -585,7 +585,7 @@ void F77_sspr(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, float *alpha, float void F77_sspr2(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, float *alpha, float *x, CBLAS_INT *incx, float *y, CBLAS_INT *incy, float *ap #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len #endif ){ float *A, *AP; diff --git a/CBLAS/testing/c_sblas3.c b/CBLAS/testing/c_sblas3.c index 513c1e2697..5a026a3355 100644 --- a/CBLAS/testing/c_sblas3.c +++ b/CBLAS/testing/c_sblas3.c @@ -13,7 +13,7 @@ void F77_sgemm(CBLAS_INT *layout, char *transpa, char *transpb, CBLAS_INT *m, CB CBLAS_INT *k, float *alpha, float *a, CBLAS_INT *lda, float *b, CBLAS_INT *ldb, float *beta, float *c, CBLAS_INT *ldc #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN transpa_len, FORTRAN_STRLEN transpb_len #endif ) { @@ -78,7 +78,7 @@ void F77_ssymm(CBLAS_INT *layout, char *rtlf, char *uplow, CBLAS_INT *m, CBLAS_I float *alpha, float *a, CBLAS_INT *lda, float *b, CBLAS_INT *ldb, float *beta, float *c, CBLAS_INT *ldc #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len #endif ) { @@ -136,7 +136,7 @@ void F77_ssyrk(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLAS float *alpha, float *a, CBLAS_INT *lda, float *beta, float *c, CBLAS_INT *ldc #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len #endif ) { @@ -188,7 +188,7 @@ void F77_ssyr2k(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLA float *alpha, float *a, CBLAS_INT *lda, float *b, CBLAS_INT *ldb, float *beta, float *c, CBLAS_INT *ldc #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len #endif ) { CBLAS_INT i,j,LDA,LDB,LDC; @@ -247,7 +247,7 @@ void F77_strmm(CBLAS_INT *layout, char *rtlf, char *uplow, char *transp, char *d CBLAS_INT *m, CBLAS_INT *n, float *alpha, float *a, CBLAS_INT *lda, float *b, CBLAS_INT *ldb #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { CBLAS_INT i,j,LDA,LDB; @@ -302,7 +302,7 @@ void F77_strsm(CBLAS_INT *layout, char *rtlf, char *uplow, char *transp, char *d CBLAS_INT *m, CBLAS_INT *n, float *alpha, float *a, CBLAS_INT *lda, float *b, CBLAS_INT *ldb #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { CBLAS_INT i,j,LDA,LDB; diff --git a/CBLAS/testing/c_xerbla.c b/CBLAS/testing/c_xerbla.c index f1505dfc3a..a3ce836e7d 100644 --- a/CBLAS/testing/c_xerbla.c +++ b/CBLAS/testing/c_xerbla.c @@ -90,7 +90,7 @@ void F77_xerbla(F77_Char F77_srname, void *vinfo void F77_xerbla(char *srname, void *vinfo #endif #ifdef BLAS_FORTRAN_STRLEN_END -, FORTRAN_STRLEN +, FORTRAN_STRLEN srname_len #endif ) { diff --git a/CBLAS/testing/c_z2chke.c b/CBLAS/testing/c_z2chke.c index 7d51372ae6..e526905cc9 100644 --- a/CBLAS/testing/c_z2chke.c +++ b/CBLAS/testing/c_z2chke.c @@ -13,7 +13,7 @@ void F77_xerbla(F77_Char F77_srname, void *vinfo void F77_xerbla(char *srname, void *vinfo #endif #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN srname_len #endif ); @@ -30,7 +30,7 @@ void chkxer(void) { void F77_z2chke(char *rout #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN rout_len #endif ) { char *sf = ( rout ) ; diff --git a/CBLAS/testing/c_z3chke.c b/CBLAS/testing/c_z3chke.c index 37a6ff5037..113b054d97 100644 --- a/CBLAS/testing/c_z3chke.c +++ b/CBLAS/testing/c_z3chke.c @@ -13,7 +13,7 @@ void F77_xerbla(F77_Char F77_srname, void *vinfo void F77_xerbla(char *srname, void *vinfo #endif #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN srname_len #endif ); @@ -30,7 +30,7 @@ void chkxer(void) { void F77_z3chke(char *rout #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN rout_len #endif ) { char *sf = ( rout ) ; diff --git a/CBLAS/testing/c_zblas2.c b/CBLAS/testing/c_zblas2.c index e305711f51..0de71d2497 100644 --- a/CBLAS/testing/c_zblas2.c +++ b/CBLAS/testing/c_zblas2.c @@ -13,7 +13,7 @@ void F77_zgemv(CBLAS_INT *layout, char *transp, CBLAS_INT *m, CBLAS_INT *n, CBLAS_TEST_ZOMPLEX *a, CBLAS_INT *lda, const void *x, CBLAS_INT *incx, const void *beta, void *y, CBLAS_INT *incy #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN transp_len #endif ) { @@ -47,7 +47,7 @@ void F77_zgbmv(CBLAS_INT *layout, char *transp, CBLAS_INT *m, CBLAS_INT *n, CBLA CBLAS_TEST_ZOMPLEX *x, CBLAS_INT *incx, CBLAS_TEST_ZOMPLEX *beta, CBLAS_TEST_ZOMPLEX *y, CBLAS_INT *incy #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN transp_len #endif ) { @@ -154,7 +154,7 @@ void F77_zhemv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_TEST_ZOMPLEX CBLAS_TEST_ZOMPLEX *a, CBLAS_INT *lda, CBLAS_TEST_ZOMPLEX *x, CBLAS_INT *incx, CBLAS_TEST_ZOMPLEX *beta, CBLAS_TEST_ZOMPLEX *y, CBLAS_INT *incy #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len #endif ){ @@ -189,7 +189,7 @@ void F77_zhbmv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_INT *k, CBLAS_TEST_ZOMPLEX *x, CBLAS_INT *incx, CBLAS_TEST_ZOMPLEX *beta, CBLAS_TEST_ZOMPLEX *y, CBLAS_INT *incy #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len #endif ){ @@ -256,7 +256,7 @@ void F77_zhpmv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_TEST_ZOMPLEX CBLAS_TEST_ZOMPLEX *ap, CBLAS_TEST_ZOMPLEX *x, CBLAS_INT *incx, CBLAS_TEST_ZOMPLEX *beta, CBLAS_TEST_ZOMPLEX *y, CBLAS_INT *incy #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len #endif ){ @@ -316,7 +316,7 @@ void F77_ztbmv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, CBLAS_INT *n, CBLAS_INT *k, CBLAS_TEST_ZOMPLEX *a, CBLAS_INT *lda, CBLAS_TEST_ZOMPLEX *x, CBLAS_INT *incx #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { CBLAS_TEST_ZOMPLEX *A; @@ -383,7 +383,7 @@ void F77_ztbsv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, CBLAS_INT *n, CBLAS_INT *k, CBLAS_TEST_ZOMPLEX *a, CBLAS_INT *lda, CBLAS_TEST_ZOMPLEX *x, CBLAS_INT *incx #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { @@ -450,7 +450,7 @@ void F77_ztbsv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, void F77_ztpmv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, CBLAS_INT *n, CBLAS_TEST_ZOMPLEX *ap, CBLAS_TEST_ZOMPLEX *x, CBLAS_INT *incx #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { CBLAS_TEST_ZOMPLEX *A, *AP; @@ -509,7 +509,7 @@ void F77_ztpmv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, void F77_ztpsv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, CBLAS_INT *n, CBLAS_TEST_ZOMPLEX *ap, CBLAS_TEST_ZOMPLEX *x, CBLAS_INT *incx #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { CBLAS_TEST_ZOMPLEX *A, *AP; @@ -569,7 +569,7 @@ void F77_ztrmv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, CBLAS_INT *n, CBLAS_TEST_ZOMPLEX *a, CBLAS_INT *lda, CBLAS_TEST_ZOMPLEX *x, CBLAS_INT *incx #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { CBLAS_TEST_ZOMPLEX *A; @@ -602,7 +602,7 @@ void F77_ztrsv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, CBLAS_INT *n, CBLAS_TEST_ZOMPLEX *a, CBLAS_INT *lda, CBLAS_TEST_ZOMPLEX *x, CBLAS_INT *incx #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { CBLAS_TEST_ZOMPLEX *A; @@ -635,7 +635,7 @@ void F77_ztrsv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn, void F77_zhpr(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, double *alpha, CBLAS_TEST_ZOMPLEX *x, CBLAS_INT *incx, CBLAS_TEST_ZOMPLEX *ap #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len #endif ) { CBLAS_TEST_ZOMPLEX *A, *AP; @@ -715,7 +715,7 @@ void F77_zhpr2(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_TEST_ZOMPLEX CBLAS_TEST_ZOMPLEX *x, CBLAS_INT *incx, CBLAS_TEST_ZOMPLEX *y, CBLAS_INT *incy, CBLAS_TEST_ZOMPLEX *ap #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len #endif ) { CBLAS_TEST_ZOMPLEX *A, *AP; @@ -795,7 +795,7 @@ void F77_zhpr2(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_TEST_ZOMPLEX void F77_zher(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, double *alpha, CBLAS_TEST_ZOMPLEX *x, CBLAS_INT *incx, CBLAS_TEST_ZOMPLEX *a, CBLAS_INT *lda #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len #endif ) { CBLAS_TEST_ZOMPLEX *A; @@ -832,7 +832,7 @@ void F77_zher2(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_TEST_ZOMPLEX CBLAS_TEST_ZOMPLEX *x, CBLAS_INT *incx, CBLAS_TEST_ZOMPLEX *y, CBLAS_INT *incy, CBLAS_TEST_ZOMPLEX *a, CBLAS_INT *lda #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len #endif ) { diff --git a/CBLAS/testing/c_zblas3.c b/CBLAS/testing/c_zblas3.c index f8223c572e..c21adf71e4 100644 --- a/CBLAS/testing/c_zblas3.c +++ b/CBLAS/testing/c_zblas3.c @@ -16,7 +16,7 @@ void F77_zgemm(CBLAS_INT *layout, char *transpa, char *transpb, CBLAS_INT *m, CB CBLAS_TEST_ZOMPLEX *b, CBLAS_INT *ldb, CBLAS_TEST_ZOMPLEX *beta, CBLAS_TEST_ZOMPLEX *c, CBLAS_INT *ldc #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN transpa_len, FORTRAN_STRLEN transpb_len #endif ) { @@ -96,7 +96,7 @@ void F77_zhemm(CBLAS_INT *layout, char *rtlf, char *uplow, CBLAS_INT *m, CBLAS_I CBLAS_TEST_ZOMPLEX *b, CBLAS_INT *ldb, CBLAS_TEST_ZOMPLEX *beta, CBLAS_TEST_ZOMPLEX *c, CBLAS_INT *ldc #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len #endif ) { @@ -164,7 +164,7 @@ void F77_zsymm(CBLAS_INT *layout, char *rtlf, char *uplow, CBLAS_INT *m, CBLAS_I CBLAS_TEST_ZOMPLEX *b, CBLAS_INT *ldb, CBLAS_TEST_ZOMPLEX *beta, CBLAS_TEST_ZOMPLEX *c, CBLAS_INT *ldc #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len #endif ) { @@ -222,7 +222,7 @@ void F77_zherk(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLAS double *alpha, CBLAS_TEST_ZOMPLEX *a, CBLAS_INT *lda, double *beta, CBLAS_TEST_ZOMPLEX *c, CBLAS_INT *ldc #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len #endif ) { @@ -282,7 +282,7 @@ void F77_zsyrk(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLAS CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, CBLAS_INT *lda, CBLAS_TEST_ZOMPLEX *beta, CBLAS_TEST_ZOMPLEX *c, CBLAS_INT *ldc #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len #endif ) { @@ -342,7 +342,7 @@ void F77_zher2k(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLA CBLAS_TEST_ZOMPLEX *b, CBLAS_INT *ldb, double *beta, CBLAS_TEST_ZOMPLEX *c, CBLAS_INT *ldc #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len #endif ) { CBLAS_INT i,j,LDA,LDB,LDC; @@ -410,7 +410,7 @@ void F77_zsyr2k(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLA CBLAS_TEST_ZOMPLEX *b, CBLAS_INT *ldb, CBLAS_TEST_ZOMPLEX *beta, CBLAS_TEST_ZOMPLEX *c, CBLAS_INT *ldc #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len #endif ) { CBLAS_INT i,j,LDA,LDB,LDC; @@ -477,7 +477,7 @@ void F77_ztrmm(CBLAS_INT *layout, char *rtlf, char *uplow, char *transp, char *d CBLAS_INT *m, CBLAS_INT *n, CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, CBLAS_INT *lda, CBLAS_TEST_ZOMPLEX *b, CBLAS_INT *ldb #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { CBLAS_INT i,j,LDA,LDB; @@ -540,7 +540,7 @@ void F77_ztrsm(CBLAS_INT *layout, char *rtlf, char *uplow, char *transp, char *d CBLAS_INT *m, CBLAS_INT *n, CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, CBLAS_INT *lda, CBLAS_TEST_ZOMPLEX *b, CBLAS_INT *ldb #ifdef BLAS_FORTRAN_STRLEN_END - , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN + , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len #endif ) { CBLAS_INT i,j,LDA,LDB; From 60d0e76444a18cb9ebf5243a84736e7dc72ac482 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20K=C3=B6hler?= Date: Fri, 21 Jun 2024 14:07:47 +0200 Subject: [PATCH 15/23] Adding cblas_zgemmtr test --- CBLAS/testing/c_cblat3.f | 22 +- CBLAS/testing/c_zblas3.c | 82 +++++ CBLAS/testing/c_zblat3.f | 702 +++++++++++++++++++++++++++++++++++---- CBLAS/testing/zin3 | 19 +- 4 files changed, 733 insertions(+), 92 deletions(-) diff --git a/CBLAS/testing/c_cblat3.f b/CBLAS/testing/c_cblat3.f index ec795fdb63..8a275b96ae 100644 --- a/CBLAS/testing/c_cblat3.f +++ b/CBLAS/testing/c_cblat3.f @@ -20,15 +20,15 @@ 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: @@ -2852,7 +2852,7 @@ SUBROUTINE CCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, LOGICAL LCE, LCERES EXTERNAL LCE, LCERES * .. External Subroutines .. - EXTERNAL CCGEMM, CMAKE, CMMCH + EXTERNAL CCGEMMTR, CMAKE, CMMTCH, CPRCN8 * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. @@ -3341,7 +3341,7 @@ SUBROUTINE CMMTCH(UPLO, TRANSA, TRANSB, N, KK, ALPHA, A, LDA, 9998 FORMAT( 1X, I7, 2( ' (', G15.6, ',', G15.6, ')' ) ) 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) * -* End of CMMCH. +* End of CMMTCH. * END diff --git a/CBLAS/testing/c_zblas3.c b/CBLAS/testing/c_zblas3.c index c21adf71e4..77f2f8a529 100644 --- a/CBLAS/testing/c_zblas3.c +++ b/CBLAS/testing/c_zblas3.c @@ -91,6 +91,88 @@ void F77_zgemm(CBLAS_INT *layout, char *transpa, char *transpb, CBLAS_INT *m, CB cblas_zgemm( UNDEFINED, transa, transb, *m, *n, *k, alpha, a, *lda, b, *ldb, beta, c, *ldc ); } + + +void F77_zgemmtr(CBLAS_INT *layout, char *uplop, char *transpa, char *transpb, CBLAS_INT *n, + CBLAS_INT *k, CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, CBLAS_INT *lda, + CBLAS_TEST_ZOMPLEX *b, CBLAS_INT *ldb, CBLAS_TEST_ZOMPLEX *beta, + CBLAS_TEST_ZOMPLEX *c, CBLAS_INT *ldc ) { + + CBLAS_TEST_ZOMPLEX *A, *B, *C; + CBLAS_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_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_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(CBLAS_INT *layout, char *rtlf, char *uplow, CBLAS_INT *m, CBLAS_INT *n, CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, CBLAS_INT *lda, CBLAS_TEST_ZOMPLEX *b, CBLAS_INT *ldb, CBLAS_TEST_ZOMPLEX *beta, diff --git a/CBLAS/testing/c_zblat3.f b/CBLAS/testing/c_zblat3.f index 21e743d171..a93e201a80 100644 --- a/CBLAS/testing/c_zblat3.f +++ b/CBLAS/testing/c_zblat3.f @@ -4,7 +4,7 @@ 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 @@ -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 @@ -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, @@ -367,6 +368,20 @@ PROGRAM ZBLAT3 $ 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 * 190 IF( FATAL.AND.SFATAL ) $ GO TO 210 @@ -406,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, @@ -414,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' ) @@ -447,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 ), @@ -695,20 +710,20 @@ 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:' ) - 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',', + 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 *', @@ -723,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 @@ -748,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 @@ -777,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 ), @@ -1021,20 +1036,20 @@ 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:' ) - 9995 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( 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 *', @@ -1049,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 @@ -1070,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 @@ -1098,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 ), @@ -1373,20 +1388,20 @@ 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:' ) - 9995 FORMAT(1X, I6, ': ', A12,'(', 4( '''', A1, ''',' ), 2( I3, ',' ), + 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 *', @@ -1401,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 @@ -1434,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 @@ -1463,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 ), @@ -1755,24 +1770,24 @@ 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 ) - 9994 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), + 9994 FORMAT(1X, I6, ': ', A13,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') ', $ ' .' ) - 9993 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( 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 *', @@ -1787,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 @@ -1810,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 @@ -1821,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 @@ -1844,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 @@ -1873,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 ), @@ -2208,24 +2223,24 @@ 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 ) - 9994 FORMAT(1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( 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, ': ', A12,'(', 2( '''', A1, ''',' ), 2( 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 *', @@ -2240,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 @@ -2263,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 @@ -2275,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 @@ -2298,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 @@ -2790,3 +2805,546 @@ 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 8-February-1989. +* Jack Dongarra, Argonne National Laboratory. +* Iain Duff, AERE Harwell. +* Jeremy Du Croz, Numerical Algorithms Group Ltd. +* Sven Hammarling, Numerical Algorithms Group Ltd. +* +* .. Parameters .. + 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. +* +* Auxiliary routine for test program for Level 3 Blas. +* +* -- Written on 8-February-1989. +* Jack Dongarra, Argonne National Laboratory. +* Iain Duff, AERE Harwell. +* Jeremy Du Croz, Numerical Algorithms Group Ltd. +* Sven Hammarling, Numerical Algorithms Group Ltd. +* +* .. Parameters .. + 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 ABS, DIMAG, DCONJG, MAX, REAL, DBLE, SQRT +* .. Statement Functions .. + DOUBLE PRECISION ABS1 +* .. Statement Function definitions .. + ABS1( CL ) = ABS( DBLE( CL ) ) + ABS( 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/CBLAS/testing/zin3 b/CBLAS/testing/zin3 index 90a657592c..7e00e13ced 100644 --- a/CBLAS/testing/zin3 +++ b/CBLAS/testing/zin3 @@ -11,12 +11,13 @@ T LOGICAL FLAG, T TO TEST ERROR EXITS. (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA 3 NUMBER OF VALUES OF BETA (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA -cblas_zgemm T PUT F FOR NO TEST. SAME COLUMNS. -cblas_zhemm T PUT F FOR NO TEST. SAME COLUMNS. -cblas_zsymm T PUT F FOR NO TEST. SAME COLUMNS. -cblas_ztrmm T PUT F FOR NO TEST. SAME COLUMNS. -cblas_ztrsm T PUT F FOR NO TEST. SAME COLUMNS. -cblas_zherk T PUT F FOR NO TEST. SAME COLUMNS. -cblas_zsyrk T PUT F FOR NO TEST. SAME COLUMNS. -cblas_zher2k T PUT F FOR NO TEST. SAME COLUMNS. -cblas_zsyr2k T PUT F FOR NO TEST. SAME COLUMNS. +cblas_zgemm T PUT F FOR NO TEST. SAME COLUMNS. +cblas_zhemm T PUT F FOR NO TEST. SAME COLUMNS. +cblas_zsymm T PUT F FOR NO TEST. SAME COLUMNS. +cblas_ztrmm T PUT F FOR NO TEST. SAME COLUMNS. +cblas_ztrsm T PUT F FOR NO TEST. SAME COLUMNS. +cblas_zherk T PUT F FOR NO TEST. SAME COLUMNS. +cblas_zsyrk T PUT F FOR NO TEST. SAME COLUMNS. +cblas_zher2k T PUT F FOR NO TEST. SAME COLUMNS. +cblas_zsyr2k T PUT F FOR NO TEST. SAME COLUMNS. +cblas_zgemmtr T PUT F FOR NO TEST. SAME COLUMNS. From b721a550483e8a2a00e8ecc2a3b91841016a7468 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20K=C3=B6hler?= Date: Mon, 24 Jun 2024 10:15:00 +0200 Subject: [PATCH 16/23] Working CBLAS_ZGEMMTR Test --- BLAS/SRC/cgemmtr.f | 3 +- BLAS/SRC/zgemmtr.f | 7 +- CBLAS/src/cblas_cgemmtr.c | 187 +++++++++++++++++------------------ CBLAS/src/cblas_zgemmtr.c | 198 ++++++++++++++++++++------------------ CBLAS/testing/c_cblat3.f | 16 +-- CBLAS/testing/c_zblas3.c | 119 +++++++++++------------ CBLAS/testing/c_zblat3.f | 20 ++-- 7 files changed, 276 insertions(+), 274 deletions(-) diff --git a/BLAS/SRC/cgemmtr.f b/BLAS/SRC/cgemmtr.f index 5124a4a195..84bd22277c 100644 --- a/BLAS/SRC/cgemmtr.f +++ b/BLAS/SRC/cgemmtr.f @@ -278,8 +278,7 @@ SUBROUTINE CGEMMTR(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB, * * Quick return if possible. * - IF ((N.EQ.0) .OR. - + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN + IF (N.EQ.0) RETURN * * And when alpha.eq.zero. * diff --git a/BLAS/SRC/zgemmtr.f b/BLAS/SRC/zgemmtr.f index 18adf02dd7..5907a4d532 100644 --- a/BLAS/SRC/zgemmtr.f +++ b/BLAS/SRC/zgemmtr.f @@ -222,9 +222,9 @@ SUBROUTINE ZGEMMTR(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB, * .. * .. Parameters .. COMPLEX*16 ONE - PARAMETER (ONE= (1.0E+0,0.0E+0)) + PARAMETER (ONE= (1.0D+0,0.0D+0)) COMPLEX*16 ZERO - PARAMETER (ZERO= (0.0E+0,0.0E+0)) + PARAMETER (ZERO= (0.0D+0,0.0D+0)) * .. * * Set NOTA and NOTB as true if A and B respectively are not @@ -278,8 +278,7 @@ SUBROUTINE ZGEMMTR(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB, * * Quick return if possible. * - IF ((N.EQ.0) .OR. - + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN + IF (N.EQ.0) RETURN * * And when alpha.eq.zero. * diff --git a/CBLAS/src/cblas_cgemmtr.c b/CBLAS/src/cblas_cgemmtr.c index 9eb3592ca3..f3bc600e02 100644 --- a/CBLAS/src/cblas_cgemmtr.c +++ b/CBLAS/src/cblas_cgemmtr.c @@ -10,124 +10,125 @@ #include "cblas.h" #include "cblas_f77.h" void API_SUFFIX(cblas_cgemmtr)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, - const CBLAS_TRANSPOSE TransB, const CBLAS_INT N, - const CBLAS_INT K, const void *alpha, const void *A, - const CBLAS_INT lda, const void *B, const CBLAS_INT ldb, - const void *beta, void *C, const CBLAS_INT ldc) + const CBLAS_TRANSPOSE TransB, const CBLAS_INT N, + const CBLAS_INT K, const void *alpha, const void *A, + const CBLAS_INT lda, const void *B, const CBLAS_INT ldb, + const void *beta, void *C, const CBLAS_INT ldc) { - char TA, TB; - char UL; + char TA, TB; + char UL; #ifdef F77_CHAR - F77_CHAR F77_TA, F77_TB, F77_UL; + F77_CHAR F77_TA, F77_TB, F77_UL; #else - #define F77_TA &TA - #define F77_TB &TB - #define F77_UL &UL +#define F77_TA &TA +#define F77_TB &TB +#define F77_UL &UL #endif #ifdef F77_INT - F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; - F77_INT F77_ldc=ldc; + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; #else - #define F77_N N - #define F77_K K - #define F77_lda lda - #define F77_ldb ldb - #define F77_ldc ldc +#define F77_N N +#define F77_K K +#define F77_lda lda +#define F77_ldb ldb +#define F77_ldc ldc #endif - extern int CBLAS_CallFromC; - extern int RowMajorStrg; - RowMajorStrg = 0; - CBLAS_CallFromC = 1; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; - if( layout == CblasColMajor ) - { - if ( Uplo == CblasUpper ) UL = 'U'; - else if (Uplo == CblasLower) UL= 'L'; - else { + if( layout == CblasColMajor ) + { + if ( Uplo == CblasUpper ) UL = 'U'; + else if (Uplo == CblasLower) UL= 'L'; + else { API_SUFFIX(cblas_xerbla)(2, "cblas_cgemmtr", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; - } + } - if(TransA == CblasTrans) TA='T'; - else if ( TransA == CblasConjTrans ) TA='C'; - else if ( TransA == CblasNoTrans ) TA='N'; - else - { - API_SUFFIX(cblas_xerbla)(3, "cblas_cgemmtr", "Illegal TransA setting, %d\n", TransA); - CBLAS_CallFromC = 0; - RowMajorStrg = 0; - return; - } + if(TransA == CblasTrans) TA='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + API_SUFFIX(cblas_xerbla)(3, "cblas_cgemmtr", "Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } - if(TransB == CblasTrans) TB='T'; - else if ( TransB == CblasConjTrans ) TB='C'; - else if ( TransB == CblasNoTrans ) TB='N'; - else - { - API_SUFFIX(cblas_xerbla)(4, "cblas_cgemmtr", "Illegal TransB setting, %d\n", TransB); - CBLAS_CallFromC = 0; - RowMajorStrg = 0; - return; - } + if(TransB == CblasTrans) TB='T'; + else if ( TransB == CblasConjTrans ) TB='C'; + else if ( TransB == CblasNoTrans ) TB='N'; + else + { + API_SUFFIX(cblas_xerbla)(4, "cblas_cgemmtr", "Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } - #ifdef F77_CHAR - F77_TA = C2F_CHAR(&TA); - F77_TB = C2F_CHAR(&TB); - F77_UL = C2F_CHAR(&UL); - #endif +#ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + F77_UL = C2F_CHAR(&UL); +#endif - F77_cgemmtr(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, alpha, A, - &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); - } else if (layout == CblasRowMajor) - { - RowMajorStrg = 1; + F77_cgemmtr(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, alpha, A, + &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; - if ( Uplo == CblasUpper ) UL = 'L'; - else if (Uplo == CblasLower) UL= 'U'; - else { + if ( Uplo == CblasUpper ) UL = 'L'; + else if (Uplo == CblasLower) UL= 'U'; + else { API_SUFFIX(cblas_xerbla)(2, "cblas_cgemmtr", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; - } + } - if(TransA == CblasTrans) TB='T'; - else if ( TransA == CblasConjTrans ) TB='C'; - else if ( TransA == CblasNoTrans ) TB='N'; - else - { - API_SUFFIX(cblas_xerbla)(3, "cblas_cgemmtr", "Illegal TransA setting, %d\n", TransA); - CBLAS_CallFromC = 0; - RowMajorStrg = 0; - return; - } - if(TransB == CblasTrans) TA='T'; - else if ( TransB == CblasConjTrans ) TA='C'; - else if ( TransB == CblasNoTrans ) TA='N'; - else - { - API_SUFFIX(cblas_xerbla)(4, "cblas_cgemmtr", "Illegal TransB setting, %d\n", TransB); - CBLAS_CallFromC = 0; - RowMajorStrg = 0; - return; - } - #ifdef F77_CHAR - F77_TA = C2F_CHAR(&TA); - F77_TB = C2F_CHAR(&TB); - F77_UL = C2F_CHAR(&UL); + if(TransA == CblasTrans) TB='T'; + else if ( TransA == CblasConjTrans ) TB='C'; + else if ( TransA == CblasNoTrans ) TB='N'; + else + { + API_SUFFIX(cblas_xerbla)(3, "cblas_cgemmtr", "Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(TransB == CblasTrans) TA='T'; + else if ( TransB == CblasConjTrans ) TA='C'; + else if ( TransB == CblasNoTrans ) TA='N'; + else + { + API_SUFFIX(cblas_xerbla)(4, "cblas_cgemmtr", "Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } +#ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + F77_UL = C2F_CHAR(&UL); - #endif +#endif - F77_cgemmtr(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, alpha, B, - &F77_ldb, A, &F77_lda, beta, C, &F77_ldc); - } - else API_SUFFIX(cblas_xerbla)(1, "cblas_cgemmtr", "Illegal layout setting, %d\n", layout); - CBLAS_CallFromC = 0; - RowMajorStrg = 0; - return; + F77_cgemmtr(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, alpha, B, + &F77_ldb, A, &F77_lda, beta, C, &F77_ldc); + } + else API_SUFFIX(cblas_xerbla)(1, "cblas_cgemmtr", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; } diff --git a/CBLAS/src/cblas_zgemmtr.c b/CBLAS/src/cblas_zgemmtr.c index c01ecb2d1d..23eebe516a 100644 --- a/CBLAS/src/cblas_zgemmtr.c +++ b/CBLAS/src/cblas_zgemmtr.c @@ -10,112 +10,126 @@ #include "cblas.h" #include "cblas_f77.h" void API_SUFFIX(cblas_zgemmtr)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, - const CBLAS_TRANSPOSE TransB, const CBLAS_INT N, - const CBLAS_INT K, const void *alpha, const void *A, - const CBLAS_INT lda, const void *B, const CBLAS_INT ldb, - const void *beta, void *C, const CBLAS_INT ldc) + const CBLAS_TRANSPOSE TransB, const CBLAS_INT N, + const CBLAS_INT K, const void *alpha, const void *A, + const CBLAS_INT lda, const void *B, const CBLAS_INT ldb, + const void *beta, void *C, const CBLAS_INT ldc) { - char TA, TB, UL; + char TA, TB, UL; #ifdef F77_CHAR - F77_CHAR F77_TA, F77_TB, F77_UL; + F77_CHAR F77_TA, F77_TB, F77_UL; #else - #define F77_TA &TA - #define F77_TB &TB - #define F77_UL &UL +#define F77_TA &TA +#define F77_TB &TB +#define F77_UL &UL #endif #ifdef F77_INT - F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; - F77_INT F77_ldc=ldc; + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; #else - #define F77_N N - #define F77_K K - #define F77_lda lda - #define F77_ldb ldb - #define F77_ldc ldc +#define F77_N N +#define F77_K K +#define F77_lda lda +#define F77_ldb ldb +#define F77_ldc ldc #endif - extern int CBLAS_CallFromC; - extern int RowMajorStrg; - RowMajorStrg = 0; - CBLAS_CallFromC = 1; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; - if ( Uplo == CblasUpper ) UL = 'U'; - else if (Uplo == CblasLower) UL= 'L'; - else { - API_SUFFIX(cblas_xerbla)(2, "cblas_zgemmtr", "Illegal Uplo setting, %d\n", Uplo); - CBLAS_CallFromC = 0; - RowMajorStrg = 0; - return; - } + if( layout == CblasColMajor ) + { + if ( Uplo == CblasUpper ) UL = 'U'; + else if (Uplo == CblasLower) UL= 'L'; + else { + API_SUFFIX(cblas_xerbla)(2, "cblas_zgemmtr", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } - if( layout == CblasColMajor ) - { - if(TransA == CblasTrans) TA='T'; - else if ( TransA == CblasConjTrans ) TA='C'; - else if ( TransA == CblasNoTrans ) TA='N'; - else - { - API_SUFFIX(cblas_xerbla)(3, "cblas_zgemmtr","Illegal TransA setting, %d\n", TransA); - CBLAS_CallFromC = 0; - RowMajorStrg = 0; - return; - } - if(TransB == CblasTrans) TB='T'; - else if ( TransB == CblasConjTrans ) TB='C'; - else if ( TransB == CblasNoTrans ) TB='N'; - else - { - API_SUFFIX(cblas_xerbla)(4, "cblas_zgemmtr","Illegal TransB setting, %d\n", TransB); - CBLAS_CallFromC = 0; - RowMajorStrg = 0; - return; - } + if(TransA == CblasTrans) TA='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + API_SUFFIX(cblas_xerbla)(3, "cblas_zgemmtr","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } - #ifdef F77_CHAR - F77_TA = C2F_CHAR(&TA); - F77_TB = C2F_CHAR(&TB); - F77_UL = C2F_CHAR(&UL); - #endif + if(TransB == CblasTrans) TB='T'; + else if ( TransB == CblasConjTrans ) TB='C'; + else if ( TransB == CblasNoTrans ) TB='N'; + else + { + API_SUFFIX(cblas_xerbla)(4, "cblas_zgemmtr","Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } - F77_zgemmtr(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, alpha, A, - &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); - } else if (layout == CblasRowMajor) - { - RowMajorStrg = 1; - if(TransA == CblasTrans) TB='T'; - else if ( TransA == CblasConjTrans ) TB='C'; - else if ( TransA == CblasNoTrans ) TB='N'; - else - { - API_SUFFIX(cblas_xerbla)(3, "cblas_zgemmtr","Illegal TransA setting, %d\n", TransA); - CBLAS_CallFromC = 0; - RowMajorStrg = 0; - return; - } - if(TransB == CblasTrans) TA='T'; - else if ( TransB == CblasConjTrans ) TA='C'; - else if ( TransB == CblasNoTrans ) TA='N'; - else - { - API_SUFFIX(cblas_xerbla)(4, "cblas_zgemmtr","Illegal TransB setting, %d\n", TransB); - CBLAS_CallFromC = 0; - RowMajorStrg = 0; - return; - } - #ifdef F77_CHAR - F77_TA = C2F_CHAR(&TA); - F77_TB = C2F_CHAR(&TB); - F77_UL = C2F_CHAR(&UL); - #endif +#ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + F77_UL = C2F_CHAR(&UL); +#endif + + F77_zgemmtr(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, alpha, A, + &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + + if ( Uplo == CblasUpper ) UL = 'L'; + else if (Uplo == CblasLower) UL= 'U'; + else { + API_SUFFIX(cblas_xerbla)(2, "cblas_cgemmtr", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if(TransA == CblasTrans) TB='T'; + else if ( TransA == CblasConjTrans ) TB='C'; + else if ( TransA == CblasNoTrans ) TB='N'; + else + { + API_SUFFIX(cblas_xerbla)(3, "zblas_cgemmtr", "Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(TransB == CblasTrans) TA='T'; + else if ( TransB == CblasConjTrans ) TA='C'; + else if ( TransB == CblasNoTrans ) TA='N'; + else + { + API_SUFFIX(cblas_xerbla)(4, "zblas_cgemmtr", "Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } +#ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + F77_UL = C2F_CHAR(&UL); + +#endif + + F77_zgemmtr(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, alpha, B, + &F77_ldb, A, &F77_lda, beta, C, &F77_ldc); + } - F77_zgemmtr(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, alpha, B, - &F77_ldb, A, &F77_lda, beta, C, &F77_ldc); - } - else API_SUFFIX(cblas_xerbla)(1, "cblas_zgemmtr", "Illegal layout setting, %d\n", layout); - CBLAS_CallFromC = 0; - RowMajorStrg = 0; - return; + else API_SUFFIX(cblas_xerbla)(1, "cblas_zgemmtr", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; } diff --git a/CBLAS/testing/c_cblat3.f b/CBLAS/testing/c_cblat3.f index 8a275b96ae..07be55c929 100644 --- a/CBLAS/testing/c_cblat3.f +++ b/CBLAS/testing/c_cblat3.f @@ -2812,11 +2812,8 @@ SUBROUTINE CCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * * Auxiliary routine for test program for Level 3 Blas. * -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. +* -- Written on 24-June-2024. +* Martin Koehler, Max Planck Institute Magdeburg * * .. Parameters .. COMPLEX ZERO @@ -3148,15 +3145,12 @@ SUBROUTINE CMMTCH(UPLO, TRANSA, TRANSB, N, KK, ALPHA, A, LDA, $ NOUT, MV ) IMPLICIT NONE * -* Checks the results of the computational tests. +* Checks the results of the computational tests for GEMMTR. * * Auxiliary routine for test program for Level 3 Blas. * -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. +* -- Written on 24-June-2024. +* Martin Koehler, Max Planck Institute, Magdeburg * * .. Parameters .. COMPLEX ZERO diff --git a/CBLAS/testing/c_zblas3.c b/CBLAS/testing/c_zblas3.c index 77f2f8a529..43dd335df7 100644 --- a/CBLAS/testing/c_zblas3.c +++ b/CBLAS/testing/c_zblas3.c @@ -5,6 +5,7 @@ * Modified by T. H. Do, 4/15/98, SGI/CRAY Research. */ #include +#include #include "cblas.h" #include "cblas_test.h" #define TEST_COL_MJR 0 @@ -108,68 +109,68 @@ void F77_zgemmtr(CBLAS_INT *layout, char *uplop, char *transpa, char *transpb, C 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_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); + 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 ); + 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 ); + cblas_zgemmtr( UNDEFINED, uplo, transa, transb, *n, *k, alpha, a, *lda, + b, *ldb, beta, c, *ldc ); } diff --git a/CBLAS/testing/c_zblat3.f b/CBLAS/testing/c_zblat3.f index a93e201a80..bab4f06ddd 100644 --- a/CBLAS/testing/c_zblat3.f +++ b/CBLAS/testing/c_zblat3.f @@ -2815,11 +2815,8 @@ SUBROUTINE ZCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * * Auxiliary routine for test program for Level 3 Blas. * -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. +* -- Written on 24-June-2024. +* Martin Koehler, Max Planck Institute Magdeburg * * .. Parameters .. COMPLEX*16 ZERO @@ -3151,15 +3148,12 @@ SUBROUTINE ZMMTCH(UPLO, TRANSA, TRANSB, N, KK, ALPHA, A, LDA, $ NOUT, MV ) IMPLICIT NONE * -* Checks the results of the computational tests. +* Checks the results of the computational tests for GEMMTR. * * Auxiliary routine for test program for Level 3 Blas. * -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. +* -- Written on 24-June-2024. +* Martin Koehler, Max Planck Institute, Magdeburg * * .. Parameters .. COMPLEX*16 ZERO @@ -3182,11 +3176,11 @@ SUBROUTINE ZMMTCH(UPLO, TRANSA, TRANSB, N, KK, ALPHA, A, LDA, INTEGER I, J, K, ISTART, ISTOP LOGICAL CTRANA, CTRANB, TRANA, TRANB, UPPER * .. Intrinsic Functions .. - INTRINSIC ABS, DIMAG, DCONJG, MAX, REAL, DBLE, SQRT + INTRINSIC DABS, DIMAG, DCONJG, MAX, DBLE, DSQRT * .. Statement Functions .. DOUBLE PRECISION ABS1 * .. Statement Function definitions .. - ABS1( CL ) = ABS( DBLE( CL ) ) + ABS( DIMAG( CL ) ) + ABS1( CL ) = DABS( DBLE( CL ) ) + DABS( DIMAG( CL ) ) * .. Executable Statements .. UPPER = UPLO.EQ.'U' From adaf7248e787681fce028d460cad2601b2b094de Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20K=C3=B6hler?= Date: Mon, 24 Jun 2024 10:20:17 +0200 Subject: [PATCH 17/23] Update comments --- CBLAS/src/cblas_cgemmtr.c | 8 ++++---- CBLAS/src/cblas_zgemmtr.c | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/CBLAS/src/cblas_cgemmtr.c b/CBLAS/src/cblas_cgemmtr.c index f3bc600e02..5717dc4097 100644 --- a/CBLAS/src/cblas_cgemmtr.c +++ b/CBLAS/src/cblas_cgemmtr.c @@ -1,9 +1,9 @@ /* * - * cblas_cgemm.c - * This program is a C interface to cgemm. - * Written by Keita Teranishi - * 4/8/1998 + * cblas_cgemmtr.c + * This program is a C interface to cgemmtr. + * Written by Martin Koehler, MPI Magdeburg + * 06/24/2024 * */ diff --git a/CBLAS/src/cblas_zgemmtr.c b/CBLAS/src/cblas_zgemmtr.c index 23eebe516a..4d884d944a 100644 --- a/CBLAS/src/cblas_zgemmtr.c +++ b/CBLAS/src/cblas_zgemmtr.c @@ -1,9 +1,9 @@ /* * - * cblas_zgemm.c - * This program is a C interface to zgemm. - * Written by Keita Teranishi - * 4/8/1998 + * cblas_zgemmtr.c + * This program is a C interface to zgemmtr. + * Written by Martin Koehler, MPI Magdeburg + * 06/24/2024 * */ From b681b1eaecd8813ba9b0a822b97aa2556856b8f9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20K=C3=B6hler?= Date: Mon, 24 Jun 2024 13:43:23 +0200 Subject: [PATCH 18/23] Add cblas_dgemmtr test --- BLAS/SRC/dgemmtr.f | 3 +- BLAS/TESTING/dblat3.f | 12 +- CBLAS/src/cblas_dgemmtr.c | 197 ++++++------ CBLAS/testing/c_cblat2.f | 4 +- CBLAS/testing/c_dblas3.c | 79 +++++ CBLAS/testing/c_dblat3.f | 631 +++++++++++++++++++++++++++++++++----- CBLAS/testing/c_sblas3.c | 76 +++++ CBLAS/testing/c_zblat2.f | 4 +- CBLAS/testing/c_zblat3.f | 8 +- CBLAS/testing/din3 | 13 +- 10 files changed, 841 insertions(+), 186 deletions(-) diff --git a/BLAS/SRC/dgemmtr.f b/BLAS/SRC/dgemmtr.f index 3a54f17b6f..acaaa351e0 100644 --- a/BLAS/SRC/dgemmtr.f +++ b/BLAS/SRC/dgemmtr.f @@ -272,8 +272,7 @@ SUBROUTINE DGEMMTR(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB, * * Quick return if possible. * - IF ((N.EQ.0) .OR. - + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN + IF (N.EQ.0) RETURN * * And if alpha.eq.zero. * diff --git a/BLAS/TESTING/dblat3.f b/BLAS/TESTING/dblat3.f index e45a1f91da..e95da164a8 100644 --- a/BLAS/TESTING/dblat3.f +++ b/BLAS/TESTING/dblat3.f @@ -37,12 +37,12 @@ *> 0.0 1.0 0.7 VALUES OF ALPHA *> 3 NUMBER OF VALUES OF BETA *> 0.0 1.0 1.3 VALUES OF BETA -*> DGEMM T PUT F FOR NO TEST. SAME COLUMNS. -*> DSYMM T PUT F FOR NO TEST. SAME COLUMNS. -*> DTRMM T PUT F FOR NO TEST. SAME COLUMNS. -*> DTRSM T PUT F FOR NO TEST. SAME COLUMNS. -*> DSYRK T PUT F FOR NO TEST. SAME COLUMNS. -*> DSYR2K T PUT F FOR NO TEST. SAME COLUMNS. +*> DGEMM T PUT F FOR NO TEST. SAME COLUMNS. +*> DSYMM T PUT F FOR NO TEST. SAME COLUMNS. +*> DTRMM T PUT F FOR NO TEST. SAME COLUMNS. +*> DTRSM T PUT F FOR NO TEST. SAME COLUMNS. +*> DSYRK T PUT F FOR NO TEST. SAME COLUMNS. +*> DSYR2K T PUT F FOR NO TEST. SAME COLUMNS. *> DGEMMTR T PUT F FOR NO TEST. SAME COLUMNS. *> *> Further Details diff --git a/CBLAS/src/cblas_dgemmtr.c b/CBLAS/src/cblas_dgemmtr.c index 99a2fa81a8..ac605e31db 100644 --- a/CBLAS/src/cblas_dgemmtr.c +++ b/CBLAS/src/cblas_dgemmtr.c @@ -10,112 +10,125 @@ #include "cblas.h" #include "cblas_f77.h" void API_SUFFIX(cblas_dgemmtr)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, - const CBLAS_TRANSPOSE TransB, const CBLAS_INT N, - const CBLAS_INT K, const double alpha, const double *A, - const CBLAS_INT lda, const double *B, const CBLAS_INT ldb, - const double beta, double *C, const CBLAS_INT ldc) + const CBLAS_TRANSPOSE TransB, const CBLAS_INT N, + const CBLAS_INT K, const double alpha, const double *A, + const CBLAS_INT lda, const double *B, const CBLAS_INT ldb, + const double beta, double *C, const CBLAS_INT ldc) { - char TA, TB, UL; + char TA, TB, UL; #ifdef F77_CHAR - F77_CHAR F77_TA, F77_TB. F77_UL; + F77_CHAR F77_TA, F77_TB. F77_UL; #else - #define F77_TA &TA - #define F77_TB &TB - #define F77_UL &UL +#define F77_TA &TA +#define F77_TB &TB +#define F77_UL &UL #endif #ifdef F77_INT - F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; - F77_INT F77_ldc=ldc; + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; #else - #define F77_N N - #define F77_K K - #define F77_lda lda - #define F77_ldb ldb - #define F77_ldc ldc +#define F77_N N +#define F77_K K +#define F77_lda lda +#define F77_ldb ldb +#define F77_ldc ldc #endif - extern int CBLAS_CallFromC; - extern int RowMajorStrg; - RowMajorStrg = 0; - CBLAS_CallFromC = 1; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; - if ( Uplo == CblasUpper ) UL = 'U'; - else if (Uplo == CblasLower) UL= 'L'; - else { - API_SUFFIX(cblas_xerbla)(2, "cblas_dgemmtr", "Illegal Uplo setting, %d\n", Uplo); - CBLAS_CallFromC = 0; - RowMajorStrg = 0; - return; - } + if( layout == CblasColMajor ) + { + if ( Uplo == CblasUpper ) UL = 'U'; + else if (Uplo == CblasLower) UL= 'L'; + else { + API_SUFFIX(cblas_xerbla)(2, "cblas_dgemmtr", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } - if( layout == CblasColMajor ) - { - if(TransA == CblasTrans) TA='T'; - else if ( TransA == CblasConjTrans ) TA='C'; - else if ( TransA == CblasNoTrans ) TA='N'; - else - { - API_SUFFIX(cblas_xerbla)(3, "cblas_dgemmtr","Illegal TransA setting, %d\n", TransA); - CBLAS_CallFromC = 0; - RowMajorStrg = 0; - return; - } - if(TransB == CblasTrans) TB='T'; - else if ( TransB == CblasConjTrans ) TB='C'; - else if ( TransB == CblasNoTrans ) TB='N'; - else - { - API_SUFFIX(cblas_xerbla)(4, "cblas_dgemmtr","Illegal TransB setting, %d\n", TransB); - CBLAS_CallFromC = 0; - RowMajorStrg = 0; - return; - } - #ifdef F77_CHAR - F77_TA = C2F_CHAR(&TA); - F77_TB = C2F_CHAR(&TB); - F77_UL = C2F_CHAR(&UL); - #endif + if(TransA == CblasTrans) TA='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + API_SUFFIX(cblas_xerbla)(3, "cblas_dgemmtr","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } - F77_dgemmtr(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, &alpha, A, - &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); - } else if (layout == CblasRowMajor) - { - RowMajorStrg = 1; - if(TransA == CblasTrans) TB='T'; - else if ( TransA == CblasConjTrans ) TB='C'; - else if ( TransA == CblasNoTrans ) TB='N'; - else - { - API_SUFFIX(cblas_xerbla)(3, "cblas_dgemmtr","Illegal TransA setting, %d\n", TransA); - CBLAS_CallFromC = 0; - RowMajorStrg = 0; - return; - } - if(TransB == CblasTrans) TA='T'; - else if ( TransB == CblasConjTrans ) TA='C'; - else if ( TransB == CblasNoTrans ) TA='N'; - else - { - API_SUFFIX(cblas_xerbla)(4, "cblas_dgemmtr","Illegal TransB setting, %d\n", TransB); - CBLAS_CallFromC = 0; - RowMajorStrg = 0; - return; - } - #ifdef F77_CHAR - F77_TA = C2F_CHAR(&TA); - F77_TB = C2F_CHAR(&TB); - F77_UL = C2F_CHAR(&UL); - #endif + if(TransB == CblasTrans) TB='T'; + else if ( TransB == CblasConjTrans ) TB='C'; + else if ( TransB == CblasNoTrans ) TB='N'; + else + { + API_SUFFIX(cblas_xerbla)(4, "cblas_dgemmtr","Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } - F77_dgemmtr( F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, &alpha, B, - &F77_ldb, A, &F77_lda, &beta, C, &F77_ldc); - } - else API_SUFFIX(cblas_xerbla)(1, "cblas_dgemmtr", "Illegal layout setting, %d\n", layout); - CBLAS_CallFromC = 0; - RowMajorStrg = 0; - return; +#ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + F77_UL = C2F_CHAR(&UL); +#endif + + F77_dgemmtr(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, &alpha, A, + &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); + } + else if (layout == CblasRowMajor) + { + if ( Uplo == CblasUpper ) UL = 'L'; + else if (Uplo == CblasLower) UL= 'U'; + else { + API_SUFFIX(cblas_xerbla)(2, "cblas_dgemmtr", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + + RowMajorStrg = 1; + if(TransA == CblasTrans) TB='T'; + else if ( TransA == CblasConjTrans ) TB='C'; + else if ( TransA == CblasNoTrans ) TB='N'; + else + { + API_SUFFIX(cblas_xerbla)(3, "cblas_dgemmtr","Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(TransB == CblasTrans) TA='T'; + else if ( TransB == CblasConjTrans ) TA='C'; + else if ( TransB == CblasNoTrans ) TA='N'; + else + { + API_SUFFIX(cblas_xerbla)(4, "cblas_dgemmtr","Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } +#ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + F77_UL = C2F_CHAR(&UL); +#endif + + F77_dgemmtr( F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, &alpha, B, + &F77_ldb, A, &F77_lda, &beta, C, &F77_ldc); + } + else API_SUFFIX(cblas_xerbla)(1, "cblas_dgemmtr", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; } diff --git a/CBLAS/testing/c_cblat2.f b/CBLAS/testing/c_cblat2.f index d934ebb49d..072b6a3b18 100644 --- a/CBLAS/testing/c_cblat2.f +++ b/CBLAS/testing/c_cblat2.f @@ -349,13 +349,13 @@ PROGRAM CBLAT2 CALL CCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z, - $ 0 ) + $ 0 ) END IF IF (RORDER) THEN CALL CCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z, - $ 1 ) + $ 1 ) END IF GO TO 200 * Test CGERC, 12, CGERU, 13. diff --git a/CBLAS/testing/c_dblas3.c b/CBLAS/testing/c_dblas3.c index c50b874df1..675f0ebfc0 100644 --- a/CBLAS/testing/c_dblas3.c +++ b/CBLAS/testing/c_dblas3.c @@ -77,6 +77,85 @@ void F77_dgemm(CBLAS_INT *layout, char *transpa, char *transpb, CBLAS_INT *m, CB cblas_dgemm( UNDEFINED, transa, transb, *m, *n, *k, *alpha, a, *lda, b, *ldb, *beta, c, *ldc ); } + +void F77_dgemmtr(CBLAS_INT *layout, char *uplop, char *transpa, char *transpb, CBLAS_INT *n, + CBLAS_INT *k, double *alpha, double *a, CBLAS_INT *lda, + double *b, CBLAS_INT *ldb, double *beta, + double *c, CBLAS_INT *ldc ) { + + double *A, *B, *C; + CBLAS_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(CBLAS_INT *layout, char *rtlf, char *uplow, CBLAS_INT *m, CBLAS_INT *n, double *alpha, double *a, CBLAS_INT *lda, double *b, CBLAS_INT *ldb, double *beta, double *c, CBLAS_INT *ldc diff --git a/CBLAS/testing/c_dblat3.f b/CBLAS/testing/c_dblat3.f index 72ad80c925..e88a77dc7b 100644 --- a/CBLAS/testing/c_dblat3.f +++ b/CBLAS/testing/c_dblat3.f @@ -4,7 +4,7 @@ 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 @@ -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. @@ -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 @@ -397,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, @@ -405,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' ) @@ -435,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 ), @@ -588,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. * @@ -681,20 +697,20 @@ 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:' ) - 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',', + 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 *', @@ -708,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 @@ -733,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 @@ -759,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 ), @@ -994,20 +1010,20 @@ 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:' ) - 9995 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), + 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 *', @@ -1022,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 @@ -1043,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 @@ -1069,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 ), @@ -1201,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, @@ -1211,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. @@ -1342,20 +1358,20 @@ 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:' ) - 9995 FORMAT( 1X, I6, ': ', A12,'(', 4( '''', A1, ''',' ), 2( 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 *', $ '******' ) @@ -1369,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 @@ -1402,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 @@ -1428,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 ), @@ -1667,21 +1683,21 @@ 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 ) - 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( 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 *', $ '******' ) @@ -1695,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 @@ -1718,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 @@ -1726,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. * @@ -1745,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 ), @@ -1888,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. * @@ -2023,21 +2039,21 @@ 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 ) - 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), + 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 *', @@ -2052,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 @@ -2075,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 @@ -2474,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/CBLAS/testing/c_sblas3.c b/CBLAS/testing/c_sblas3.c index 5a026a3355..5a0744e116 100644 --- a/CBLAS/testing/c_sblas3.c +++ b/CBLAS/testing/c_sblas3.c @@ -74,6 +74,82 @@ void F77_sgemm(CBLAS_INT *layout, char *transpa, char *transpb, CBLAS_INT *m, CB cblas_sgemm( UNDEFINED, transa, transb, *m, *n, *k, *alpha, a, *lda, b, *ldb, *beta, c, *ldc ); } + +void F77_cgemmtr(CBLAS_INT *layout, char *uplop, char *transpa, char *transpb, CBLAS_INT *n, + CBLAS_INT *k, float *alpha, float *a, CBLAS_INT *lda, + float *b, CBLAS_INT *ldb, float *beta, + float *c, CBLAS_INT *ldc ) { + + float *A, *B, *C; + CBLAS_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(CBLAS_INT *layout, char *rtlf, char *uplow, CBLAS_INT *m, CBLAS_INT *n, float *alpha, float *a, CBLAS_INT *lda, float *b, CBLAS_INT *ldb, float *beta, float *c, CBLAS_INT *ldc diff --git a/CBLAS/testing/c_zblat2.f b/CBLAS/testing/c_zblat2.f index 4392602302..a46e62137c 100644 --- a/CBLAS/testing/c_zblat2.f +++ b/CBLAS/testing/c_zblat2.f @@ -349,13 +349,13 @@ PROGRAM ZBLAT2 CALL ZCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z, - $ 0 ) + $ 0 ) END IF IF (RORDER) THEN CALL ZCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z, - $ 1 ) + $ 1 ) END IF GO TO 200 * Test ZGERC, 12, ZGERU, 13. diff --git a/CBLAS/testing/c_zblat3.f b/CBLAS/testing/c_zblat3.f index bab4f06ddd..23ee361acc 100644 --- a/CBLAS/testing/c_zblat3.f +++ b/CBLAS/testing/c_zblat3.f @@ -331,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. @@ -359,13 +359,13 @@ 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 diff --git a/CBLAS/testing/din3 b/CBLAS/testing/din3 index 1f777156f0..350544d66f 100644 --- a/CBLAS/testing/din3 +++ b/CBLAS/testing/din3 @@ -11,9 +11,10 @@ T LOGICAL FLAG, T TO TEST ERROR EXITS. 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. From 63d2b3af5810da7be2b6c58939f32c1ccb5988bc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20K=C3=B6hler?= Date: Mon, 24 Jun 2024 14:03:08 +0200 Subject: [PATCH 19/23] add cblas_sgemmtr tests --- BLAS/SRC/sgemmtr.f | 3 +- CBLAS/src/cblas_dgemmtr.c | 8 +- CBLAS/src/cblas_sgemmtr.c | 209 +++++++------ CBLAS/testing/c_sblas3.c | 2 +- CBLAS/testing/c_sblat3.f | 616 ++++++++++++++++++++++++++++++++++---- CBLAS/testing/sin3 | 13 +- 6 files changed, 677 insertions(+), 174 deletions(-) diff --git a/BLAS/SRC/sgemmtr.f b/BLAS/SRC/sgemmtr.f index 053075f2ff..1f0ed17bf4 100644 --- a/BLAS/SRC/sgemmtr.f +++ b/BLAS/SRC/sgemmtr.f @@ -272,8 +272,7 @@ SUBROUTINE SGEMMTR(UPLO,TRANSA,TRANSB,N,K,ALPHA,A,LDA,B,LDB, * * Quick return if possible. * - IF ((N.EQ.0) .OR. - + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN + IF (N.EQ.0) RETURN * * And if alpha.eq.zero. * diff --git a/CBLAS/src/cblas_dgemmtr.c b/CBLAS/src/cblas_dgemmtr.c index ac605e31db..d64c664ba2 100644 --- a/CBLAS/src/cblas_dgemmtr.c +++ b/CBLAS/src/cblas_dgemmtr.c @@ -1,9 +1,9 @@ /* * - * cblas_dgemm.c - * This program is a C interface to dgemm. - * Written by Keita Teranishi - * 4/8/1998 + * cblas_dgemmtr.c + * This program is a C interface to dgemmtr. + * Written by Martin Koehler, MPI Magdeburg + * 06/24/2024 * */ diff --git a/CBLAS/src/cblas_sgemmtr.c b/CBLAS/src/cblas_sgemmtr.c index f2f9528ee9..065a031bec 100644 --- a/CBLAS/src/cblas_sgemmtr.c +++ b/CBLAS/src/cblas_sgemmtr.c @@ -1,123 +1,136 @@ + /* * - * cblas_sgemm.c - * This program is a C interface to sgemm. - * Written by Keita Teranishi - * 4/8/1998 + * cblas_sgemmtr.c + * This program is a C interface to sgemmtr. + * Written by Martin Koehler, MPI Magdeburg + * 06/24/2024 * */ #include "cblas.h" #include "cblas_f77.h" void API_SUFFIX(cblas_sgemmtr)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, - const CBLAS_TRANSPOSE TransB, const CBLAS_INT N, - const CBLAS_INT K, const float alpha, const float *A, - const CBLAS_INT lda, const float *B, const CBLAS_INT ldb, - const float beta, float *C, const CBLAS_INT ldc) + const CBLAS_TRANSPOSE TransB, const CBLAS_INT N, + const CBLAS_INT K, const float alpha, const float *A, + const CBLAS_INT lda, const float *B, const CBLAS_INT ldb, + const float beta, float *C, const CBLAS_INT ldc) { - char TA, TB, UL; + char TA, TB, UL; #ifdef F77_CHAR - F77_CHAR F77_TA, F77_TB, F77_UL; + F77_CHAR F77_TA, F77_TB, F77_UL; #else - #define F77_TA &TA - #define F77_TB &TB - #define F77_UL &UL +#define F77_TA &TA +#define F77_TB &TB +#define F77_UL &UL #endif #ifdef F77_INT - F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; - F77_INT F77_ldc=ldc; + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; #else - #define F77_N N - #define F77_K K - #define F77_lda lda - #define F77_ldb ldb - #define F77_ldc ldc +#define F77_N N +#define F77_K K +#define F77_lda lda +#define F77_ldb ldb +#define F77_ldc ldc #endif - extern int CBLAS_CallFromC; - extern int RowMajorStrg; - RowMajorStrg = 0; - CBLAS_CallFromC = 1; + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + + if( layout == CblasColMajor ) + { + if ( Uplo == CblasUpper ) UL = 'U'; + else if (Uplo == CblasLower) UL= 'L'; + else { + API_SUFFIX(cblas_xerbla)(2, "cblas_sgemmtr", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + - if ( Uplo == CblasUpper ) UL = 'U'; - else if (Uplo == CblasLower) UL= 'L'; - else { - API_SUFFIX(cblas_xerbla)(2, "cblas_sgemmtr", "Illegal Uplo setting, %d\n", Uplo); - CBLAS_CallFromC = 0; - RowMajorStrg = 0; - return; - } + if(TransA == CblasTrans) TA='T'; + else if ( TransA == CblasConjTrans ) TA='C'; + else if ( TransA == CblasNoTrans ) TA='N'; + else + { + API_SUFFIX(cblas_xerbla)(3, "cblas_sgemmtr", + "Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(TransB == CblasTrans) TB='T'; + else if ( TransB == CblasConjTrans ) TB='C'; + else if ( TransB == CblasNoTrans ) TB='N'; + else + { + API_SUFFIX(cblas_xerbla)(4, "cblas_sgemmtr", + "Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } - if( layout == CblasColMajor ) - { - if(TransA == CblasTrans) TA='T'; - else if ( TransA == CblasConjTrans ) TA='C'; - else if ( TransA == CblasNoTrans ) TA='N'; - else - { - API_SUFFIX(cblas_xerbla)(3, "cblas_sgemmtr", - "Illegal TransA setting, %d\n", TransA); - CBLAS_CallFromC = 0; - RowMajorStrg = 0; - return; - } +#ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + F77_UL = C2F_CHAR(&UL); +#endif - if(TransB == CblasTrans) TB='T'; - else if ( TransB == CblasConjTrans ) TB='C'; - else if ( TransB == CblasNoTrans ) TB='N'; - else - { - API_SUFFIX(cblas_xerbla)(4, "cblas_sgemmtr", - "Illegal TransB setting, %d\n", TransB); - CBLAS_CallFromC = 0; - RowMajorStrg = 0; - return; - } + F77_sgemmtr(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, &alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); + } + else if (layout == CblasRowMajor) + { + if ( Uplo == CblasUpper ) UL = 'L'; + else if (Uplo == CblasLower) UL= 'U'; + else { + API_SUFFIX(cblas_xerbla)(2, "cblas_sgemmtr", "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } - #ifdef F77_CHAR - F77_TA = C2F_CHAR(&TA); - F77_TB = C2F_CHAR(&TB); - F77_UL = C2F_CHAR(&UL); - #endif - F77_sgemmtr(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, &alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); - } else if (layout == CblasRowMajor) - { - RowMajorStrg = 1; - if(TransA == CblasTrans) TB='T'; - else if ( TransA == CblasConjTrans ) TB='C'; - else if ( TransA == CblasNoTrans ) TB='N'; - else - { - API_SUFFIX(cblas_xerbla)(3, "cblas_sgemmtr", - "Illegal TransA setting, %d\n", TransA); - CBLAS_CallFromC = 0; - RowMajorStrg = 0; - return; - } - if(TransB == CblasTrans) TA='T'; - else if ( TransB == CblasConjTrans ) TA='C'; - else if ( TransB == CblasNoTrans ) TA='N'; - else - { - API_SUFFIX(cblas_xerbla)(4, "cblas_sgemmtr", - "Illegal TransB setting, %d\n", TransB); - CBLAS_CallFromC = 0; - RowMajorStrg = 0; - return; - } - #ifdef F77_CHAR - F77_TA = C2F_CHAR(&TA); - F77_TB = C2F_CHAR(&TB); - F77_UL = C2F_CHAR(&UL); - #endif + RowMajorStrg = 1; + if(TransA == CblasTrans) TB='T'; + else if ( TransA == CblasConjTrans ) TB='C'; + else if ( TransA == CblasNoTrans ) TB='N'; + else + { + API_SUFFIX(cblas_xerbla)(3, "cblas_sgemmtr", + "Illegal TransA setting, %d\n", TransA); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if(TransB == CblasTrans) TA='T'; + else if ( TransB == CblasConjTrans ) TA='C'; + else if ( TransB == CblasNoTrans ) TA='N'; + else + { + API_SUFFIX(cblas_xerbla)(4, "cblas_sgemmtr", + "Illegal TransB setting, %d\n", TransB); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } +#ifdef F77_CHAR + F77_TA = C2F_CHAR(&TA); + F77_TB = C2F_CHAR(&TB); + F77_UL = C2F_CHAR(&UL); +#endif - F77_sgemmtr(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, &alpha, B, &F77_ldb, A, &F77_lda, &beta, C, &F77_ldc); - } else - API_SUFFIX(cblas_xerbla)(1, "cblas_sgemmtr", - "Illegal layout setting, %d\n", layout); - CBLAS_CallFromC = 0; - RowMajorStrg = 0; + F77_sgemmtr(F77_UL, F77_TA, F77_TB, &F77_N, &F77_K, &alpha, B, &F77_ldb, A, &F77_lda, &beta, C, &F77_ldc); + } else + API_SUFFIX(cblas_xerbla)(1, "cblas_sgemmtr", + "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; } diff --git a/CBLAS/testing/c_sblas3.c b/CBLAS/testing/c_sblas3.c index 5a0744e116..0aaa57d2d8 100644 --- a/CBLAS/testing/c_sblas3.c +++ b/CBLAS/testing/c_sblas3.c @@ -75,7 +75,7 @@ void F77_sgemm(CBLAS_INT *layout, char *transpa, char *transpb, CBLAS_INT *m, CB b, *ldb, *beta, c, *ldc ); } -void F77_cgemmtr(CBLAS_INT *layout, char *uplop, char *transpa, char *transpb, CBLAS_INT *n, +void F77_sgemmtr(CBLAS_INT *layout, char *uplop, char *transpa, char *transpb, CBLAS_INT *n, CBLAS_INT *k, float *alpha, float *a, CBLAS_INT *lda, float *b, CBLAS_INT *ldb, float *beta, float *c, CBLAS_INT *ldc ) { diff --git a/CBLAS/testing/c_sblat3.f b/CBLAS/testing/c_sblat3.f index 31babd9a12..c6f6961900 100644 --- a/CBLAS/testing/c_sblat3.f +++ b/CBLAS/testing/c_sblat3.f @@ -4,7 +4,7 @@ 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 @@ -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 @@ -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 @@ -396,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, @@ -404,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' ) @@ -435,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 ), @@ -681,20 +699,20 @@ 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:' ) - 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',', + 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 *', @@ -711,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 @@ -736,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 @@ -763,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 ), @@ -998,20 +1016,20 @@ 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:' ) - 9995 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), + 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 *', @@ -1026,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 @@ -1047,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 @@ -1073,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 ), @@ -1346,20 +1364,20 @@ 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:' ) - 9995 FORMAT( 1X, I6, ': ', A12,'(', 4( '''', A1, ''',' ), 2( 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 *', $ '******' ) @@ -1373,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 @@ -1406,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 @@ -1433,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 ), @@ -1672,21 +1690,21 @@ 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 ) - 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( 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 *', $ '******' ) @@ -1700,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 @@ -1723,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 @@ -1750,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 ), @@ -2027,21 +2045,21 @@ 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 ) - 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), + 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 *', @@ -2056,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 @@ -2079,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 @@ -2478,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/CBLAS/testing/sin3 b/CBLAS/testing/sin3 index aa18530cb4..f332c8a9e0 100644 --- a/CBLAS/testing/sin3 +++ b/CBLAS/testing/sin3 @@ -11,9 +11,10 @@ T LOGICAL FLAG, T TO TEST ERROR EXITS. 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. From 85717807e9bb33151ae2f33d3aea03f8c6156647 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20K=C3=B6hler?= Date: Mon, 24 Jun 2024 15:12:49 +0200 Subject: [PATCH 20/23] Working error tests on cblas_cgemmtr --- CBLAS/testing/c_c3chke.c | 188 ++++++++++++++++++++------------------- CBLAS/testing/c_xerbla.c | 13 ++- 2 files changed, 104 insertions(+), 97 deletions(-) diff --git a/CBLAS/testing/c_c3chke.c b/CBLAS/testing/c_c3chke.c index 4479469a2f..2f48430b69 100644 --- a/CBLAS/testing/c_c3chke.c +++ b/CBLAS/testing/c_c3chke.c @@ -55,235 +55,238 @@ void F77_c3chke(char * rout } #endif - if (strncmp( sf,"cblas_cgemm" ,11)==0) { - cblas_rout = "cblas_cgemm" ; + if (strncmp( sf,"cblas_cgemmtr" ,13)==0) { + cblas_rout = "cblas_cgemmtr" ; cblas_info = 1; - cblas_cgemm( INVALID, CblasNoTrans, CblasNoTrans, 0, 0, 0, + cblas_cgemmtr( INVALID, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 1; - cblas_cgemm( INVALID, CblasNoTrans, CblasTrans, 0, 0, 0, + cblas_cgemmtr( INVALID, CblasUpper, CblasNoTrans, CblasTrans, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 1; - cblas_cgemm( INVALID, CblasTrans, CblasNoTrans, 0, 0, 0, + cblas_cgemmtr( INVALID, CblasUpper,CblasTrans, CblasNoTrans, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 1; - cblas_cgemm( INVALID, CblasTrans, CblasTrans, 0, 0, 0, + cblas_cgemmtr( INVALID, CblasUpper, CblasTrans, CblasTrans, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); - cblas_info = 2; RowMajorStrg = FALSE; - cblas_cgemm( CblasColMajor, INVALID, CblasNoTrans, 0, 0, 0, + + cblas_info = 1; + cblas_cgemmtr( INVALID, CblasLower, CblasNoTrans, CblasNoTrans, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); - cblas_info = 2; RowMajorStrg = FALSE; - cblas_cgemm( CblasColMajor, INVALID, CblasTrans, 0, 0, 0, + cblas_info = 1; + cblas_cgemmtr( INVALID, CblasLower, CblasNoTrans, CblasTrans, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); - cblas_info = 3; RowMajorStrg = FALSE; - cblas_cgemm( CblasColMajor, CblasNoTrans, INVALID, 0, 0, 0, + cblas_info = 1; + cblas_cgemmtr( INVALID, CblasLower,CblasTrans, CblasNoTrans, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); - cblas_info = 3; RowMajorStrg = FALSE; - cblas_cgemm( CblasColMajor, CblasTrans, INVALID, 0, 0, 0, + cblas_info = 1; + cblas_cgemmtr( INVALID, CblasLower, CblasTrans, CblasTrans, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); - cblas_info = 4; RowMajorStrg = FALSE; - cblas_cgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, INVALID, 0, 0, + + cblas_info = 2; RowMajorStrg = FALSE; + cblas_cgemmtr( CblasColMajor, INVALID, CblasNoTrans, CblasNoTrans, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); - cblas_info = 4; RowMajorStrg = FALSE; - cblas_cgemm( CblasColMajor, CblasNoTrans, CblasTrans, INVALID, 0, 0, + cblas_info = 2; RowMajorStrg = FALSE; + cblas_cgemmtr( CblasColMajor, INVALID, CblasNoTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 3; RowMajorStrg = FALSE; + cblas_cgemmtr( CblasColMajor, CblasUpper, INVALID, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_cgemmtr( CblasColMajor, CblasUpper, INVALID, CblasTrans, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; - cblas_cgemm( CblasColMajor, CblasTrans, CblasNoTrans, INVALID, 0, 0, + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 4; RowMajorStrg = FALSE; - cblas_cgemm( CblasColMajor, CblasTrans, CblasTrans, INVALID, 0, 0, + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, INVALID, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); + + cblas_info = 5; RowMajorStrg = FALSE; - cblas_cgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 0, INVALID, 0, + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, INVALID, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = FALSE; - cblas_cgemm( CblasColMajor, CblasNoTrans, CblasTrans, 0, INVALID, 0, + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, INVALID, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = FALSE; - cblas_cgemm( CblasColMajor, CblasTrans, CblasNoTrans, 0, INVALID, 0, + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, INVALID, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = FALSE; - cblas_cgemm( CblasColMajor, CblasTrans, CblasTrans, 0, INVALID, 0, + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, INVALID, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; - cblas_cgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 0, 0, INVALID, + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, INVALID, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = FALSE; - cblas_cgemm( CblasColMajor, CblasNoTrans, CblasTrans, 0, 0, INVALID, + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, INVALID, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = FALSE; - cblas_cgemm( CblasColMajor, CblasTrans, CblasNoTrans, 0, 0, INVALID, + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, INVALID, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = FALSE; - cblas_cgemm( CblasColMajor, CblasTrans, CblasTrans, 0, 0, INVALID, + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 0, INVALID, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); + + cblas_info = 9; RowMajorStrg = FALSE; - cblas_cgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 2, 0, 0, + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ); chkxer(); cblas_info = 9; RowMajorStrg = FALSE; - cblas_cgemm( CblasColMajor, CblasNoTrans, CblasTrans, 2, 0, 0, + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ); chkxer(); cblas_info = 9; RowMajorStrg = FALSE; - cblas_cgemm( CblasColMajor, CblasTrans, CblasNoTrans, 0, 0, 2, + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = FALSE; - cblas_cgemm( CblasColMajor, CblasTrans, CblasTrans, 0, 0, 2, + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; - cblas_cgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 0, 0, 2, + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 11; RowMajorStrg = FALSE; - cblas_cgemm( CblasColMajor, CblasTrans, CblasNoTrans, 0, 0, 2, + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 11; RowMajorStrg = FALSE; - cblas_cgemm( CblasColMajor, CblasNoTrans, CblasTrans, 0, 2, 0, - ALPHA, A, 1, B, 1, BETA, C, 1 ); - chkxer(); - cblas_info = 11; RowMajorStrg = FALSE; - cblas_cgemm( CblasColMajor, CblasTrans, CblasTrans, 0, 2, 0, + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; - cblas_cgemm( CblasColMajor, CblasNoTrans, CblasNoTrans, 2, 0, 0, + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 14; RowMajorStrg = FALSE; - cblas_cgemm( CblasColMajor, CblasNoTrans, CblasTrans, 2, 0, 0, - ALPHA, A, 2, B, 1, BETA, C, 1 ); + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; - cblas_cgemm( CblasColMajor, CblasTrans, CblasNoTrans, 2, 0, 0, - ALPHA, A, 1, B, 1, BETA, C, 1 ); + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 14; RowMajorStrg = FALSE; - cblas_cgemm( CblasColMajor, CblasTrans, CblasTrans, 2, 0, 0, - ALPHA, A, 1, B, 1, BETA, C, 1 ); - chkxer(); - cblas_info = 4; RowMajorStrg = TRUE; - cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, INVALID, 0, 0, - ALPHA, A, 1, B, 1, BETA, C, 1 ); - chkxer(); - cblas_info = 4; RowMajorStrg = TRUE; - cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasTrans, INVALID, 0, 0, - ALPHA, A, 1, B, 1, BETA, C, 1 ); - chkxer(); - cblas_info = 4; RowMajorStrg = TRUE; - cblas_cgemm( CblasRowMajor, CblasTrans, CblasNoTrans, INVALID, 0, 0, - ALPHA, A, 1, B, 1, BETA, C, 1 ); - chkxer(); - cblas_info = 4; RowMajorStrg = TRUE; - cblas_cgemm( CblasRowMajor, CblasTrans, CblasTrans, INVALID, 0, 0, - ALPHA, A, 1, B, 1, BETA, C, 1 ); + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); chkxer(); + + /* Row Major */ cblas_info = 5; RowMajorStrg = TRUE; - cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, INVALID, 0, + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, INVALID, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = TRUE; - cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, INVALID, 0, + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, INVALID, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = TRUE; - cblas_cgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 0, INVALID, 0, + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, INVALID, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 5; RowMajorStrg = TRUE; - cblas_cgemm( CblasRowMajor, CblasTrans, CblasTrans, 0, INVALID, 0, + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, INVALID, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; - cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, 0, INVALID, + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, INVALID, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = TRUE; - cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, 0, INVALID, + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, INVALID, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = TRUE; - cblas_cgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 0, 0, INVALID, + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, INVALID, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 6; RowMajorStrg = TRUE; - cblas_cgemm( CblasRowMajor, CblasTrans, CblasTrans, 0, 0, INVALID, + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 0, INVALID, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; - cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, 0, 2, + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 2 ); chkxer(); cblas_info = 9; RowMajorStrg = TRUE; - cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, 0, 2, + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 2 ); chkxer(); cblas_info = 9; RowMajorStrg = TRUE; - cblas_cgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 2, 0, 0, + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ); chkxer(); cblas_info = 9; RowMajorStrg = TRUE; - cblas_cgemm( CblasRowMajor, CblasTrans, CblasTrans, 2, 0, 0, + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; - cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, 2, 0, + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 11; RowMajorStrg = TRUE; - cblas_cgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 0, 2, 0, - ALPHA, A, 2, B, 1, BETA, C, 1 ); - chkxer(); - cblas_info = 11; RowMajorStrg = TRUE; - cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, 0, 2, + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 11; RowMajorStrg = TRUE; - cblas_cgemm( CblasRowMajor, CblasTrans, CblasTrans, 0, 0, 2, + cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; - cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 0, 2, 0, - ALPHA, A, 1, B, 2, BETA, C, 1 ); + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); chkxer(); cblas_info = 14; RowMajorStrg = TRUE; - cblas_cgemm( CblasRowMajor, CblasNoTrans, CblasTrans, 0, 2, 0, - ALPHA, A, 1, B, 1, BETA, C, 1 ); + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); chkxer(); cblas_info = 14; RowMajorStrg = TRUE; - cblas_cgemm( CblasRowMajor, CblasTrans, CblasNoTrans, 0, 2, 0, - ALPHA, A, 1, B, 2, BETA, C, 1 ); + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); chkxer(); cblas_info = 14; RowMajorStrg = TRUE; - cblas_cgemm( CblasRowMajor, CblasTrans, CblasTrans, 0, 2, 0, - ALPHA, A, 1, B, 1, BETA, C, 1 ); + cblas_cgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); chkxer(); - } else if (strncmp( sf,"cblas_cgemmtr" ,12)==0) { - cblas_rout = "cblas_cgemmtr" ; + + } else if (strncmp( sf,"cblas_cgemm" ,11)==0) { + cblas_rout = "cblas_cgemm" ; cblas_info = 1; cblas_cgemm( INVALID, CblasNoTrans, CblasNoTrans, 0, 0, 0, @@ -509,7 +512,6 @@ void F77_c3chke(char * rout cblas_cgemm( CblasRowMajor, CblasTrans, CblasTrans, 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); - } else if (strncmp( sf,"cblas_chemm" ,11)==0) { cblas_rout = "cblas_chemm" ; @@ -1937,7 +1939,7 @@ void F77_c3chke(char * rout } if (cblas_ok == 1 ) - printf(" %-12s PASSED THE TESTS OF ERROR-EXITS\n", cblas_rout); + printf(" %-13s PASSED THE TESTS OF ERROR-EXITS\n", cblas_rout); else printf("***** %s FAILED THE TESTS OF ERROR-EXITS *******\n",cblas_rout); } diff --git a/CBLAS/testing/c_xerbla.c b/CBLAS/testing/c_xerbla.c index a3ce836e7d..2af45f4a4c 100644 --- a/CBLAS/testing/c_xerbla.c +++ b/CBLAS/testing/c_xerbla.c @@ -33,13 +33,18 @@ void cblas_xerbla(CBLAS_INT info, const char *rout, const char *form, ...) * for A and B, lda is in position 11 instead of 9, and ldb is in * position 9 instead of 11. */ - if (strstr(rout,"gemm") != 0) + if (strstr(rout,"gemm") != 0 && strstr(rout, "gemmtr") == 0) { if (info == 5 ) info = 4; else if (info == 4 ) info = 5; else if (info == 11) info = 9; else if (info == 9 ) info = 11; + } else if (strstr(rout, "gemmtr") != 0) + { + if (info == 11) info = 9; + else if (info == 9 ) info = 11; } + else if (strstr(rout,"symm") != 0 || strstr(rout,"hemm") != 0) { if (info == 5 ) info = 4; @@ -98,7 +103,7 @@ void F77_xerbla(char *srname, void *vinfo char *srname; #endif - char rout[] = {'c','b','l','a','s','_','\0','\0','\0','\0','\0','\0','\0'}; + char rout[] = {'c','b','l','a','s','_','\0','\0','\0','\0','\0','\0','\0', '\0'}; #ifdef F77_Integer F77_Integer *info=vinfo; @@ -119,8 +124,8 @@ void F77_xerbla(char *srname, void *vinfo link_xerbla = 0; return; } - for(i=0; i < 6; i++) rout[i+6] = tolower(srname[i]); - for(i=11; i >= 9; i--) if (rout[i] == ' ') rout[i] = '\0'; + for(i=0; i < 7; i++) rout[i+6] = tolower(srname[i]); + for(i=12; i >= 9; i--) if (rout[i] == ' ') rout[i] = '\0'; /* We increment *info by 1 since the CBLAS interface adds one more * argument to all level 2 and 3 routines. From 34adaba0e6829c3cc43cda4aba6e78c44ac93b8b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20K=C3=B6hler?= Date: Mon, 24 Jun 2024 15:18:22 +0200 Subject: [PATCH 21/23] Add tests for cblas_s/d/zgemmtr --- CBLAS/testing/c_d3chke.c | 234 ++++++++++++++++++++++++++++++++++++++- CBLAS/testing/c_s3chke.c | 234 ++++++++++++++++++++++++++++++++++++++- CBLAS/testing/c_z3chke.c | 233 +++++++++++++++++++++++++++++++++++++- 3 files changed, 695 insertions(+), 6 deletions(-) diff --git a/CBLAS/testing/c_d3chke.c b/CBLAS/testing/c_d3chke.c index f8919bf92d..6d27bc6cfc 100644 --- a/CBLAS/testing/c_d3chke.c +++ b/CBLAS/testing/c_d3chke.c @@ -53,7 +53,237 @@ void F77_d3chke(char *rout cblas_ok = TRUE ; cblas_lerr = PASSED ; - if (strncmp( sf,"cblas_dgemm" ,11)==0) { + if (strncmp( sf,"cblas_dgemmtr" ,13)==0) { + cblas_rout = "cblas_dgemmtr" ; + + cblas_info = 1; + cblas_dgemmtr( INVALID, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_dgemmtr( INVALID, CblasUpper, CblasNoTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_dgemmtr( INVALID, CblasUpper,CblasTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_dgemmtr( INVALID, CblasUpper, CblasTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 1; + cblas_dgemmtr( INVALID, CblasLower, CblasNoTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_dgemmtr( INVALID, CblasLower, CblasNoTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_dgemmtr( INVALID, CblasLower,CblasTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_dgemmtr( INVALID, CblasLower, CblasTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, INVALID, CblasNoTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, INVALID, CblasNoTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, INVALID, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, INVALID, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + + cblas_info = 9; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 11; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 14; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + + cblas_info = 14; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + + /* Row Major */ + cblas_info = 5; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 9; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 11; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 14; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_dgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_dgemm" ,11)==0) { cblas_rout = "cblas_dgemm" ; cblas_info = 1; @@ -1275,7 +1505,7 @@ void F77_d3chke(char *rout chkxer(); } if (cblas_ok == TRUE ) - printf(" %-12s PASSED THE TESTS OF ERROR-EXITS\n", cblas_rout); + printf(" %-13s PASSED THE TESTS OF ERROR-EXITS\n", cblas_rout); else printf("***** %s FAILED THE TESTS OF ERROR-EXITS *******\n",cblas_rout); } diff --git a/CBLAS/testing/c_s3chke.c b/CBLAS/testing/c_s3chke.c index f9772bf813..2009e388af 100644 --- a/CBLAS/testing/c_s3chke.c +++ b/CBLAS/testing/c_s3chke.c @@ -53,7 +53,237 @@ void F77_s3chke(char *rout cblas_ok = TRUE ; cblas_lerr = PASSED ; - if (strncmp( sf,"cblas_sgemm" ,11)==0) { + if (strncmp( sf,"cblas_sgemmtr" ,13)==0) { + cblas_rout = "cblas_sgemmtr" ; + + cblas_info = 1; + cblas_sgemmtr( INVALID, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_sgemmtr( INVALID, CblasUpper, CblasNoTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_sgemmtr( INVALID, CblasUpper,CblasTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_sgemmtr( INVALID, CblasUpper, CblasTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 1; + cblas_sgemmtr( INVALID, CblasLower, CblasNoTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_sgemmtr( INVALID, CblasLower, CblasNoTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_sgemmtr( INVALID, CblasLower,CblasTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_sgemmtr( INVALID, CblasLower, CblasTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 2; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, INVALID, CblasNoTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, INVALID, CblasNoTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 3; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, INVALID, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, INVALID, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 4; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + + cblas_info = 5; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 6; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + + cblas_info = 9; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 11; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 14; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + + cblas_info = 14; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + + /* Row Major */ + cblas_info = 5; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 6; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 9; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 11; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 14; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_sgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_sgemm" ,11)==0) { cblas_rout = "cblas_sgemm" ; cblas_info = 1; cblas_sgemm( INVALID, CblasNoTrans, CblasNoTrans, 0, 0, 0, @@ -1277,7 +1507,7 @@ void F77_s3chke(char *rout chkxer(); } if (cblas_ok == TRUE ) - printf(" %-12s PASSED THE TESTS OF ERROR-EXITS\n", cblas_rout); + printf(" %-13s PASSED THE TESTS OF ERROR-EXITS\n", cblas_rout); else printf("***** %s FAILED THE TESTS OF ERROR-EXITS *******\n",cblas_rout); } diff --git a/CBLAS/testing/c_z3chke.c b/CBLAS/testing/c_z3chke.c index 113b054d97..72c960735f 100644 --- a/CBLAS/testing/c_z3chke.c +++ b/CBLAS/testing/c_z3chke.c @@ -54,8 +54,237 @@ void F77_z3chke(char *rout F77_xerbla(cblas_rout,&cblas_info, 1); } #endif + if (strncmp( sf,"cblas_zgemmtr" ,13)==0) { + cblas_rout = "cblas_zgemmtr" ; - if (strncmp( sf,"cblas_zgemm" ,11)==0) { + cblas_info = 1; + cblas_zgemmtr( INVALID, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_zgemmtr( INVALID, CblasUpper, CblasNoTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_zgemmtr( INVALID, CblasUpper,CblasTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_zgemmtr( INVALID, CblasUpper, CblasTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 1; + cblas_zgemmtr( INVALID, CblasLower, CblasNoTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_zgemmtr( INVALID, CblasLower, CblasNoTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_zgemmtr( INVALID, CblasLower,CblasTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 1; + cblas_zgemmtr( INVALID, CblasLower, CblasTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 2; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, INVALID, CblasNoTrans, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, INVALID, CblasNoTrans, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 3; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, INVALID, CblasNoTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, INVALID, CblasTrans, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 6; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + + cblas_info = 9; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 11; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 14; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + + cblas_info = 14; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = FALSE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + + /* Row Major */ + cblas_info = 5; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 6; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 9; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 9; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 11; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasNoTrans, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasColMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + + cblas_info = 14; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasNoTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasNoTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 14; RowMajorStrg = TRUE; + cblas_zgemmtr( CblasRowMajor, CblasUpper, CblasTrans, CblasTrans, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + + } else if (strncmp( sf,"cblas_zgemm" ,11)==0) { cblas_rout = "cblas_zgemm" ; cblas_info = 1; @@ -1710,7 +1939,7 @@ void F77_z3chke(char *rout } if (cblas_ok == 1 ) - printf(" %-12s PASSED THE TESTS OF ERROR-EXITS\n", cblas_rout); + printf(" %-13s PASSED THE TESTS OF ERROR-EXITS\n", cblas_rout); else printf("***** %s FAILED THE TESTS OF ERROR-EXITS *******\n",cblas_rout); } From 0e37c5cc375ce6ab46e958c076ba6fe3faed7881 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20K=C3=B6hler?= Date: Mon, 24 Jun 2024 15:35:14 +0200 Subject: [PATCH 22/23] Fix CMake Build --- CBLAS/src/CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CBLAS/src/CMakeLists.txt b/CBLAS/src/CMakeLists.txt index 2979d91a6d..8dcb2f2931 100644 --- a/CBLAS/src/CMakeLists.txt +++ b/CBLAS/src/CMakeLists.txt @@ -89,7 +89,7 @@ set(SLEV3 cblas_sgemm.c cblas_ssymm.c cblas_ssyrk.c cblas_ssyr2k.c cblas_strmm.c # Files for level 3 double precision real set(DLEV3 cblas_dgemm.c cblas_dsymm.c cblas_dsyrk.c cblas_dsyr2k.c cblas_dtrmm.c - cblas_dtrsm.c cblas_cgemmtr.c) + cblas_dtrsm.c cblas_dgemmtr.c) # Files for level 3 single precision complex set(CLEV3 cblas_cgemm.c cblas_csymm.c cblas_chemm.c cblas_cherk.c From c57c156bd10eb7923a24dfe3ef664c4f90034dce Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20K=C3=B6hler?= Date: Thu, 27 Jun 2024 14:01:49 +0200 Subject: [PATCH 23/23] Add gemmtr group to Doxygen updated: * BLAS/SRC/sgemmtr.f * BLAS/SRC/zgemmtr.f * BLAS/SRC/cgemmtr.f * BLAS/SRC/dgemmtr.f --- BLAS/SRC/cgemmtr.f | 2 +- BLAS/SRC/dgemmtr.f | 2 +- BLAS/SRC/sgemmtr.f | 2 +- BLAS/SRC/zgemmtr.f | 2 +- DOCS/groups-usr.dox | 2 ++ 5 files changed, 6 insertions(+), 4 deletions(-) diff --git a/BLAS/SRC/cgemmtr.f b/BLAS/SRC/cgemmtr.f index 84bd22277c..68063cbdaf 100644 --- a/BLAS/SRC/cgemmtr.f +++ b/BLAS/SRC/cgemmtr.f @@ -172,7 +172,7 @@ * *> \author Martin Koehler * -*> \ingroup gemm +*> \ingroup gemmtr * *> \par Further Details: * ===================== diff --git a/BLAS/SRC/dgemmtr.f b/BLAS/SRC/dgemmtr.f index acaaa351e0..74e0ce0dac 100644 --- a/BLAS/SRC/dgemmtr.f +++ b/BLAS/SRC/dgemmtr.f @@ -172,7 +172,7 @@ * *> \author Martin Koehler * -*> \ingroup gemm +*> \ingroup gemmtr * *> \par Further Details: * ===================== diff --git a/BLAS/SRC/sgemmtr.f b/BLAS/SRC/sgemmtr.f index 1f0ed17bf4..1aeff65e03 100644 --- a/BLAS/SRC/sgemmtr.f +++ b/BLAS/SRC/sgemmtr.f @@ -172,7 +172,7 @@ * *> \author Martin Koehler * -*> \ingroup gemm +*> \ingroup gemmtr * *> \par Further Details: * ===================== diff --git a/BLAS/SRC/zgemmtr.f b/BLAS/SRC/zgemmtr.f index 5907a4d532..9f30488021 100644 --- a/BLAS/SRC/zgemmtr.f +++ b/BLAS/SRC/zgemmtr.f @@ -172,7 +172,7 @@ * *> \author Martin Koehler * -*> \ingroup gemm +*> \ingroup gemmtr * *> \par Further Details: * ===================== diff --git a/DOCS/groups-usr.dox b/DOCS/groups-usr.dox index cbd7471657..0234f83d96 100644 --- a/DOCS/groups-usr.dox +++ b/DOCS/groups-usr.dox @@ -961,6 +961,8 @@ https://www.netlib.org/xblas/ @defgroup blas3_grp Level 3 BLAS: matrix-matrix ops @{ @defgroup gemm gemm: general matrix-matrix multiply + @defgroup gemmtr gemmtr: general matrix-matrix multiply with triangular output + @defgroup hemm {he,sy}mm: Hermitian/symmetric matrix-matrix multiply @defgroup herk {he,sy}rk: Hermitian/symmetric rank-k update