change conj to conjg

Remove comparison as these conditions are never true

.github/workflows/cmake.yml

@@ -75,12 +75,12 @@ jobs:
     - name: Install ninja-build tool
       uses: seanmiddleditch/gha-setup-ninja@16b940825621068d98711680b6c3ff92201f8fc0 # v3
 
-    - name: Use GCC-11 on MacOS
+    - name: Use GCC-14 on MacOS
       if: ${{ matrix.os == 'macos-latest' }}
       run: >
         cmake -B build -G Ninja
-        -D CMAKE_C_COMPILER="gcc-11"
-        -D CMAKE_Fortran_COMPILER="gfortran-11"
+        -D CMAKE_C_COMPILER="gcc-14"
+        -D CMAKE_Fortran_COMPILER="gfortran-14"
         -D USE_FLAT_NAMESPACE:BOOL=ON
 
     - name: Special flags for Windows
@@ -237,4 +237,4 @@ jobs:
             fi
           done
           exit 0
-        fi
+        fi

.github/workflows/makefile.yml

@@ -90,8 +90,8 @@ jobs:
         echo "DOCSDIR = ${{github.workspace}}/DOCS" >> make.inc
     - name: Alias for GCC compilers
       run: |
-        sudo ln -s $(which gcc-11) /usr/local/bin/gcc
-        sudo ln -s $(which gfortran-11) /usr/local/bin/gfortran
+        sudo ln -s $(which gcc-14) /usr/local/bin/gcc
+        sudo ln -s $(which gfortran-14) /usr/local/bin/gfortran
     - name: Install
       run: |
         make -s -j2 all

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 sgemmtr.f srotc.f90)
 
 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 cgemmtr.f crotc.f90 scrotc.f90)
 
-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 dgemmtr.f drotc.f90)
 
 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 zgemmtr.f zrotc.f90 dzrotc.f90)
 
 
 set(SOURCES)

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 sgemmtr.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 cgemmtr.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 dgemmtr.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 zgemmtr.o
 $(ZBLAS3): $(FRC)
 
 ALLOBJ = $(SBLAS1) $(SBLAS2) $(SBLAS3) $(DBLAS1) $(DBLAS2) $(DBLAS3) \

BLAS/SRC/cgemmtr.f

@@ -0,0 +1,569 @@
+*> \brief \b CGEMMTR
+*
+*  =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+*            http://www.netlib.org/lapack/explore-html/
+*
+*  Definition:
+*  ===========
+*
+*       SUBROUTINE CGEMMTR(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
+*>
+*> CGEMMTR  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 if
+*> the resulting matrix C is known to be Hermitian or 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 gemmtr
+*
+*> \par Further Details:
+*  =====================
+*>
+*> \verbatim
+*>
+*>  Level 3 Blas routine.
+*>
+*>  -- Written on 19-July-2023.
+*>     Martin Koehler, MPI Magdeburg
+*> \endverbatim
+*>
+*  =====================================================================
+      SUBROUTINE CGEMMTR(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('CGEMMTR',INFO)
+          RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF (N.EQ.0) 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 CGEMMTR
+*
+      END

BLAS/SRC/crotc.f90

@@ -0,0 +1,256 @@
+!> \brief \b CROTC applies a chain of rotation sequences to a matrix.
+!
+!  =========== DOCUMENTATION ===========
+!
+! Online html documentation available at
+!            http://www.netlib.org/lapack/explore-html/
+!
+!  Definition:
+!  ===========
+!
+!   subroutine crotc(side, dir, startup, shutdown, m, n, k,&
+!                    A, lda, C, ldc, S, lds)
+!    .. Scalar Arguments ..
+!    integer, intent(in) :: m, n, k
+!    ...
+!
+!> \par Purpose:
+!  =============
+!>
+!> \verbatim
+!>
+!> CROTC applies a chain of k rotation sequences of length n to a matrix A.
+!>
+!> Each rotation is specified by a cosine and a sine, stored in the
+!> matrices C and S respectively. Rotation G(i,j) is formed by
+!> C(i,j) and S(i,j).
+!>
+!> If side = 'L', rotation G(i,j) is applied to rows i and i+1 of A.
+!> [ A(i,j)   ] = [  C(i,j)        S(i,j) ] [ A(i,j)   ]
+!> [ A(i+1,j) ]   [ -conjg(S(i,j))  C(i,j) ] [ A(i+1,j) ]
+!> If side = 'R', rotation G(i,j) is applied to columns j and j+1 of A.
+!> [ A(i,j)   A(i,j+1)   ] = [ A(i,j)   A(i,j+1)   ] [  C(i,j) -conjg(S(i,j)) ]
+!> [ A(i+1,j) A(i+1,j+1) ]   [ A(i+1,j) A(i+1,j+1) ] [  S(i,j)  C(i,j)       ]
+!>
+!> \endverbatim
+!
+!  Arguments:
+!  ==========
+!
+!> \param[in] side
+!> \verbatim
+!>          side is CHARACTER*1
+!>          If side = 'L', the rotations are applied to A from the left.
+!>          If side = 'R', the rotations are applied to A from the right.
+!> \endverbatim
+!>
+!> \param[in] dir
+!> \verbatim
+!>          dir is CHARACTER*1
+!>          If dir = 'F', the rotations are applied in sequence from the
+!>          first column/row to the last column/row.
+!>          If dir = 'B', the rotations are applied in sequence from the
+!>          last column/row to the first column/row.
+!> \endverbatim
+!>
+!> \param[in] startup
+!> \verbatim
+!>          startup is LOGICAL
+!>          If startup = .FALSE., the first (k-1) x (k-1) triangle
+!>          of rotations is not applied.
+!> \endverbatim
+!>
+!> \param[in] shutdown
+!> \verbatim
+!>          shutdown is LOGICAL
+!>          If shutdown = .FALSE., the last (k-1) x (k-1) triangle
+!>          of rotations is not applied.
+!> \endverbatim
+!>
+!> \param[in] m
+!> \verbatim
+!>          m is INTEGER
+!>          If side = 'L', m is the number of columns of A.
+!>          If side = 'R', m is the number of rows of A.
+!> \endverbatim
+!>
+!> \param[in] n
+!> \verbatim
+!>          n is INTEGER
+!>          The number of rotations in one sequence.
+!> \endverbatim
+!>
+!> \param[in] k
+!> \verbatim
+!>          k is INTEGER
+!>          The number of sequences of rotations.
+!> \endverbatim
+!>
+!> \param[in,out] A
+!> \verbatim
+!>          A is COMPLEX array
+!>          If side = 'L', A has dimension (n+1,m).
+!>          If side = 'R', A has dimension (m,n+1).
+!>          The matrix to which the rotations are applied.
+!> \endverbatim
+!>
+!> \param[in] lda
+!> \verbatim
+!>          lda is INTEGER
+!>          The leading dimension of A.
+!>          If side = 'L', lda >= n+1.
+!>          If side = 'R', lda >= m.
+!> \endverbatim
+!>
+!> \param[in,out] C
+!> \verbatim
+!>          C is REAL array, dimension (ldc,k)
+!>          The matrix containing the cosines of the rotations.
+!> \endverbatim
+!>
+!> \param[in] ldc
+!> \verbatim
+!>          ldc is INTEGER
+!>          The leading dimension of C.
+!>          ldc >= n.
+!> \endverbatim
+!>
+!> \param[in,out] S
+!> \verbatim
+!>          S is COMPLEX array, dimension (lds,k)
+!>          The matrix containing the sines of the rotations.
+!> \endverbatim
+!>
+!> \param[in] lds
+!> \verbatim
+!>          lds is INTEGER
+!>          The leading dimension of S.
+!>          lds >= n.
+!> \endverbatim
+!
+!  Authors:
+!  ========
+!
+!> \author Thijs Steel, KU Leuven, Belgium
+!
+!> \date October 2024
+!
+!> \ingroup rotc
+!
+subroutine crotc(side, dir, startup, shutdown, m, n, k,&
+    A, lda, C, ldc, S, lds)
+!    .. Scalar Arguments ..
+    integer, intent(in) :: m, n, k, lda, ldc, lds
+    character, intent(in) :: dir, side
+    logical, intent(in) :: startup, shutdown
+!    .. Array Arguments ..
+    complex, intent(inout) :: A(lda,*)
+    complex, intent(in) :: S(lds,*)
+    real, intent(in) :: C(ldc,*)
+!   .. Local Scalars ..
+    integer i, j, l, j1, j2, incj, incj1, incj2, info
+    complex temp, sn
+    real cs
+!    .. Executable Statements ..
+
+!   Test the input parameters
+    info = 0
+    if(.not. (side .eq. 'L' .or. side .eq. 'R')) then
+        info = 1
+    end if
+    if(.not. (dir .eq. 'F' .or. dir .eq. 'B')) then
+        info = 2
+    end if
+    if(m .lt. 0) then
+        info = 5
+    end if
+    if(n .lt. 0) then
+        info = 6
+    end if
+    if(k .lt. 0) then
+        info = 7
+    end if
+    if(side .eq. 'L') then
+        if(lda .lt. n+1) then
+            info = 9
+        end if
+    else
+        if(lda .lt. m) then
+            info = 9
+        end if
+    end if
+    if(ldc .lt. n) then
+        info = 11
+    end if
+    if(lds .lt. n) then
+        info = 13
+    end if
+
+    if(info .ne. 0) then
+        call xerbla('CROTC ', info)
+        return
+    end if
+
+!   Determine ranges for loops around C and S
+!   The range for sequence l is:
+!   j1+(l-1)*incj1:incj:j2+(l-1)*incj2
+    if( dir .eq. 'F') then
+        incj = 1
+        if(startup) then
+            j1 = 1
+            incj1 = 0
+        else
+            j1 = k
+            incj1 = -1
+        end if
+        j2 = n
+        if(shutdown) then
+            incj2 = 0
+        else
+            incj2 = -1
+        end if
+    else
+        incj = -1
+        j1 = 1
+        if(startup) then
+            incj1 = 1
+        else
+            incj1 = 0
+        end if
+        if(shutdown) then
+            j2 = 0
+            incj2 = 0
+        else
+            j2 = n-k+1
+            incj2 = 1
+        end if
+    end if
+
+!   Apply the rotations
+    if(side .eq. 'L') then
+        do l = 1, k
+            do j = j1+(l-1)*incj1, j2+(l-1)*incj2, incj
+                cs = C(j,l)
+                sn = S(j,l)
+                do i = 1, m
+                    temp = cs*A(i,j) + sn*A(i,j+1)
+                    A(i,j+1) = -conjg(sn*A(i,j)) + cs*A(i,j+1)
+                    A(i,j) = temp
+                end do
+            end do
+        end do
+    else
+        do l = 1, k
+            do j = j1+(l-1)*incj1, j2+(l-1)*incj2, incj
+                cs = C(l,j)
+                sn = S(l,j)
+                do i = 1, m
+                    temp = cs*A(j,i) + sn*A(j+1,i)
+                    A(j+1,i) = -conjg(sn*A(j,i)) + cs*A(j+1,i)
+                    A(j,i) = temp
+                end do
+            end do
+        end do
+    end if
+
+end subroutine crotc

BLAS/SRC/dgemmtr.f

@@ -0,0 +1,431 @@
+*> \brief \b DGEMMTR
+*
+*  =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+*            http://www.netlib.org/lapack/explore-html/
+*
+*  Definition:
+*  ===========
+*
+*       SUBROUTINE DGEMMTR(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
+*>
+*> DGEMMTR  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 if
+*> 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 gemmtr
+*
+*> \par Further Details:
+*  =====================
+*>
+*> \verbatim
+*>
+*>  Level 3 Blas routine.
+*>
+*>  -- Written on 19-July-2023.
+*>     Martin Koehler, MPI Magdeburg
+*> \endverbatim
+*>
+*  =====================================================================
+      SUBROUTINE DGEMMTR(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('DGEMMTR',INFO)
+          RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF (N.EQ.0) 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

BLAS/SRC/drotc.f90

@@ -0,0 +1,254 @@
+!> \brief \b DROTC applies a chain of rotation sequences to a matrix.
+!
+!  =========== DOCUMENTATION ===========
+!
+! Online html documentation available at
+!            http://www.netlib.org/lapack/explore-html/
+!
+!  Definition:
+!  ===========
+!
+!   subroutine drotc(side, dir, startup, shutdown, m, n, k,&
+!                    A, lda, C, ldc, S, lds)
+!    .. Scalar Arguments ..
+!    integer, intent(in) :: m, n, k
+!    ...
+!
+!> \par Purpose:
+!  =============
+!>
+!> \verbatim
+!>
+!> DROTC applies a chain of k rotation sequences of length n to a matrix A.
+!>
+!> Each rotation is specified by a cosine and a sine, stored in the
+!> matrices C and S respectively. Rotation G(i,j) is formed by
+!> C(i,j) and S(i,j).
+!>
+!> If side = 'L', rotation G(i,j) is applied to rows i and i+1 of A.
+!> [ A(i,j)   ] = [  C(i,j)  S(i,j) ] [ A(i,j)   ]
+!> [ A(i+1,j) ]   [ -S(i,j)  C(i,j) ] [ A(i+1,j) ]
+!> If side = 'R', rotation G(i,j) is applied to columns j and j+1 of A.
+!> [ A(i,j)   A(i,j+1)   ] = [ A(i,j)   A(i,j+1)   ] [  C(i,j) -S(i,j) ]
+!> [ A(i+1,j) A(i+1,j+1) ]   [ A(i+1,j) A(i+1,j+1) ] [  S(i,j)  C(i,j) ]
+!>
+!> \endverbatim
+!
+!  Arguments:
+!  ==========
+!
+!> \param[in] side
+!> \verbatim
+!>          side is CHARACTER*1
+!>          If side = 'L', the rotations are applied to A from the left.
+!>          If side = 'R', the rotations are applied to A from the right.
+!> \endverbatim
+!>
+!> \param[in] dir
+!> \verbatim
+!>          dir is CHARACTER*1
+!>          If dir = 'F', the rotations are applied in sequence from the
+!>          first column/row to the last column/row.
+!>          If dir = 'B', the rotations are applied in sequence from the
+!>          last column/row to the first column/row.
+!> \endverbatim
+!>
+!> \param[in] startup
+!> \verbatim
+!>          startup is LOGICAL
+!>          If startup = .FALSE., the first (k-1) x (k-1) triangle
+!>          of rotations is not applied.
+!> \endverbatim
+!>
+!> \param[in] shutdown
+!> \verbatim
+!>          shutdown is LOGICAL
+!>          If shutdown = .FALSE., the last (k-1) x (k-1) triangle
+!>          of rotations is not applied.
+!> \endverbatim
+!>
+!> \param[in] m
+!> \verbatim
+!>          m is INTEGER
+!>          If side = 'L', m is the number of columns of A.
+!>          If side = 'R', m is the number of rows of A.
+!> \endverbatim
+!>
+!> \param[in] n
+!> \verbatim
+!>          n is INTEGER
+!>          The number of rotations in one sequence.
+!> \endverbatim
+!>
+!> \param[in] k
+!> \verbatim
+!>          k is INTEGER
+!>          The number of sequences of rotations.
+!> \endverbatim
+!>
+!> \param[in,out] A
+!> \verbatim
+!>          A is DOUBLE PRECISION array
+!>          If side = 'L', A has dimension (n+1,m).
+!>          If side = 'R', A has dimension (m,n+1).
+!>          The matrix to which the rotations are applied.
+!> \endverbatim
+!>
+!> \param[in] lda
+!> \verbatim
+!>          lda is INTEGER
+!>          The leading dimension of A.
+!>          If side = 'L', lda >= n+1.
+!>          If side = 'R', lda >= m.
+!> \endverbatim
+!>
+!> \param[in,out] C
+!> \verbatim
+!>          C is DOUBLE PRECISION array, dimension (ldc,k)
+!>          The matrix containing the cosines of the rotations.
+!> \endverbatim
+!>
+!> \param[in] ldc
+!> \verbatim
+!>          ldc is INTEGER
+!>          The leading dimension of C.
+!>          ldc >= n.
+!> \endverbatim
+!>
+!> \param[in,out] S
+!> \verbatim
+!>          S is DOUBLE PRECISION array, dimension (lds,k)
+!>          The matrix containing the sines of the rotations.
+!> \endverbatim
+!>
+!> \param[in] lds
+!> \verbatim
+!>          lds is INTEGER
+!>          The leading dimension of S.
+!>          lds >= n.
+!> \endverbatim
+!
+!  Authors:
+!  ========
+!
+!> \author Thijs Steel, KU Leuven, Belgium
+!
+!> \date October 2024
+!
+!> \ingroup rotc
+!
+subroutine drotc(side, dir, startup, shutdown, m, n, k,&
+    A, lda, C, ldc, S, lds)
+!    .. Scalar Arguments ..
+    integer, intent(in) :: m, n, k, lda, ldc, lds
+    character, intent(in) :: dir, side
+    logical, intent(in) :: startup, shutdown
+!    .. Array Arguments ..
+    double precision, intent(inout) :: A(lda,*)
+    double precision, intent(in) :: C(ldc,*), S(lds,*)
+!   .. Local Scalars ..
+    integer i, j, l, j1, j2, incj, incj1, incj2, info
+    double precision temp, cs, sn
+!    .. Executable Statements ..
+
+!   Test the input parameters
+    info = 0
+    if(.not. (side .eq. 'L' .or. side .eq. 'R')) then
+        info = 1
+    end if
+    if(.not. (dir .eq. 'F' .or. dir .eq. 'B')) then
+        info = 2
+    end if
+    if(m .lt. 0) then
+        info = 5
+    end if
+    if(n .lt. 0) then
+        info = 6
+    end if
+    if(k .lt. 0) then
+        info = 7
+    end if
+    if(side .eq. 'L') then
+        if(lda .lt. n+1) then
+            info = 9
+        end if
+    else
+        if(lda .lt. m) then
+            info = 9
+        end if
+    end if
+    if(ldc .lt. n) then
+        info = 11
+    end if
+    if(lds .lt. n) then
+        info = 13
+    end if
+
+    if(info .ne. 0) then
+        call xerbla('DROTC ', info)
+        return
+    end if
+
+!   Determine ranges for loops around C and S
+!   The range for sequence l is:
+!   j1+(l-1)*incj1:incj:j2+(l-1)*incj2
+    if( dir .eq. 'F') then
+        incj = 1
+        if(startup) then
+            j1 = 1
+            incj1 = 0
+        else
+            j1 = k
+            incj1 = -1
+        end if
+        j2 = n
+        if(shutdown) then
+            incj2 = 0
+        else
+            incj2 = -1
+        end if
+    else
+        incj = -1
+        j1 = 1
+        if(startup) then
+            incj1 = 1
+        else
+            incj1 = 0
+        end if
+        if(shutdown) then
+            j2 = 0
+            incj2 = 0
+        else
+            j2 = n-k+1
+            incj2 = 1
+        end if
+    end if
+
+!   Apply the rotations
+    if(side .eq. 'L') then
+        do l = 1, k
+            do j = j1+(l-1)*incj1, j2+(l-1)*incj2, incj
+                cs = C(j,l)
+                sn = S(j,l)
+                do i = 1, m
+                    temp = cs*A(i,j) + sn*A(i,j+1)
+                    A(i,j+1) = -sn*A(i,j) + cs*A(i,j+1)
+                    A(i,j) = temp
+                end do
+            end do
+        end do
+    else
+        do l = 1, k
+            do j = j1+(l-1)*incj1, j2+(l-1)*incj2, incj
+                cs = C(l,j)
+                sn = S(l,j)
+                do i = 1, m
+                    temp = cs*A(j,i) + sn*A(j+1,i)
+                    A(j+1,i) = -sn*A(j,i) + cs*A(j+1,i)
+                    A(j,i) = temp
+                end do
+            end do
+        end do
+    end if
+
+end subroutine drotc

BLAS/SRC/dzrotc.f90

@@ -0,0 +1,255 @@
+!> \brief \b DZROTC applies a chain of rotation sequences to a matrix.
+!
+!  =========== DOCUMENTATION ===========
+!
+! Online html documentation available at
+!            http://www.netlib.org/lapack/explore-html/
+!
+!  Definition:
+!  ===========
+!
+!   subroutine dzrotc(side, dir, startup, shutdown, m, n, k,&
+!                    A, lda, C, ldc, S, lds)
+!    .. Scalar Arguments ..
+!    integer, intent(in) :: m, n, k
+!    ...
+!
+!> \par Purpose:
+!  =============
+!>
+!> \verbatim
+!>
+!> DZROTC applies a chain of k rotation sequences of length n to a matrix A.
+!>
+!> Each rotation is specified by a cosine and a sine, stored in the
+!> matrices C and S respectively. Rotation G(i,j) is formed by
+!> C(i,j) and S(i,j).
+!>
+!> If side = 'L', rotation G(i,j) is applied to rows i and i+1 of A.
+!> [ A(i,j)   ] = [  C(i,j)  S(i,j) ] [ A(i,j)   ]
+!> [ A(i+1,j) ]   [ -S(i,j)  C(i,j) ] [ A(i+1,j) ]
+!> If side = 'R', rotation G(i,j) is applied to columns j and j+1 of A.
+!> [ A(i,j)   A(i,j+1)   ] = [ A(i,j)   A(i,j+1)   ] [  C(i,j) -S(i,j) ]
+!> [ A(i+1,j) A(i+1,j+1) ]   [ A(i+1,j) A(i+1,j+1) ] [  S(i,j)  C(i,j) ]
+!>
+!> \endverbatim
+!
+!  Arguments:
+!  ==========
+!
+!> \param[in] side
+!> \verbatim
+!>          side is CHARACTER*1
+!>          If side = 'L', the rotations are applied to A from the left.
+!>          If side = 'R', the rotations are applied to A from the right.
+!> \endverbatim
+!>
+!> \param[in] dir
+!> \verbatim
+!>          dir is CHARACTER*1
+!>          If dir = 'F', the rotations are applied in sequence from the
+!>          first column/row to the last column/row.
+!>          If dir = 'B', the rotations are applied in sequence from the
+!>          last column/row to the first column/row.
+!> \endverbatim
+!>
+!> \param[in] startup
+!> \verbatim
+!>          startup is LOGICAL
+!>          If startup = .FALSE., the first (k-1) x (k-1) triangle
+!>          of rotations is not applied.
+!> \endverbatim
+!>
+!> \param[in] shutdown
+!> \verbatim
+!>          shutdown is LOGICAL
+!>          If shutdown = .FALSE., the last (k-1) x (k-1) triangle
+!>          of rotations is not applied.
+!> \endverbatim
+!>
+!> \param[in] m
+!> \verbatim
+!>          m is INTEGER
+!>          If side = 'L', m is the number of columns of A.
+!>          If side = 'R', m is the number of rows of A.
+!> \endverbatim
+!>
+!> \param[in] n
+!> \verbatim
+!>          n is INTEGER
+!>          The number of rotations in one sequence.
+!> \endverbatim
+!>
+!> \param[in] k
+!> \verbatim
+!>          k is INTEGER
+!>          The number of sequences of rotations.
+!> \endverbatim
+!>
+!> \param[in,out] A
+!> \verbatim
+!>          A is DOUBLE COMPLEX array
+!>          If side = 'L', A has dimension (n+1,m).
+!>          If side = 'R', A has dimension (m,n+1).
+!>          The matrix to which the rotations are applied.
+!> \endverbatim
+!>
+!> \param[in] lda
+!> \verbatim
+!>          lda is INTEGER
+!>          The leading dimension of A.
+!>          If side = 'L', lda >= n+1.
+!>          If side = 'R', lda >= m.
+!> \endverbatim
+!>
+!> \param[in,out] C
+!> \verbatim
+!>          C is DOUBLE PRECISION array, dimension (ldc,k)
+!>          The matrix containing the cosines of the rotations.
+!> \endverbatim
+!>
+!> \param[in] ldc
+!> \verbatim
+!>          ldc is INTEGER
+!>          The leading dimension of C.
+!>          ldc >= n.
+!> \endverbatim
+!>
+!> \param[in,out] S
+!> \verbatim
+!>          S is DOUBLE PRECISION array, dimension (lds,k)
+!>          The matrix containing the sines of the rotations.
+!> \endverbatim
+!>
+!> \param[in] lds
+!> \verbatim
+!>          lds is INTEGER
+!>          The leading dimension of S.
+!>          lds >= n.
+!> \endverbatim
+!
+!  Authors:
+!  ========
+!
+!> \author Thijs Steel, KU Leuven, Belgium
+!
+!> \date October 2024
+!
+!> \ingroup rotc
+!
+subroutine dzrotc(side, dir, startup, shutdown, m, n, k,&
+    A, lda, C, ldc, S, lds)
+!    .. Scalar Arguments ..
+    integer, intent(in) :: m, n, k, lda, ldc, lds
+    character, intent(in) :: dir, side
+    logical, intent(in) :: startup, shutdown
+!    .. Array Arguments ..
+    double complex, intent(inout) :: A(lda,*)
+    double precision, intent(in) :: C(ldc,*), S(lds,*)
+!   .. Local Scalars ..
+    integer i, j, l, j1, j2, incj, incj1, incj2, info
+    double complex temp
+    double precision cs, sn
+!    .. Executable Statements ..
+
+!   Test the input parameters
+    info = 0
+    if(.not. (side .eq. 'L' .or. side .eq. 'R')) then
+        info = 1
+    end if
+    if(.not. (dir .eq. 'F' .or. dir .eq. 'B')) then
+        info = 2
+    end if
+    if(m .lt. 0) then
+        info = 5
+    end if
+    if(n .lt. 0) then
+        info = 6
+    end if
+    if(k .lt. 0) then
+        info = 7
+    end if
+    if(side .eq. 'L') then
+        if(lda .lt. n+1) then
+            info = 9
+        end if
+    else
+        if(lda .lt. m) then
+            info = 9
+        end if
+    end if
+    if(ldc .lt. n) then
+        info = 11
+    end if
+    if(lds .lt. n) then
+        info = 13
+    end if
+
+    if(info .ne. 0) then
+        call xerbla('DZROTC ', info)
+        return
+    end if
+
+!   Determine ranges for loops around C and S
+!   The range for sequence l is:
+!   j1+(l-1)*incj1:incj:j2+(l-1)*incj2
+    if( dir .eq. 'F') then
+        incj = 1
+        if(startup) then
+            j1 = 1
+            incj1 = 0
+        else
+            j1 = k
+            incj1 = -1
+        end if
+        j2 = n
+        if(shutdown) then
+            incj2 = 0
+        else
+            incj2 = -1
+        end if
+    else
+        incj = -1
+        j1 = 1
+        if(startup) then
+            incj1 = 1
+        else
+            incj1 = 0
+        end if
+        if(shutdown) then
+            j2 = 0
+            incj2 = 0
+        else
+            j2 = n-k+1
+            incj2 = 1
+        end if
+    end if
+
+!   Apply the rotations
+    if(side .eq. 'L') then
+        do l = 1, k
+            do j = j1+(l-1)*incj1, j2+(l-1)*incj2, incj
+                cs = C(j,l)
+                sn = S(j,l)
+                do i = 1, m
+                    temp = cs*A(i,j) + sn*A(i,j+1)
+                    A(i,j+1) = -sn*A(i,j) + cs*A(i,j+1)
+                    A(i,j) = temp
+                end do
+            end do
+        end do
+    else
+        do l = 1, k
+            do j = j1+(l-1)*incj1, j2+(l-1)*incj2, incj
+                cs = C(l,j)
+                sn = S(l,j)
+                do i = 1, m
+                    temp = cs*A(j,i) + sn*A(j+1,i)
+                    A(j+1,i) = -sn*A(j,i) + cs*A(j+1,i)
+                    A(j,i) = temp
+                end do
+            end do
+        end do
+    end if
+
+end subroutine dzrotc

BLAS/SRC/scrotc.f90

@@ -0,0 +1,255 @@
+!> \brief \b SCROTC applies a chain of rotation sequences to a matrix.
+!
+!  =========== DOCUMENTATION ===========
+!
+! Online html documentation available at
+!            http://www.netlib.org/lapack/explore-html/
+!
+!  Definition:
+!  ===========
+!
+!   subroutine scrotc(side, dir, startup, shutdown, m, n, k,&
+!                    A, lda, C, ldc, S, lds)
+!    .. Scalar Arguments ..
+!    integer, intent(in) :: m, n, k
+!    ...
+!
+!> \par Purpose:
+!  =============
+!>
+!> \verbatim
+!>
+!> SCROTC applies a chain of k rotation sequences of length n to a matrix A.
+!>
+!> Each rotation is specified by a cosine and a sine, stored in the
+!> matrices C and S respectively. Rotation G(i,j) is formed by
+!> C(i,j) and S(i,j).
+!>
+!> If side = 'L', rotation G(i,j) is applied to rows i and i+1 of A.
+!> [ A(i,j)   ] = [  C(i,j)  S(i,j) ] [ A(i,j)   ]
+!> [ A(i+1,j) ]   [ -S(i,j)  C(i,j) ] [ A(i+1,j) ]
+!> If side = 'R', rotation G(i,j) is applied to columns j and j+1 of A.
+!> [ A(i,j)   A(i,j+1)   ] = [ A(i,j)   A(i,j+1)   ] [  C(i,j) -S(i,j) ]
+!> [ A(i+1,j) A(i+1,j+1) ]   [ A(i+1,j) A(i+1,j+1) ] [  S(i,j)  C(i,j) ]
+!>
+!> \endverbatim
+!
+!  Arguments:
+!  ==========
+!
+!> \param[in] side
+!> \verbatim
+!>          side is CHARACTER*1
+!>          If side = 'L', the rotations are applied to A from the left.
+!>          If side = 'R', the rotations are applied to A from the right.
+!> \endverbatim
+!>
+!> \param[in] dir
+!> \verbatim
+!>          dir is CHARACTER*1
+!>          If dir = 'F', the rotations are applied in sequence from the
+!>          first column/row to the last column/row.
+!>          If dir = 'B', the rotations are applied in sequence from the
+!>          last column/row to the first column/row.
+!> \endverbatim
+!>
+!> \param[in] startup
+!> \verbatim
+!>          startup is LOGICAL
+!>          If startup = .FALSE., the first (k-1) x (k-1) triangle
+!>          of rotations is not applied.
+!> \endverbatim
+!>
+!> \param[in] shutdown
+!> \verbatim
+!>          shutdown is LOGICAL
+!>          If shutdown = .FALSE., the last (k-1) x (k-1) triangle
+!>          of rotations is not applied.
+!> \endverbatim
+!>
+!> \param[in] m
+!> \verbatim
+!>          m is INTEGER
+!>          If side = 'L', m is the number of columns of A.
+!>          If side = 'R', m is the number of rows of A.
+!> \endverbatim
+!>
+!> \param[in] n
+!> \verbatim
+!>          n is INTEGER
+!>          The number of rotations in one sequence.
+!> \endverbatim
+!>
+!> \param[in] k
+!> \verbatim
+!>          k is INTEGER
+!>          The number of sequences of rotations.
+!> \endverbatim
+!>
+!> \param[in,out] A
+!> \verbatim
+!>          A is COMPLEX array
+!>          If side = 'L', A has dimension (n+1,m).
+!>          If side = 'R', A has dimension (m,n+1).
+!>          The matrix to which the rotations are applied.
+!> \endverbatim
+!>
+!> \param[in] lda
+!> \verbatim
+!>          lda is INTEGER
+!>          The leading dimension of A.
+!>          If side = 'L', lda >= n+1.
+!>          If side = 'R', lda >= m.
+!> \endverbatim
+!>
+!> \param[in,out] C
+!> \verbatim
+!>          C is REAL array, dimension (ldc,k)
+!>          The matrix containing the cosines of the rotations.
+!> \endverbatim
+!>
+!> \param[in] ldc
+!> \verbatim
+!>          ldc is INTEGER
+!>          The leading dimension of C.
+!>          ldc >= n.
+!> \endverbatim
+!>
+!> \param[in,out] S
+!> \verbatim
+!>          S is REAL array, dimension (lds,k)
+!>          The matrix containing the sines of the rotations.
+!> \endverbatim
+!>
+!> \param[in] lds
+!> \verbatim
+!>          lds is INTEGER
+!>          The leading dimension of S.
+!>          lds >= n.
+!> \endverbatim
+!
+!  Authors:
+!  ========
+!
+!> \author Thijs Steel, KU Leuven, Belgium
+!
+!> \date October 2024
+!
+!> \ingroup rotc
+!
+subroutine scrotc(side, dir, startup, shutdown, m, n, k,&
+    A, lda, C, ldc, S, lds)
+!    .. Scalar Arguments ..
+    integer, intent(in) :: m, n, k, lda, ldc, lds
+    character, intent(in) :: dir, side
+    logical, intent(in) :: startup, shutdown
+!    .. Array Arguments ..
+    complex, intent(inout) :: A(lda,*)
+    real, intent(in) :: C(ldc,*), S(lds,*)
+!   .. Local Scalars ..
+    integer i, j, l, j1, j2, incj, incj1, incj2, info
+    complex temp
+    real cs, sn
+!    .. Executable Statements ..
+
+!   Test the input parameters
+    info = 0
+    if(.not. (side .eq. 'L' .or. side .eq. 'R')) then
+        info = 1
+    end if
+    if(.not. (dir .eq. 'F' .or. dir .eq. 'B')) then
+        info = 2
+    end if
+    if(m .lt. 0) then
+        info = 5
+    end if
+    if(n .lt. 0) then
+        info = 6
+    end if
+    if(k .lt. 0) then
+        info = 7
+    end if
+    if(side .eq. 'L') then
+        if(lda .lt. n+1) then
+            info = 9
+        end if
+    else
+        if(lda .lt. m) then
+            info = 9
+        end if
+    end if
+    if(ldc .lt. n) then
+        info = 11
+    end if
+    if(lds .lt. n) then
+        info = 13
+    end if
+
+    if(info .ne. 0) then
+        call xerbla('SCROTC ', info)
+        return
+    end if
+
+!   Determine ranges for loops around C and S
+!   The range for sequence l is:
+!   j1+(l-1)*incj1:incj:j2+(l-1)*incj2
+    if( dir .eq. 'F') then
+        incj = 1
+        if(startup) then
+            j1 = 1
+            incj1 = 0
+        else
+            j1 = k
+            incj1 = -1
+        end if
+        j2 = n
+        if(shutdown) then
+            incj2 = 0
+        else
+            incj2 = -1
+        end if
+    else
+        incj = -1
+        j1 = 1
+        if(startup) then
+            incj1 = 1
+        else
+            incj1 = 0
+        end if
+        if(shutdown) then
+            j2 = 0
+            incj2 = 0
+        else
+            j2 = n-k+1
+            incj2 = 1
+        end if
+    end if
+
+!   Apply the rotations
+    if(side .eq. 'L') then
+        do l = 1, k
+            do j = j1+(l-1)*incj1, j2+(l-1)*incj2, incj
+                cs = C(j,l)
+                sn = S(j,l)
+                do i = 1, m
+                    temp = cs*A(i,j) + sn*A(i,j+1)
+                    A(i,j+1) = -sn*A(i,j) + cs*A(i,j+1)
+                    A(i,j) = temp
+                end do
+            end do
+        end do
+    else
+        do l = 1, k
+            do j = j1+(l-1)*incj1, j2+(l-1)*incj2, incj
+                cs = C(l,j)
+                sn = S(l,j)
+                do i = 1, m
+                    temp = cs*A(j,i) + sn*A(j+1,i)
+                    A(j+1,i) = -sn*A(j,i) + cs*A(j+1,i)
+                    A(j,i) = temp
+                end do
+            end do
+        end do
+    end if
+
+end subroutine scrotc

BLAS/SRC/sgemmtr.f

@@ -0,0 +1,431 @@
+*> \brief \b SGEMMTR
+*
+*  =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+*            http://www.netlib.org/lapack/explore-html/
+*
+*  Definition:
+*  ===========
+*
+*       SUBROUTINE SGEMMTR(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
+*>
+*> SGEMMTR  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 if
+*> 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 gemmtr
+*
+*> \par Further Details:
+*  =====================
+*>
+*> \verbatim
+*>
+*>  Level 3 Blas routine.
+*>
+*>  -- Written on 19-July-2023.
+*>     Martin Koehler, MPI Magdeburg
+*> \endverbatim
+*>
+*  =====================================================================
+      SUBROUTINE SGEMMTR(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('SGEMMTR',INFO)
+          RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF (N.EQ.0) 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 SGEMMTR
+*
+      END

BLAS/SRC/srotc.f90

@@ -0,0 +1,254 @@
+!> \brief \b SROTC applies a chain of rotation sequences to a matrix.
+!
+!  =========== DOCUMENTATION ===========
+!
+! Online html documentation available at
+!            http://www.netlib.org/lapack/explore-html/
+!
+!  Definition:
+!  ===========
+!
+!   subroutine srotc(side, dir, startup, shutdown, m, n, k,&
+!                    A, lda, C, ldc, S, lds)
+!    .. Scalar Arguments ..
+!    integer, intent(in) :: m, n, k
+!    ...
+!
+!> \par Purpose:
+!  =============
+!>
+!> \verbatim
+!>
+!> SROTC applies a chain of k rotation sequences of length n to a matrix A.
+!>
+!> Each rotation is specified by a cosine and a sine, stored in the
+!> matrices C and S respectively. Rotation G(i,j) is formed by
+!> C(i,j) and S(i,j).
+!>
+!> If side = 'L', rotation G(i,j) is applied to rows i and i+1 of A.
+!> [ A(i,j)   ] = [  C(i,j)  S(i,j) ] [ A(i,j)   ]
+!> [ A(i+1,j) ]   [ -S(i,j)  C(i,j) ] [ A(i+1,j) ]
+!> If side = 'R', rotation G(i,j) is applied to columns j and j+1 of A.
+!> [ A(i,j)   A(i,j+1)   ] = [ A(i,j)   A(i,j+1)   ] [  C(i,j) -S(i,j) ]
+!> [ A(i+1,j) A(i+1,j+1) ]   [ A(i+1,j) A(i+1,j+1) ] [  S(i,j)  C(i,j) ]
+!>
+!> \endverbatim
+!
+!  Arguments:
+!  ==========
+!
+!> \param[in] side
+!> \verbatim
+!>          side is CHARACTER*1
+!>          If side = 'L', the rotations are applied to A from the left.
+!>          If side = 'R', the rotations are applied to A from the right.
+!> \endverbatim
+!>
+!> \param[in] dir
+!> \verbatim
+!>          dir is CHARACTER*1
+!>          If dir = 'F', the rotations are applied in sequence from the
+!>          first column/row to the last column/row.
+!>          If dir = 'B', the rotations are applied in sequence from the
+!>          last column/row to the first column/row.
+!> \endverbatim
+!>
+!> \param[in] startup
+!> \verbatim
+!>          startup is LOGICAL
+!>          If startup = .FALSE., the first (k-1) x (k-1) triangle
+!>          of rotations is not applied.
+!> \endverbatim
+!>
+!> \param[in] shutdown
+!> \verbatim
+!>          shutdown is LOGICAL
+!>          If shutdown = .FALSE., the last (k-1) x (k-1) triangle
+!>          of rotations is not applied.
+!> \endverbatim
+!>
+!> \param[in] m
+!> \verbatim
+!>          m is INTEGER
+!>          If side = 'L', m is the number of columns of A.
+!>          If side = 'R', m is the number of rows of A.
+!> \endverbatim
+!>
+!> \param[in] n
+!> \verbatim
+!>          n is INTEGER
+!>          The number of rotations in one sequence.
+!> \endverbatim
+!>
+!> \param[in] k
+!> \verbatim
+!>          k is INTEGER
+!>          The number of sequences of rotations.
+!> \endverbatim
+!>
+!> \param[in,out] A
+!> \verbatim
+!>          A is REAL array
+!>          If side = 'L', A has dimension (n+1,m).
+!>          If side = 'R', A has dimension (m,n+1).
+!>          The matrix to which the rotations are applied.
+!> \endverbatim
+!>
+!> \param[in] lda
+!> \verbatim
+!>          lda is INTEGER
+!>          The leading dimension of A.
+!>          If side = 'L', lda >= n+1.
+!>          If side = 'R', lda >= m.
+!> \endverbatim
+!>
+!> \param[in,out] C
+!> \verbatim
+!>          C is REAL array, dimension (ldc,k)
+!>          The matrix containing the cosines of the rotations.
+!> \endverbatim
+!>
+!> \param[in] ldc
+!> \verbatim
+!>          ldc is INTEGER
+!>          The leading dimension of C.
+!>          ldc >= n.
+!> \endverbatim
+!>
+!> \param[in,out] S
+!> \verbatim
+!>          S is REAL array, dimension (lds,k)
+!>          The matrix containing the sines of the rotations.
+!> \endverbatim
+!>
+!> \param[in] lds
+!> \verbatim
+!>          lds is INTEGER
+!>          The leading dimension of S.
+!>          lds >= n.
+!> \endverbatim
+!
+!  Authors:
+!  ========
+!
+!> \author Thijs Steel, KU Leuven, Belgium
+!
+!> \date October 2024
+!
+!> \ingroup rotc
+!
+subroutine srotc(side, dir, startup, shutdown, m, n, k,&
+    A, lda, C, ldc, S, lds)
+!    .. Scalar Arguments ..
+    integer, intent(in) :: m, n, k, lda, ldc, lds
+    character, intent(in) :: dir, side
+    logical, intent(in) :: startup, shutdown
+!    .. Array Arguments ..
+    real, intent(inout) :: A(lda,*)
+    real, intent(in) :: C(ldc,*), S(lds,*)
+!   .. Local Scalars ..
+    integer i, j, l, j1, j2, incj, incj1, incj2, info
+    real temp, cs, sn
+!    .. Executable Statements ..
+
+!   Test the input parameters
+    info = 0
+    if(.not. (side .eq. 'L' .or. side .eq. 'R')) then
+        info = 1
+    end if
+    if(.not. (dir .eq. 'F' .or. dir .eq. 'B')) then
+        info = 2
+    end if
+    if(m .lt. 0) then
+        info = 5
+    end if
+    if(n .lt. 0) then
+        info = 6
+    end if
+    if(k .lt. 0) then
+        info = 7
+    end if
+    if(side .eq. 'L') then
+        if(lda .lt. n+1) then
+            info = 9
+        end if
+    else
+        if(lda .lt. m) then
+            info = 9
+        end if
+    end if
+    if(ldc .lt. n) then
+        info = 11
+    end if
+    if(lds .lt. n) then
+        info = 13
+    end if
+
+    if(info .ne. 0) then
+        call xerbla('SROTC ', info)
+        return
+    end if
+
+!   Determine ranges for loops around C and S
+!   The range for sequence l is:
+!   j1+(l-1)*incj1:incj:j2+(l-1)*incj2
+    if( dir .eq. 'F') then
+        incj = 1
+        if(startup) then
+            j1 = 1
+            incj1 = 0
+        else
+            j1 = k
+            incj1 = -1
+        end if
+        j2 = n
+        if(shutdown) then
+            incj2 = 0
+        else
+            incj2 = -1
+        end if
+    else
+        incj = -1
+        j1 = 1
+        if(startup) then
+            incj1 = 1
+        else
+            incj1 = 0
+        end if
+        if(shutdown) then
+            j2 = 0
+            incj2 = 0
+        else
+            j2 = n-k+1
+            incj2 = 1
+        end if
+    end if
+
+!   Apply the rotations
+    if(side .eq. 'L') then
+        do l = 1, k
+            do j = j1+(l-1)*incj1, j2+(l-1)*incj2, incj
+                cs = C(j,l)
+                sn = S(j,l)
+                do i = 1, m
+                    temp = cs*A(i,j) + sn*A(i,j+1)
+                    A(i,j+1) = -sn*A(i,j) + cs*A(i,j+1)
+                    A(i,j) = temp
+                end do
+            end do
+        end do
+    else
+        do l = 1, k
+            do j = j1+(l-1)*incj1, j2+(l-1)*incj2, incj
+                cs = C(l,j)
+                sn = S(l,j)
+                do i = 1, m
+                    temp = cs*A(j,i) + sn*A(j+1,i)
+                    A(j+1,i) = -sn*A(j,i) + cs*A(j+1,i)
+                    A(j,i) = temp
+                end do
+            end do
+        end do
+    end if
+
+end subroutine srotc

BLAS/SRC/zgemmtr.f

@@ -0,0 +1,569 @@
+*> \brief \b ZGEMMTR
+*
+*  =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+*            http://www.netlib.org/lapack/explore-html/
+*
+*  Definition:
+*  ===========
+*
+*       SUBROUTINE ZGEMMTR(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
+*>
+*> ZGEMMTR  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 if
+*> the resulting matrix C is known to be Hermitian or 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 gemmtr
+*
+*> \par Further Details:
+*  =====================
+*>
+*> \verbatim
+*>
+*>  Level 3 Blas routine.
+*>
+*>  -- Written on 19-July-2023.
+*>     Martin Koehler, MPI Magdeburg
+*> \endverbatim
+*>
+*  =====================================================================
+      SUBROUTINE ZGEMMTR(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.0D+0,0.0D+0))
+      COMPLEX*16 ZERO
+      PARAMETER (ZERO= (0.0D+0,0.0D+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('ZGEMMTR',INFO)
+          RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF (N.EQ.0) 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 ZGEMMTR
+*
+      END

BLAS/SRC/zrotc.f90

@@ -0,0 +1,256 @@
+!> \brief \b ZROTC applies a chain of rotation sequences to a matrix.
+!
+!  =========== DOCUMENTATION ===========
+!
+! Online html documentation available at
+!            http://www.netlib.org/lapack/explore-html/
+!
+!  Definition:
+!  ===========
+!
+!   subroutine zrotc(side, dir, startup, shutdown, m, n, k,&
+!                    A, lda, C, ldc, S, lds)
+!    .. Scalar Arguments ..
+!    integer, intent(in) :: m, n, k
+!    ...
+!
+!> \par Purpose:
+!  =============
+!>
+!> \verbatim
+!>
+!> ZROTC applies a chain of k rotation sequences of length n to a matrix A.
+!>
+!> Each rotation is specified by a cosine and a sine, stored in the
+!> matrices C and S respectively. Rotation G(i,j) is formed by
+!> C(i,j) and S(i,j).
+!>
+!> If side = 'L', rotation G(i,j) is applied to rows i and i+1 of A.
+!> [ A(i,j)   ] = [  C(i,j)        S(i,j) ] [ A(i,j)   ]
+!> [ A(i+1,j) ]   [ -conjg(S(i,j))  C(i,j) ] [ A(i+1,j) ]
+!> If side = 'R', rotation G(i,j) is applied to columns j and j+1 of A.
+!> [ A(i,j)   A(i,j+1)   ] = [ A(i,j)   A(i,j+1)   ] [  C(i,j) -conjg(S(i,j)) ]
+!> [ A(i+1,j) A(i+1,j+1) ]   [ A(i+1,j) A(i+1,j+1) ] [  S(i,j)  C(i,j)       ]
+!>
+!> \endverbatim
+!
+!  Arguments:
+!  ==========
+!
+!> \param[in] side
+!> \verbatim
+!>          side is CHARACTER*1
+!>          If side = 'L', the rotations are applied to A from the left.
+!>          If side = 'R', the rotations are applied to A from the right.
+!> \endverbatim
+!>
+!> \param[in] dir
+!> \verbatim
+!>          dir is CHARACTER*1
+!>          If dir = 'F', the rotations are applied in sequence from the
+!>          first column/row to the last column/row.
+!>          If dir = 'B', the rotations are applied in sequence from the
+!>          last column/row to the first column/row.
+!> \endverbatim
+!>
+!> \param[in] startup
+!> \verbatim
+!>          startup is LOGICAL
+!>          If startup = .FALSE., the first (k-1) x (k-1) triangle
+!>          of rotations is not applied.
+!> \endverbatim
+!>
+!> \param[in] shutdown
+!> \verbatim
+!>          shutdown is LOGICAL
+!>          If shutdown = .FALSE., the last (k-1) x (k-1) triangle
+!>          of rotations is not applied.
+!> \endverbatim
+!>
+!> \param[in] m
+!> \verbatim
+!>          m is INTEGER
+!>          If side = 'L', m is the number of columns of A.
+!>          If side = 'R', m is the number of rows of A.
+!> \endverbatim
+!>
+!> \param[in] n
+!> \verbatim
+!>          n is INTEGER
+!>          The number of rotations in one sequence.
+!> \endverbatim
+!>
+!> \param[in] k
+!> \verbatim
+!>          k is INTEGER
+!>          The number of sequences of rotations.
+!> \endverbatim
+!>
+!> \param[in,out] A
+!> \verbatim
+!>          A is DOUBLE COMPLEX array
+!>          If side = 'L', A has dimension (n+1,m).
+!>          If side = 'R', A has dimension (m,n+1).
+!>          The matrix to which the rotations are applied.
+!> \endverbatim
+!>
+!> \param[in] lda
+!> \verbatim
+!>          lda is INTEGER
+!>          The leading dimension of A.
+!>          If side = 'L', lda >= n+1.
+!>          If side = 'R', lda >= m.
+!> \endverbatim
+!>
+!> \param[in,out] C
+!> \verbatim
+!>          C is DOUBLE PRECISION array, dimension (ldc,k)
+!>          The matrix containing the cosines of the rotations.
+!> \endverbatim
+!>
+!> \param[in] ldc
+!> \verbatim
+!>          ldc is INTEGER
+!>          The leading dimension of C.
+!>          ldc >= n.
+!> \endverbatim
+!>
+!> \param[in,out] S
+!> \verbatim
+!>          S is DOUBLE COMPLEX array, dimension (lds,k)
+!>          The matrix containing the sines of the rotations.
+!> \endverbatim
+!>
+!> \param[in] lds
+!> \verbatim
+!>          lds is INTEGER
+!>          The leading dimension of S.
+!>          lds >= n.
+!> \endverbatim
+!
+!  Authors:
+!  ========
+!
+!> \author Thijs Steel, KU Leuven, Belgium
+!
+!> \date October 2024
+!
+!> \ingroup rotc
+!
+subroutine zrotc(side, dir, startup, shutdown, m, n, k,&
+    A, lda, C, ldc, S, lds)
+!    .. Scalar Arguments ..
+    integer, intent(in) :: m, n, k, lda, ldc, lds
+    character, intent(in) :: dir, side
+    logical, intent(in) :: startup, shutdown
+!    .. Array Arguments ..
+    double complex, intent(inout) :: A(lda,*)
+    double complex, intent(in) :: S(lds,*)
+    double precision, intent(in) :: C(ldc,*)
+!   .. Local Scalars ..
+    integer i, j, l, j1, j2, incj, incj1, incj2, info
+    double complex temp, sn
+    double precision cs
+!    .. Executable Statements ..
+
+!   Test the input parameters
+    info = 0
+    if(.not. (side .eq. 'L' .or. side .eq. 'R')) then
+        info = 1
+    end if
+    if(.not. (dir .eq. 'F' .or. dir .eq. 'B')) then
+        info = 2
+    end if
+    if(m .lt. 0) then
+        info = 5
+    end if
+    if(n .lt. 0) then
+        info = 6
+    end if
+    if(k .lt. 0) then
+        info = 7
+    end if
+    if(side .eq. 'L') then
+        if(lda .lt. n+1) then
+            info = 9
+        end if
+    else
+        if(lda .lt. m) then
+            info = 9
+        end if
+    end if
+    if(ldc .lt. n) then
+        info = 11
+    end if
+    if(lds .lt. n) then
+        info = 13
+    end if
+
+    if(info .ne. 0) then
+        call xerbla('ZROTC ', info)
+        return
+    end if
+
+!   Determine ranges for loops around C and S
+!   The range for sequence l is:
+!   j1+(l-1)*incj1:incj:j2+(l-1)*incj2
+    if( dir .eq. 'F') then
+        incj = 1
+        if(startup) then
+            j1 = 1
+            incj1 = 0
+        else
+            j1 = k
+            incj1 = -1
+        end if
+        j2 = n
+        if(shutdown) then
+            incj2 = 0
+        else
+            incj2 = -1
+        end if
+    else
+        incj = -1
+        j1 = 1
+        if(startup) then
+            incj1 = 1
+        else
+            incj1 = 0
+        end if
+        if(shutdown) then
+            j2 = 0
+            incj2 = 0
+        else
+            j2 = n-k+1
+            incj2 = 1
+        end if
+    end if
+
+!   Apply the rotations
+    if(side .eq. 'L') then
+        do l = 1, k
+            do j = j1+(l-1)*incj1, j2+(l-1)*incj2, incj
+                cs = C(j,l)
+                sn = S(j,l)
+                do i = 1, m
+                    temp = cs*A(i,j) + sn*A(i,j+1)
+                    A(i,j+1) = -conjg(sn*A(i,j)) + cs*A(i,j+1)
+                    A(i,j) = temp
+                end do
+            end do
+        end do
+    else
+        do l = 1, k
+            do j = j1+(l-1)*incj1, j2+(l-1)*incj2, incj
+                cs = C(l,j)
+                sn = S(l,j)
+                do i = 1, m
+                    temp = cs*A(j,i) + sn*A(j+1,i)
+                    A(j+1,i) = -conjg(sn*A(j,i)) + cs*A(j+1,i)
+                    A(j,i) = temp
+                end do
+            end do
+        end do
+    end if
+
+end subroutine zrotc

BLAS/TESTING/cblat1.f

@@ -994,13 +994,17 @@
 *     .. Scalar Arguments ..
       REAL              XX
       INTEGER           K
+*     .. Parameters ..
+      REAL              ZERO
+      PARAMETER         (ZERO=0.0E+0)
 *     .. Local Scalars ..
-      REAL              X, Y, YY, Z
+      REAL              X, Y, Z
 *     .. Intrinsic Functions ..
       INTRINSIC         HUGE
 *     .. Executable Statements ..
+      X = ZERO
       Y = HUGE(XX)
-      Z = YY
+      Z = Y*Y
       IF (K.EQ.1) THEN
          X = -Z
       ELSE IF (K.EQ.2) THEN

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.
+*> CGEMMTR T PUT F FOR NO TEST. SAME COLUMNS.
 *>
 *> Further Details
 *> ===============
@@ -93,7 +94,7 @@
       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
@@ -108,7 +109,7 @@
       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 ),
@@ -120,26 +121,27 @@
       REAL               G( NMAX )
       INTEGER            IDIM( NIDMAX )
       LOGICAL            LTEST( NSUBS )
-      CHARACTER*6        SNAMES( NSUBS )
+      CHARACTER*7        SNAMES( NSUBS )
 *     .. External Functions ..
       REAL               SDIFF
       LOGICAL            LCE
       EXTERNAL           SDIFF, LCE
 *     .. External Subroutines ..
       EXTERNAL           CCHK1, CCHK2, CCHK3, CCHK4, CCHK5, CCHKE, CMMCH
+      EXTERNAL           CCHK6
 *     .. Intrinsic Functions ..
       INTRINSIC          MAX, MIN
 *     .. 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/'CGEMM ', 'CHEMM ', 'CSYMM ', 'CTRMM ',
      $                   'CTRSM ', 'CHERK ', 'CSYRK ', 'CHER2K',
-     $                   'CSYR2K'/
+     $                   'CSYR2K', 'CGEMMTR'/
 *     .. Executable Statements ..
 *
 *     Read name and unit number for summary output file and open file.
@@ -317,7 +319,7 @@
             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 @@
      $                  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
@@ -390,8 +397,8 @@
      $      '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' )
@@ -422,7 +429,7 @@
       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 ),
@@ -707,7 +714,7 @@
       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 ),
@@ -986,7 +993,7 @@
       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 ),
@@ -1296,7 +1303,7 @@
       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 ),
@@ -1628,7 +1635,7 @@
       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 ),
@@ -1998,7 +2005,7 @@
 *
 *     .. Scalar Arguments ..
       INTEGER            ISNUM, NOUT
-      CHARACTER*6        SRNAMT
+      CHARACTER*7        SRNAMT
 *     .. Scalars in Common ..
       INTEGER            INFOT, NOUTC
       LOGICAL            LERR, OK
@@ -2031,7 +2038,7 @@
       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 @@
       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 @@
       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 @@
       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 @@
       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 @@
       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 @@
       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 @@
       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 @@
       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,204 @@
       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 CGEMMTR( '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 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 CGEMMTR( '/', 'N', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 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 CGEMMTR( '/', 'T', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 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 CGEMMTR( '/', 'C', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 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 CGEMMTR( '/', 'C', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+
+      INFOT = 2
+      CALL CGEMMTR( 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 2
+      CALL CGEMMTR( 'U', '/', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 2
+      CALL CGEMMTR( 'U', '/', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 2
+      CALL CGEMMTR( 'L', '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 2
+      CALL CGEMMTR( 'L', '/', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 2
+      CALL CGEMMTR( 'L', '/', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+
+      INFOT = 3
+      CALL CGEMMTR( 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 3
+      CALL CGEMMTR( 'U', 'C', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 3
+      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 CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 4
+      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 CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 4
+      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 CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 4
+      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 CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 4
+      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 CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 5
+      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 CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 5
+      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 CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 5
+      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 CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 5
+      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 CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 5
+      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 CGEMMTR( 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 8
+      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 CGEMMTR( 'U', 'N', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 8
+      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 CGEMMTR( 'U', 'C', 'C', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 8
+      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 CGEMMTR( 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 8
+      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 CGEMMTR( 'U', 'T', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+
+      INFOT = 10
+      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 CGEMMTR( 'U', 'C', 'N', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 10
+      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 CGEMMTR( 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 13
+      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 CGEMMTR( 'U', 'N', 'T', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 13
+      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 CGEMMTR( 'U', 'C', 'C', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 13
+      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 CGEMMTR( 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 13
+      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 CGEMMTR( '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
@@ -3416,7 +3619,7 @@
 *     .. 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
@@ -3452,11 +3655,11 @@
 *
 *     .. 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
@@ -3486,3 +3689,496 @@
 *     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 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            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*7        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,
+     $                   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, ' ', 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 CGEMMTR( 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', ' ', 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
+         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, 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
+

BLAS/TESTING/cblat3.in

@@ -12,12 +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.

BLAS/TESTING/dblat1.f

@@ -1326,13 +1326,17 @@
 *     .. Scalar Arguments ..
       DOUBLE PRECISION  XX
       INTEGER           K
+*     .. Parameters ..
+      DOUBLE PRECISION  ZERO
+      PARAMETER         (ZERO=0.0D+0)
 *     .. Local Scalars ..
-      DOUBLE PRECISION  X, Y, YY, Z
+      DOUBLE PRECISION  X, Y, Z
 *     .. Intrinsic Functions ..
       INTRINSIC         HUGE
 *     .. Executable Statements ..
+      X = ZERO
       Y = HUGE(XX)
-      Z = YY
+      Z = Y*Y
       IF (K.EQ.1) THEN
          X = -Z
       ELSE IF (K.EQ.2) THEN

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
@@ -37,12 +37,13 @@
 *> 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
 *> ===============
@@ -90,7 +91,7 @@
       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
@@ -103,7 +104,7 @@
       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 ),
@@ -114,7 +115,7 @@
      $                   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
@@ -126,13 +127,13 @@
 *     .. 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/'DGEMM ', 'DSYMM ', 'DTRMM ', 'DTRSM ',
-     $                   'DSYRK ', 'DSYR2K'/
+     $                   'DSYRK ', 'DSYR2K', 'DGEMMTR'/
 *     .. Executable Statements ..
 *
 *     Read name and unit number for summary output file and open file.
@@ -309,7 +310,7 @@
             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 @@
      $                  REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
      $                  NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W )
             GO TO 190
+*           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,
+     $                  CC, CS, CT, G )
+
 *
   190       IF( FATAL.AND.SFATAL )
      $         GO TO 210
@@ -380,8 +387,8 @@
      $      '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' )
@@ -410,7 +417,7 @@
       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 ),
@@ -691,7 +698,7 @@
       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 ),
@@ -961,7 +968,7 @@
       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 ),
@@ -1266,7 +1273,7 @@
       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 ),
@@ -1541,7 +1548,7 @@
       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 ),
@@ -1853,7 +1860,7 @@
 *
 *     .. Scalar Arguments ..
       INTEGER            ISNUM, NOUT
-      CHARACTER*6        SRNAMT
+      CHARACTER*7        SRNAMT
 *     .. Scalars in Common ..
       INTEGER            INFOT, NOUTC
       LOGICAL            LERR, OK
@@ -1882,7 +1889,7 @@
       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 @@
       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 @@
       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 @@
       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 @@
       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 @@
       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,87 @@
       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 DGEMMTR( '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 2
+      CALL DGEMMTR( 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 2
+      CALL DGEMMTR( 'U', '/', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 3
+      CALL DGEMMTR( 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 3
+      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 CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 4
+      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 CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 4
+      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 CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 5
+      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 CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 5
+      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 CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 8
+      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 DGEMMTR( 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 10
+      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 DGEMMTR( 'U', 'N', 'T', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 10
+      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 DGEMMTR( 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 13
+      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 DGEMMTR( 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 13
+      CALL DGEMMTR( '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
@@ -2797,7 +2883,7 @@
 *     .. 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
@@ -2833,11 +2919,11 @@
 *
 *     .. 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
@@ -2867,3 +2953,420 @@
 *     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 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
+      LOGICAL            FATAL, REWI, TRACE
+      CHARACTER*7        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           DGEMMTR, 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 DGEMMTR( 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
+         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. (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
+

BLAS/TESTING/dblat3.in

@@ -12,9 +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.

BLAS/TESTING/sblat1.f

@@ -1278,13 +1278,17 @@
 *     .. Scalar Arguments ..
       REAL              XX
       INTEGER           K
+*     .. Parameters ..
+      REAL              ZERO
+      PARAMETER         (ZERO=0.0E+0)
 *     .. Local Scalars ..
-      REAL              X, Y, YY, Z
+      REAL              X, Y, Z
 *     .. Intrinsic Functions ..
       INTRINSIC         HUGE
 *     .. Executable Statements ..
+      X = ZERO
       Y = HUGE(XX)
-      Z = YY
+      Z = Y*Y
       IF (K.EQ.1) THEN
          X = -Z
       ELSE IF (K.EQ.2) THEN

BLAS/TESTING/sblat3.f

@@ -19,8 +19,8 @@
 *> 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
-*> are read using the format ( A6, L2 ). An annotated example of a data
+*> of the file are read using list-directed input, the last 7 records
+*> 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
@@ -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.
+*> SGEMMTR T PUT F FOR NO TEST. SAME COLUMNS.
 *>
 *> Further Details
 *> ===============
@@ -90,7 +91,7 @@
       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
@@ -103,7 +104,7 @@
       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 ),
@@ -114,7 +115,7 @@
      $                   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
@@ -126,13 +127,13 @@
 *     .. 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'/
+      DATA               SNAMES/'SGEMM', 'SSYMM  ', 'STRMM  ',
+     $                   'STRSM  ', 'SSYRK  ', 'SSYR2K ', 'SGEMMTR'/
 *     .. Executable Statements ..
 *
 *     Read name and unit number for summary output file and open file.
@@ -309,7 +310,7 @@
             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 @@
      $                  REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
      $                  NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W )
             GO TO 190
+*           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,
+     $                  CC, CS, CT, G )
+            GO TO 190
 *
   190       IF( FATAL.AND.SFATAL )
      $         GO TO 210
@@ -372,7 +379,7 @@
  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,
@@ -380,8 +387,8 @@
      $      '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' )
@@ -410,7 +417,7 @@
       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 ),
@@ -653,15 +660,15 @@
   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 *',
@@ -691,7 +698,7 @@
       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 ),
@@ -923,15 +930,15 @@
   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 *',
@@ -961,7 +968,7 @@
       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 ),
@@ -1229,15 +1236,15 @@
   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 *',
      $      '******' )
@@ -1266,7 +1273,7 @@
       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 ),
@@ -1503,16 +1510,16 @@
   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 *',
      $      '******' )
@@ -1541,7 +1548,7 @@
       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 ),
@@ -1816,16 +1823,16 @@
   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 *',
@@ -1853,7 +1860,7 @@
 *
 *     .. Scalar Arguments ..
       INTEGER            ISNUM, NOUT
-      CHARACTER*6        SRNAMT
+      CHARACTER*7        SRNAMT
 *     .. Scalars in Common ..
       INTEGER            INFOT, NOUTC
       LOGICAL            LERR, OK
@@ -1866,7 +1873,7 @@
       REAL               A( 2, 1 ), B( 2, 1 ), C( 2, 1 )
 *     .. External Subroutines ..
       EXTERNAL           CHKXER, SGEMM, SSYMM, SSYR2K, SSYRK, STRMM,
-     $                   STRSM
+     $                   STRSM, SGEMMTR
 *     .. Common blocks ..
       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
 *     .. Executable Statements ..
@@ -1882,7 +1889,7 @@
       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 @@
       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 @@
       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 @@
       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 @@
       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 @@
       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,16 +2381,95 @@
       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 SGEMMTR( '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 2
+      CALL SGEMMTR( 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 2
+      CALL SGEMMTR( 'U', '/', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 3
+      CALL SGEMMTR( 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 3
+      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 CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 4
+      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 CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 4
+      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 CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 5
+      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 CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 5
+      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 CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 8
+      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 SGEMMTR( 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 10
+      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 SGEMMTR( 'U', 'N', 'T', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 10
+      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 SGEMMTR( 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 13
+      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 SGEMMTR( 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 13
+      CALL SGEMMTR( '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
       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
@@ -2797,7 +2883,7 @@
 *     .. 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
@@ -2807,7 +2893,7 @@
       RETURN
 *
  9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D',
-     $      'ETECTED BY ', A6, ' *****' )
+     $      'ETECTED BY ', A7, ' *****' )
 *
 *     End of CHKXER
 *
@@ -2833,11 +2919,11 @@
 *
 *     .. 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
@@ -2851,7 +2937,7 @@
          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
@@ -2859,11 +2945,428 @@
 *
  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,
      $      ' *******' )
 *
 *     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 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.0D0 )
+*     .. Scalar Arguments ..
+      REAL               EPS, THRESH
+      INTEGER            NALF, NBET, NIDIM, NMAX, NOUT, NTRA
+      LOGICAL            FATAL, REWI, TRACE
+      CHARACTER*7        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           SGEMMTR, 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 SGEMMTR( 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
+         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( ' ', A7, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
+     $      'S)' )
+ 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
+     $      'ANGED INCORRECTLY *******' )
+ 9997 FORMAT( ' ', A7, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
+     $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
+     $      ' - SUSPECT *******' )
+ 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 *',
+     $      '******' )
+*
+*     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. (SGEMMTR)
+*
+*  -- 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

BLAS/TESTING/sblat3.in

@@ -12,9 +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.

BLAS/TESTING/zblat1.f

@@ -994,13 +994,17 @@
 *     .. Scalar Arguments ..
       DOUBLE PRECISION  XX
       INTEGER           K
+*     .. Parameters ..
+      DOUBLE PRECISION  ZERO
+      PARAMETER         (ZERO=0.0D+0)
 *     .. Local Scalars ..
-      DOUBLE PRECISION  X, Y, YY, Z
+      DOUBLE PRECISION  X, Y, Z
 *     .. Intrinsic Functions ..
       INTRINSIC         HUGE
 *     .. Executable Statements ..
+      X = ZERO
       Y = HUGE(XX)
-      Z = YY
+      Z = Y*Y
       IF (K.EQ.1) THEN
          X = -Z
       ELSE IF (K.EQ.2) THEN

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.
+*> ZGEMMTR T PUT F FOR NO TEST. SAME COLUMNS.
 *>
 *>
 *> Further Details
@@ -94,7 +95,7 @@
       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 ) )
@@ -110,7 +111,7 @@
       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 ),
@@ -122,26 +123,27 @@
       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
       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 ..
       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/'ZGEMM ', 'ZHEMM ', 'ZSYMM ', 'ZTRMM ',
      $                   'ZTRSM ', 'ZHERK ', 'ZSYRK ', 'ZHER2K',
-     $                   'ZSYR2K'/
+     $                   'ZSYR2K', 'ZGEMMTR'/
 *     .. Executable Statements ..
 *
 *     Read name and unit number for summary output file and open file.
@@ -319,7 +321,7 @@
             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 @@
      $                  REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
      $                  NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W )
             GO TO 190
+*           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,
+     $                  CC, CS, CT, G )
+            GO TO 190
+
 *
   190       IF( FATAL.AND.SFATAL )
      $         GO TO 210
@@ -392,8 +401,8 @@
      $      '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' )
@@ -424,7 +433,7 @@
       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 ),
@@ -709,7 +718,7 @@
       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 ),
@@ -989,7 +998,7 @@
       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 ),
@@ -1299,7 +1308,7 @@
       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 ),
@@ -1632,7 +1641,7 @@
       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 ),
@@ -2003,12 +2012,12 @@
 *
 *     .. Scalar Arguments ..
       INTEGER            ISNUM, NOUT
-      CHARACTER*6        SRNAMT
+      CHARACTER*7        SRNAMT
 *     .. Scalars in Common ..
       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 @@
       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 @@
       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 @@
       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 @@
       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 @@
       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 @@
       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 @@
       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 @@
       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 @@
       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,204 @@
       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 ZGEMMTR( '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 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 ZGEMMTR( '/', 'N', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 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 ZGEMMTR( '/', 'T', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 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 ZGEMMTR( '/', 'C', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 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 ZGEMMTR( '/', 'C', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+
+      INFOT = 2
+      CALL ZGEMMTR( 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 2
+      CALL ZGEMMTR( 'U', '/', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 2
+      CALL ZGEMMTR( 'U', '/', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 2
+      CALL ZGEMMTR( 'L', '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 2
+      CALL ZGEMMTR( 'L', '/', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 2
+      CALL ZGEMMTR( 'L', '/', 'T', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+
+      INFOT = 3
+      CALL ZGEMMTR( 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 3
+      CALL ZGEMMTR( 'U', 'C', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 3
+      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 CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 4
+      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 CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 4
+      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 CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 4
+      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 CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 4
+      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 CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 5
+      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 CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 5
+      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 CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 5
+      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 CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 5
+      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 CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 5
+      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 ZGEMMTR( 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 8
+      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 ZGEMMTR( 'U', 'N', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 8
+      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 ZGEMMTR( 'U', 'C', 'C', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 8
+      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 ZGEMMTR( 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 8
+      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 ZGEMMTR( 'U', 'T', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+
+      INFOT = 10
+      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 ZGEMMTR( 'U', 'C', 'N', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 10
+      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 ZGEMMTR( 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 13
+      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 ZGEMMTR( 'U', 'N', 'T', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 13
+      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 ZGEMMTR( 'U', 'C', 'C', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 13
+      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 ZGEMMTR( 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+      CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+      INFOT = 13
+      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 ZGEMMTR( '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
@@ -3426,7 +3631,7 @@
 *     .. 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
@@ -3462,11 +3667,11 @@
 *
 *     .. 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
@@ -3496,3 +3701,498 @@
 *     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 ZGEMMTR.
+*
+*  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*7        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,
+     $                   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, ' ', 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 ZGEMMTR( 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', ' ', 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
+         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, 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
+

BLAS/TESTING/zblat3.in

@@ -12,12 +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.

CBLAS/examples/cblas_example2_64.c

@@ -1,10 +1,11 @@
 /* cblas_example2.c */
 
+#define CBLAS_API64
+#define F77_INT int64_t
+
 #include <stdio.h>
 #include <stdlib.h>
 #include "cblas_64.h"
-#define CBLAS_API64
-#define F77_INT int64_t
 #include "cblas_f77.h"
 
 #define INVALID -1

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_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,
+                 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_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,
+                 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_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,
+                 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_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,
+                 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,

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_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,
+                 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_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,
+                 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_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,
+                 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_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,
+                 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,

CBLAS/include/cblas_f77.h

@@ -17,6 +17,10 @@
 *  or make the str argument into a struct. */
 #define BLAS_FORTRAN_STRLEN_END
 
+#ifndef FORTRAN_STRLEN
+  #define FORTRAN_STRLEN size_t
+#endif
+
 #ifdef CRAY
    #include <fortran.h>
    #define F77_CHAR _fcd
@@ -193,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_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_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_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_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)
@@ -385,6 +393,7 @@
    /* Single Precision */
 
    #define F77_sgemm(...)     F77_sgemm_base(__VA_ARGS__, 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)
@@ -394,6 +403,7 @@
    /* Double Precision */
 
    #define F77_dgemm(...)     F77_dgemm_base(__VA_ARGS__, 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)
@@ -403,6 +413,7 @@
    /* Single Complex Precision */
 
    #define F77_cgemm(...)     F77_cgemm_base(__VA_ARGS__, 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)
@@ -415,6 +426,7 @@
    /* Double Complex Precision */
 
    #define F77_zgemm(...)     F77_zgemm_base(__VA_ARGS__, 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)
@@ -509,6 +521,7 @@
    /* Single Precision */
 
    #define F77_sgemm(...)     F77_sgemm_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__)
@@ -518,6 +531,7 @@
    /* Double Precision */
 
    #define F77_dgemm(...)     F77_dgemm_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__)
@@ -527,6 +541,7 @@
    /* Single Complex Precision */
 
    #define F77_cgemm(...)     F77_cgemm_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__)
@@ -539,6 +554,7 @@
    /* Double Complex Precision */
 
    #define F77_zgemm(...)     F77_zgemm_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__)
@@ -569,7 +585,7 @@ __attribute__((weak))
 #endif
 F77_xerbla_base(FCHAR, void *
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 
@@ -652,78 +668,78 @@ void F77_dcabs1_sub_base(const void *, double *);
 
 void F77_sgemv_base(FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_sgbmv_base(FCHAR, FINT, FINT, FINT, FINT, const float *,  const float *, FINT, const float *, FINT, const float *, float *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_ssymv_base(FCHAR, FINT, const float *, const float *, FINT, const float *,  FINT, const float *, float *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_ssbmv_base(FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_sspmv_base(FCHAR, FINT, const float *, const float *, const float *, FINT, const float *, float *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_strmv_base(FCHAR, FCHAR, FCHAR, FINT, const float *, FINT, float *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_stbmv_base(FCHAR, FCHAR, FCHAR, FINT, FINT, const float *, FINT, float *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_strsv_base(FCHAR, FCHAR, FCHAR, FINT, const float *, FINT, float *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_stbsv_base(FCHAR, FCHAR, FCHAR, FINT, FINT, const float *, FINT, float *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_stpmv_base(FCHAR, FCHAR, FCHAR, FINT, const float *, float *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_stpsv_base(FCHAR, FCHAR, FCHAR, FINT, const float *, float *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_sger_base(FINT, FINT, const float *, const float *, FINT, const float *, FINT, float *, FINT);
 void F77_ssyr_base(FCHAR, FINT, const float *, const float *, FINT, float *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_sspr_base(FCHAR, FINT, const float *, const float *, FINT, float *
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_sspr2_base(FCHAR, FINT, const float *, const float *, FINT, const float *, FINT,  float *
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_ssyr2_base(FCHAR, FINT, const float *, const float *, FINT, const float *, FINT,  float *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 
@@ -731,78 +747,78 @@ void F77_ssyr2_base(FCHAR, FINT, const float *, const float *, FINT, const float
 
 void F77_dgemv_base(FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_dgbmv_base(FCHAR, FINT, FINT, FINT, FINT, const double *,  const double *, FINT, const double *, FINT, const double *, double *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_dsymv_base(FCHAR, FINT, const double *, const double *, FINT, const double *,  FINT, const double *, double *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_dsbmv_base(FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_dspmv_base(FCHAR, FINT, const double *, const double *, const double *, FINT, const double *, double *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_dtrmv_base(FCHAR, FCHAR, FCHAR, FINT, const double *, FINT, double *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_dtbmv_base(FCHAR, FCHAR, FCHAR, FINT, FINT, const double *, FINT, double *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_dtrsv_base(FCHAR, FCHAR, FCHAR, FINT, const double *, FINT, double *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_dtbsv_base(FCHAR, FCHAR, FCHAR, FINT, FINT, const double *, FINT, double *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_dtpmv_base(FCHAR, FCHAR, FCHAR, FINT, const double *, double *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_dtpsv_base(FCHAR, FCHAR, FCHAR, FINT, const double *, double *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_dger_base(FINT, FINT, const double *, const double *, FINT, const double *, FINT, double *, FINT);
 void F77_dsyr_base(FCHAR, FINT, const double *, const double *, FINT, double *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_dspr_base(FCHAR, FINT, const double *, const double *, FINT, double *
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_dspr2_base(FCHAR, FINT, const double *, const double *, FINT, const double *, FINT,  double *
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_dsyr2_base(FCHAR, FINT, const double *, const double *, FINT, const double *, FINT,  double *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 
@@ -810,79 +826,79 @@ void F77_dsyr2_base(FCHAR, FINT, const double *, const double *, FINT, const dou
 
 void F77_cgemv_base(FCHAR, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_cgbmv_base(FCHAR, FINT, FINT, FINT, FINT, const void *,  const void *, FINT, const void *, FINT, const void *, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_chemv_base(FCHAR, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_chbmv_base(FCHAR, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_chpmv_base(FCHAR, FINT, const void *, const void *, const void *, FINT, const void *, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_ctrmv_base(FCHAR, FCHAR, FCHAR, FINT, const void *, FINT, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_ctbmv_base(FCHAR, FCHAR, FCHAR, FINT, FINT, const void *, FINT, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_ctpmv_base(FCHAR, FCHAR, FCHAR, FINT, const void *, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_ctrsv_base(FCHAR, FCHAR, FCHAR, FINT, const void *, FINT, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_ctbsv_base(FCHAR, FCHAR, FCHAR, FINT, FINT, const void *, FINT, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_ctpsv_base(FCHAR, FCHAR, FCHAR, FINT, const void *, void *,FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_cgerc_base(FINT, FINT, const void *, const void *, FINT, const void *, FINT, void *, FINT);
 void F77_cgeru_base(FINT, FINT, const void *, const void *, FINT, const void *, FINT, void *,  FINT);
 void F77_cher_base(FCHAR, FINT, const float *, const void *, FINT, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_cher2_base(FCHAR, FINT, const void *, const void *, FINT, const void *, FINT, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_chpr_base(FCHAR, FINT, const float *, const void *, FINT, void *
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
-void F77_chpr2_base(FCHAR, FINT, const float *, const void *, FINT, const void *, FINT, void *
+void F77_chpr2_base(FCHAR, FINT, const void *, const void *, FINT, const void *, FINT, void *
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 
@@ -890,79 +906,79 @@ void F77_chpr2_base(FCHAR, FINT, const float *, const void *, FINT, const void *
 
 void F77_zgemv_base(FCHAR, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_zgbmv_base(FCHAR, FINT, FINT, FINT, FINT, const void *,  const void *, FINT, const void *, FINT, const void *, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_zhemv_base(FCHAR, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_zhbmv_base(FCHAR, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_zhpmv_base(FCHAR, FINT, const void *, const void *, const void *, FINT, const void *, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_ztrmv_base(FCHAR, FCHAR, FCHAR, FINT, const void *, FINT, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_ztbmv_base(FCHAR, FCHAR, FCHAR, FINT, FINT, const void *, FINT, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_ztpmv_base(FCHAR, FCHAR, FCHAR, FINT, const void *, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_ztrsv_base(FCHAR, FCHAR, FCHAR, FINT, const void *, FINT, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_ztbsv_base(FCHAR, FCHAR, FCHAR, FINT, FINT, const void *, FINT, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_ztpsv_base(FCHAR, FCHAR, FCHAR, FINT, const void *, void *,FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_zgerc_base(FINT, FINT, const void *, const void *, FINT, const void *, FINT, void *, FINT);
 void F77_zgeru_base(FINT, FINT, const void *, const void *, FINT, const void *, FINT, void *,  FINT);
 void F77_zher_base(FCHAR, FINT, const double *, const void *, FINT, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_zher2_base(FCHAR, FINT, const void *, const void *, FINT, const void *, FINT, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 void F77_zhpr_base(FCHAR, FINT, const double *, const void *, FINT, void *
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
-void F77_zhpr2_base(FCHAR, FINT, const double *, const void *, FINT, const void *, FINT, void *
+void F77_zhpr2_base(FCHAR, FINT, const void *, const void *, FINT, const void *, FINT, void *
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t
+   , FORTRAN_STRLEN
 #endif
 );
 
@@ -974,32 +990,38 @@ void F77_zhpr2_base(FCHAR, FINT, const double *, const void *, FINT, const void
 
 void F77_sgemm_base(FCHAR, FCHAR, FINT, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
+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
+);
+
 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
-   , size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_ssyrk_base(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, float *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_ssyr2k_base(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
+   , FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_strmm_base(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, float *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_strsm_base(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, float *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 
@@ -1007,128 +1029,148 @@ void F77_strsm_base(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const float *, const
 
 void F77_dgemm_base(FCHAR, FCHAR, FINT, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
+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
+);
+
 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
-   , size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_dsyrk_base(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, double *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_dsyr2k_base(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
+   , FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_dtrmm_base(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, double *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 void F77_dtrsm_base(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, double *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 
 /* Single Complex Precision */
 
-void F77_cgemm_base(FCHAR, FCHAR, FINT, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT
+void F77_cgemm_base(FCHAR, FCHAR, FINT, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
-void F77_csymm_base(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, 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
-   , size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
-void F77_chemm_base(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT
+
+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
-   , size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
-void F77_csyrk_base(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, float *, FINT
+void F77_chemm_base(FCHAR, FCHAR, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
-void F77_cherk_base(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, float *, FINT
+void F77_csyrk_base(FCHAR, FCHAR, FINT, FINT, const void *, const void *, FINT, const void *, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
-void F77_csyr2k_base(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT
+void F77_cherk_base(FCHAR, FCHAR, FINT, FINT, const float *, const void *, FINT, const float *, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
-void F77_cher2k_base(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT
+void F77_csyr2k_base(FCHAR, FCHAR, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
-void F77_ctrmm_base(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, float *, FINT
+void F77_cher2k_base(FCHAR, FCHAR, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const float *, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
-void F77_ctrsm_base(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, float *, FINT
+void F77_ctrmm_base(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const void *, const void *, FINT, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
+#endif
+);
+void F77_ctrsm_base(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const void *, const void *, FINT, void *, FINT
+#ifdef BLAS_FORTRAN_STRLEN_END
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 
 /* Double Complex Precision */
 
-void F77_zgemm_base(FCHAR, FCHAR, FINT, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT
+void F77_zgemm_base(FCHAR, FCHAR, FINT, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
-void F77_zsymm_base(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, 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
-   , size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
-void F77_zhemm_base(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT
+
+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
-   , size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
-void F77_zsyrk_base(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, double *, FINT
+void F77_zhemm_base(FCHAR, FCHAR, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
-void F77_zherk_base(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, double *, FINT
+void F77_zsyrk_base(FCHAR, FCHAR, FINT, FINT, const void *, const void *, FINT, const void *, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
-void F77_zsyr2k_base(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT
+void F77_zherk_base(FCHAR, FCHAR, FINT, FINT, const double *, const void *, FINT, const double *, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
-void F77_zher2k_base(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT
+void F77_zsyr2k_base(FCHAR, FCHAR, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const void *, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
-void F77_ztrmm_base(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, double *, FINT
+void F77_zher2k_base(FCHAR, FCHAR, FINT, FINT, const void *, const void *, FINT, const void *, FINT, const double *, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
-void F77_ztrsm_base(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, double *, FINT
+void F77_ztrmm_base(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const void *, const void *, FINT, void *, FINT
 #ifdef BLAS_FORTRAN_STRLEN_END
-   , size_t, size_t, size_t, size_t
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
+#endif
+);
+void F77_ztrsm_base(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const void *, const void *, FINT, void *, FINT
+#ifdef BLAS_FORTRAN_STRLEN_END
+   , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN
 #endif
 );
 

CBLAS/include/cblas_test.h

@@ -7,6 +7,15 @@
 #include "cblas.h"
 #include "cblas_mangling.h"
 
+/* It seems all current Fortran compilers put strlen at end.
+*  Some historical compilers put strlen after the str argument
+*  or make the str argument into a struct. */
+#define BLAS_FORTRAN_STRLEN_END
+
+#ifndef FORTRAN_STRLEN
+  #define FORTRAN_STRLEN size_t
+#endif
+
 #define  TRUE           1
 #define  PASSED         1
 #define  TEST_ROW_MJR	1
@@ -158,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_sgemmtr 		F77_GLOBAL(csgemmtr,CSGEMMTR)
 #define F77_ssymm 		F77_GLOBAL(cssymm,CSSYMM)
 #define F77_ssyrk 		F77_GLOBAL(cssyrk,CSSYRK)
 #define F77_ssyr2k 		F77_GLOBAL(cssyr2k,CSSYR2K)
 #define F77_strmm 		F77_GLOBAL(cstrmm,CSTRMM)
 #define F77_strsm 		F77_GLOBAL(cstrsm,CSTRSM)
 #define F77_dgemm 		F77_GLOBAL(cdgemm,CDGEMM)
+#define F77_dgemmtr 		F77_GLOBAL(cdgemmtr,CDGEMMTR)
 #define F77_dsymm 		F77_GLOBAL(cdsymm,CDSYMM)
 #define F77_dsyrk 		F77_GLOBAL(cdsyrk,CDSYRK)
 #define F77_dsyr2k 		F77_GLOBAL(cdsyr2k,CDSYR2K)
 #define F77_dtrmm 		F77_GLOBAL(cdtrmm,CDTRMM)
 #define F77_dtrsm 		F77_GLOBAL(cdtrsm,CDTRSM)
 #define F77_cgemm 		F77_GLOBAL(ccgemm,CCGEMM)
+#define F77_cgemmtr 		F77_GLOBAL(ccgemmtr,CCGEMMTR)
 #define F77_csymm 		F77_GLOBAL(ccsymm,CCSYMM)
 #define F77_csyrk 		F77_GLOBAL(ccsyrk,CCSYRK)
 #define F77_csyr2k 		F77_GLOBAL(ccsyr2k,CCSYR2K)
 #define F77_ctrmm 		F77_GLOBAL(cctrmm,CCTRMM)
 #define F77_ctrsm 		F77_GLOBAL(cctrsm,CCTRSM)
 #define F77_zgemm 		F77_GLOBAL(czgemm,CZGEMM)
+#define F77_zgemmtr 		F77_GLOBAL(czgemmtr,CZGEMMTR)
 #define F77_zsymm 		F77_GLOBAL(czsymm,CZSYMM)
 #define F77_zsyrk 		F77_GLOBAL(czsyrk,CZSYRK)
 #define F77_zsyr2k 		F77_GLOBAL(czsyr2k,CZSYR2K)

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_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_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
         cblas_cher2k.c cblas_ctrmm.c cblas_ctrsm.c cblas_csyrk.c
-        cblas_csyr2k.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_zsyr2k.c cblas_zgemmtr.c)
 
 
 set(SOURCES)

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_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_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_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_zsyr2k.o cblas_zgemmtr.o
 
 .PHONY: slib3 dlib3 clib3 zlib3
 # Single precision real

CBLAS/src/cblas_cgemmtr.c

@@ -0,0 +1,134 @@
+/*
+ *
+ * cblas_cgemmtr.c
+ * This program is a C interface to cgemmtr.
+ * Written by Martin Koehler, MPI Magdeburg
+ * 06/24/2024
+ *
+ */
+
+#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)
+{
+    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( 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(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
+
+        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 {
+            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);
+
+#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;
+}

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;

CBLAS/src/cblas_dgemmtr.c

@@ -0,0 +1,134 @@
+/*
+ *
+ * cblas_dgemmtr.c
+ * This program is a C interface to dgemmtr.
+ * Written by Martin Koehler, MPI Magdeburg
+ * 06/24/2024
+ *
+ */
+
+#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)
+{
+    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( 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(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
+
+        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;
+}

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;

CBLAS/src/cblas_sgemmtr.c

@@ -0,0 +1,136 @@
+
+/*
+ *
+ * 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)
+{
+    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( 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(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;
+        }
+
+#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)
+    {
+        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;
+        }
+
+
+        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;
+}

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;

CBLAS/src/cblas_zgemmtr.c

@@ -0,0 +1,135 @@
+/*
+ *
+ * cblas_zgemmtr.c
+ * This program is a C interface to zgemmtr.
+ * Written by Martin Koehler, MPI Magdeburg
+ * 06/24/2024
+ *
+ */
+
+#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)
+{
+    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( 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(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;
+        }
+
+#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);
+    }
+
+    else  API_SUFFIX(cblas_xerbla)(1, "cblas_zgemmtr", "Illegal layout setting, %d\n", layout);
+    CBLAS_CallFromC = 0;
+    RowMajorStrg = 0;
+    return;
+}

CBLAS/src/xerbla.c

@@ -17,7 +17,7 @@ F77_xerbla_base
 (char *srname, void *vinfo
 #endif
 #ifdef BLAS_FORTRAN_STRLEN_END
-, size_t len
+, FORTRAN_STRLEN len
 #endif
 )
 {

CBLAS/testing/c_c2chke.c

@@ -8,10 +8,14 @@ CBLAS_INT link_xerbla=TRUE;
 char *cblas_rout;
 
 #ifdef F77_Char
-void F77_xerbla(F77_Char F77_srname, void *vinfo);
+void F77_xerbla(F77_Char F77_srname, void *vinfo
 #else
-void F77_xerbla(char *srname, void *vinfo);
+void F77_xerbla(char *srname, void *vinfo
 #endif
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN srname_len
+#endif
+);
 
 void chkxer(void) {
    extern CBLAS_INT cblas_ok, cblas_lerr, cblas_info;
@@ -24,7 +28,11 @@ void chkxer(void) {
    cblas_lerr = 1 ;
 }
 
-void F77_c2chke(char *rout) {
+void F77_c2chke(char *rout
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN rout_len
+#endif
+) {
    char *sf = ( rout ) ;
    float  A[2] = {0.0,0.0},
           X[2] = {0.0,0.0},
@@ -40,7 +48,7 @@ void F77_c2chke(char *rout) {
    if (link_xerbla) /* call these first to link */
    {
       cblas_xerbla(cblas_info,cblas_rout,"");
-      F77_xerbla(cblas_rout,&cblas_info);
+      F77_xerbla(cblas_rout,&cblas_info, 1);
    }
 #endif
 

CBLAS/testing/c_c3chke.c

@@ -8,10 +8,14 @@ CBLAS_INT link_xerbla=TRUE;
 char *cblas_rout;
 
 #ifdef F77_Char
-void F77_xerbla(F77_Char F77_srname, void *vinfo);
+void F77_xerbla(F77_Char F77_srname, void *vinfo
 #else
-void F77_xerbla(char *srname, void *vinfo);
+void F77_xerbla(char *srname, void *vinfo
 #endif
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN srname_len
+#endif
+);
 
 void chkxer(void) {
    extern CBLAS_INT cblas_ok, cblas_lerr, cblas_info;
@@ -24,7 +28,11 @@ void chkxer(void) {
    cblas_lerr = 1 ;
 }
 
-void  F77_c3chke(char *  rout) {
+void  F77_c3chke(char *  rout
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN rout_len
+#endif
+) {
    char *sf = ( rout ) ;
    float   A[4]     = {0.0,0.0,0.0,0.0},
            B[4]     = {0.0,0.0,0.0,0.0},
@@ -43,11 +51,241 @@ void  F77_c3chke(char *  rout) {
    if (link_xerbla) /* call these first to link */
    {
       cblas_xerbla(cblas_info,cblas_rout,"");
-      F77_xerbla(cblas_rout,&cblas_info);
+      F77_xerbla(cblas_rout,&cblas_info, 1);
    }
 #endif
 
-   if (strncmp( sf,"cblas_cgemm"   ,11)==0) {
+   if (strncmp( sf,"cblas_cgemmtr"   ,13)==0) {
+      cblas_rout = "cblas_cgemmtr"   ;
+
+      cblas_info = 1;
+      cblas_cgemmtr( INVALID, CblasUpper, CblasNoTrans, CblasNoTrans, 0, 0,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+      cblas_info = 1;
+      cblas_cgemmtr( INVALID, CblasUpper, CblasNoTrans, CblasTrans, 0, 0,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+      cblas_info = 1;
+      cblas_cgemmtr( INVALID, CblasUpper,CblasTrans, CblasNoTrans, 0, 0,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+      cblas_info = 1;
+      cblas_cgemmtr( INVALID, CblasUpper, CblasTrans, CblasTrans, 0, 0,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+
+      cblas_info = 1;
+      cblas_cgemmtr( INVALID, CblasLower, CblasNoTrans, CblasNoTrans, 0, 0,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+      cblas_info = 1;
+      cblas_cgemmtr( INVALID, CblasLower, CblasNoTrans, CblasTrans, 0, 0,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+      cblas_info = 1;
+      cblas_cgemmtr( INVALID, CblasLower,CblasTrans, CblasNoTrans, 0, 0,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+      cblas_info = 1;
+      cblas_cgemmtr( INVALID, CblasLower, CblasTrans, CblasTrans, 0, 0,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+
+      cblas_info = 2; RowMajorStrg = FALSE;
+      cblas_cgemmtr( CblasColMajor,  INVALID, CblasNoTrans, CblasNoTrans, 0, 0,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+      cblas_info = 2; RowMajorStrg = FALSE;
+      cblas_cgemmtr( CblasColMajor,  INVALID, CblasNoTrans, CblasTrans, 0, 0,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+
+      cblas_info = 3; RowMajorStrg = FALSE;
+      cblas_cgemmtr( CblasColMajor,  CblasUpper, INVALID, CblasNoTrans, 0, 0,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+      cblas_info = 3; RowMajorStrg = FALSE;
+      cblas_cgemmtr( CblasColMajor,  CblasUpper, INVALID, CblasTrans, 0, 0,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+
+      cblas_info = 4; RowMajorStrg = FALSE;
+      cblas_cgemmtr( CblasColMajor, CblasUpper,  CblasNoTrans, INVALID, 0, 0,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+      cblas_info = 4; RowMajorStrg = FALSE;
+      cblas_cgemmtr( CblasColMajor, CblasUpper, CblasTrans, INVALID, 0, 0,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+
+
+      cblas_info = 5; RowMajorStrg = FALSE;
+      cblas_cgemmtr( CblasColMajor,  CblasUpper, CblasNoTrans, CblasNoTrans, INVALID, 0,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+      cblas_info = 5; RowMajorStrg = FALSE;
+      cblas_cgemmtr( CblasColMajor,  CblasUpper, CblasNoTrans, CblasTrans, INVALID, 0,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+      cblas_info = 5; RowMajorStrg = FALSE;
+      cblas_cgemmtr( CblasColMajor,  CblasUpper, CblasTrans, CblasNoTrans, INVALID, 0,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+      cblas_info = 5; RowMajorStrg = FALSE;
+      cblas_cgemmtr( CblasColMajor,  CblasUpper, CblasTrans, CblasTrans, INVALID, 0,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+
+      cblas_info = 6; RowMajorStrg = FALSE;
+      cblas_cgemmtr( CblasColMajor,  CblasUpper, CblasNoTrans, CblasNoTrans, 0, INVALID,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+      cblas_info = 6; RowMajorStrg = FALSE;
+      cblas_cgemmtr( CblasColMajor,  CblasUpper, CblasNoTrans, CblasTrans, 0, INVALID,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+      cblas_info = 6; RowMajorStrg = FALSE;
+      cblas_cgemmtr( CblasColMajor,  CblasUpper, CblasTrans, CblasNoTrans, 0, INVALID,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+      cblas_info = 6; RowMajorStrg = FALSE;
+      cblas_cgemmtr( CblasColMajor,  CblasUpper, CblasTrans, CblasTrans, 0, INVALID,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+
+
+      cblas_info = 9; RowMajorStrg = FALSE;
+      cblas_cgemmtr( CblasColMajor,  CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0,
+                   ALPHA, A, 1, B, 1, BETA, C, 2 );
+      chkxer();
+      cblas_info = 9; RowMajorStrg = FALSE;
+      cblas_cgemmtr( CblasColMajor,  CblasUpper, CblasNoTrans, CblasTrans, 2, 0,
+                   ALPHA, A, 1, B, 1, BETA, C, 2 );
+      chkxer();
+      cblas_info = 9; RowMajorStrg = FALSE;
+      cblas_cgemmtr( CblasColMajor,  CblasUpper, CblasTrans, CblasNoTrans, 0, 2,
+                   ALPHA, A, 1, B, 2, BETA, C, 1 );
+      chkxer();
+      cblas_info = 9; RowMajorStrg = FALSE;
+      cblas_cgemmtr( CblasColMajor,  CblasUpper, CblasTrans, CblasTrans, 0, 2,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+
+      cblas_info = 11; RowMajorStrg = FALSE;
+      cblas_cgemmtr( CblasColMajor,  CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+      cblas_info = 11; RowMajorStrg = FALSE;
+      cblas_cgemmtr( CblasColMajor,  CblasUpper, CblasTrans, CblasNoTrans, 0, 2,
+                   ALPHA, A, 2, B, 1, BETA, C, 1 );
+      chkxer();
+      cblas_info = 11; RowMajorStrg = FALSE;
+      cblas_cgemmtr( CblasColMajor,  CblasUpper, CblasTrans, CblasTrans, 2, 0,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+
+      cblas_info = 14; RowMajorStrg = FALSE;
+      cblas_cgemmtr( CblasColMajor,  CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0,
+                   ALPHA, A, 2, B, 1, BETA, C, 1 );
+      chkxer();
+      cblas_info = 14; RowMajorStrg = FALSE;
+      cblas_cgemmtr( CblasColMajor,  CblasUpper, CblasNoTrans, CblasTrans, 2, 0,
+                   ALPHA, A, 2, B, 2, BETA, C, 1 );
+      chkxer();
+
+      cblas_info = 14; RowMajorStrg = FALSE;
+      cblas_cgemmtr( CblasColMajor,  CblasUpper, CblasTrans, CblasNoTrans, 2, 0,
+                   ALPHA, A, 2, B, 1, BETA, C, 1 );
+      chkxer();
+      cblas_info = 14; RowMajorStrg = FALSE;
+      cblas_cgemmtr( CblasColMajor,  CblasUpper, CblasTrans, CblasTrans, 2, 0,
+                   ALPHA, A, 2, B, 2, BETA, C, 1 );
+      chkxer();
+
+      /* Row Major */
+      cblas_info = 5; RowMajorStrg = TRUE;
+      cblas_cgemmtr( CblasRowMajor,  CblasUpper, CblasNoTrans, CblasNoTrans, INVALID, 0,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+      cblas_info = 5; RowMajorStrg = TRUE;
+      cblas_cgemmtr( CblasRowMajor,  CblasUpper, CblasNoTrans, CblasTrans, INVALID, 0,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+      cblas_info = 5; RowMajorStrg = TRUE;
+      cblas_cgemmtr( CblasRowMajor,  CblasUpper, CblasTrans, CblasNoTrans, INVALID, 0,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+      cblas_info = 5; RowMajorStrg = TRUE;
+      cblas_cgemmtr( CblasRowMajor,  CblasUpper, CblasTrans, CblasTrans, INVALID, 0,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+
+      cblas_info = 6; RowMajorStrg = TRUE;
+      cblas_cgemmtr( CblasRowMajor,  CblasUpper, CblasNoTrans, CblasNoTrans, 0, INVALID,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+      cblas_info = 6; RowMajorStrg = TRUE;
+      cblas_cgemmtr( CblasRowMajor,  CblasUpper, CblasNoTrans, CblasTrans, 0, INVALID,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+      cblas_info = 6; RowMajorStrg = TRUE;
+      cblas_cgemmtr( CblasRowMajor,  CblasUpper, CblasTrans, CblasNoTrans, 0, INVALID,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+      cblas_info = 6; RowMajorStrg = TRUE;
+      cblas_cgemmtr( CblasRowMajor,  CblasUpper, CblasTrans, CblasTrans, 0, INVALID,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+
+      cblas_info = 9;  RowMajorStrg = TRUE;
+      cblas_cgemmtr( CblasRowMajor,  CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2,
+                   ALPHA, A, 1, B, 1, BETA, C, 2 );
+      chkxer();
+      cblas_info = 9; RowMajorStrg = TRUE;
+      cblas_cgemmtr( CblasRowMajor,  CblasUpper, CblasNoTrans, CblasTrans, 0, 2,
+                   ALPHA, A, 1, B, 2, BETA, C, 2 );
+      chkxer();
+      cblas_info = 9; RowMajorStrg = TRUE;
+      cblas_cgemmtr( CblasRowMajor,  CblasUpper, CblasTrans, CblasNoTrans, 2, 0,
+                   ALPHA, A, 1, B, 2, BETA, C, 1 );
+      chkxer();
+      cblas_info = 9; RowMajorStrg = TRUE;
+      cblas_cgemmtr( CblasRowMajor,  CblasUpper, CblasTrans, CblasTrans, 2, 0,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+
+      cblas_info = 11; RowMajorStrg = TRUE;
+      cblas_cgemmtr( CblasColMajor,  CblasUpper, CblasNoTrans, CblasNoTrans, 0, 2,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+      cblas_info = 11; RowMajorStrg = TRUE;
+      cblas_cgemmtr( CblasColMajor,  CblasUpper, CblasTrans, CblasNoTrans, 0, 2,
+                   ALPHA, A, 2, B, 1, BETA, C, 1 );
+      chkxer();
+      cblas_info = 11; RowMajorStrg = TRUE;
+      cblas_cgemmtr( CblasColMajor,  CblasUpper, CblasTrans, CblasTrans, 2, 0,
+                   ALPHA, A, 1, B, 1, BETA, C, 1 );
+      chkxer();
+
+      cblas_info = 14; RowMajorStrg = TRUE;
+      cblas_cgemmtr( CblasRowMajor,  CblasUpper, CblasNoTrans, CblasNoTrans, 2, 0,
+                   ALPHA, A, 2, B, 2, BETA, C, 1 );
+      chkxer();
+      cblas_info = 14; RowMajorStrg = TRUE;
+      cblas_cgemmtr( CblasRowMajor,  CblasUpper, CblasNoTrans, CblasTrans, 2, 0,
+                   ALPHA, A, 2, B, 1, BETA, C, 1 );
+      chkxer();
+      cblas_info = 14; RowMajorStrg = TRUE;
+      cblas_cgemmtr( CblasRowMajor,  CblasUpper, CblasTrans, CblasNoTrans, 2, 0,
+                   ALPHA, A, 2, B, 2, BETA, C, 1 );
+      chkxer();
+      cblas_info = 14; RowMajorStrg = TRUE;
+      cblas_cgemmtr( CblasRowMajor,  CblasUpper, CblasTrans, CblasTrans, 2, 0,
+                   ALPHA, A, 2, B, 2, BETA, C, 1 );
+      chkxer();
+
+   } else if (strncmp( sf,"cblas_cgemm"   ,11)==0) {
       cblas_rout = "cblas_cgemm"   ;
 
       cblas_info = 1;
@@ -274,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"   ;
 
@@ -1702,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);
 }

CBLAS/testing/c_cblas2.c

@@ -11,7 +11,11 @@
 void F77_cgemv(CBLAS_INT *layout, char *transp, CBLAS_INT *m, CBLAS_INT *n,
           const void *alpha,
           CBLAS_TEST_COMPLEX *a, CBLAS_INT *lda, const void *x, CBLAS_INT *incx,
-          const void *beta, void *y, CBLAS_INT *incy) {
+          const void *beta, void *y, CBLAS_INT *incy
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN transp_len
+#endif
+) {
 
   CBLAS_TEST_COMPLEX *A;
   CBLAS_INT i,j,LDA;
@@ -41,7 +45,11 @@ void F77_cgemv(CBLAS_INT *layout, char *transp, CBLAS_INT *m, CBLAS_INT *n,
 void F77_cgbmv(CBLAS_INT *layout, char *transp, CBLAS_INT *m, CBLAS_INT *n, CBLAS_INT *kl, CBLAS_INT *ku,
 	      CBLAS_TEST_COMPLEX *alpha, 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) {
+	      CBLAS_TEST_COMPLEX *beta, CBLAS_TEST_COMPLEX *y, CBLAS_INT *incy
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN transp_len
+#endif
+) {
 
   CBLAS_TEST_COMPLEX *A;
   CBLAS_INT i,j,irow,jcol,LDA;
@@ -144,7 +152,11 @@ void F77_cgerc(CBLAS_INT *layout, CBLAS_INT *m, CBLAS_INT *n, CBLAS_TEST_COMPLEX
 
 void F77_chemv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_TEST_COMPLEX *alpha,
       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){
+      CBLAS_INT *incx, CBLAS_TEST_COMPLEX *beta, CBLAS_TEST_COMPLEX *y, CBLAS_INT *incy
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len
+#endif
+){
 
   CBLAS_TEST_COMPLEX *A;
   CBLAS_INT i,j,LDA;
@@ -175,7 +187,11 @@ void F77_chemv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_TEST_COMPLEX
 void F77_chbmv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_INT *k,
      CBLAS_TEST_COMPLEX *alpha, 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){
+     CBLAS_TEST_COMPLEX *y, CBLAS_INT *incy
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len
+#endif
+){
 
 CBLAS_TEST_COMPLEX *A;
 CBLAS_INT i,irow,j,jcol,LDA;
@@ -238,7 +254,11 @@ CBLAS_INT i,irow,j,jcol,LDA;
 
 void F77_chpmv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_TEST_COMPLEX *alpha,
      CBLAS_TEST_COMPLEX *ap, CBLAS_TEST_COMPLEX *x, CBLAS_INT *incx,
-     CBLAS_TEST_COMPLEX *beta, CBLAS_TEST_COMPLEX *y, CBLAS_INT *incy){
+     CBLAS_TEST_COMPLEX *beta, CBLAS_TEST_COMPLEX *y, CBLAS_INT *incy
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len
+#endif
+){
 
   CBLAS_TEST_COMPLEX *A, *AP;
   CBLAS_INT i,j,k,LDA;
@@ -294,7 +314,11 @@ void F77_chpmv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_TEST_COMPLEX
 
 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) {
+     CBLAS_INT *incx
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
   CBLAS_TEST_COMPLEX *A;
   CBLAS_INT irow, jcol, i, j, LDA;
   CBLAS_TRANSPOSE trans;
@@ -357,7 +381,11 @@ void F77_ctbmv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn,
 
 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) {
+      CBLAS_INT *incx
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
 
   CBLAS_TEST_COMPLEX *A;
   CBLAS_INT irow, jcol, i, j, LDA;
@@ -420,7 +448,11 @@ 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) {
+      CBLAS_INT *n, CBLAS_TEST_COMPLEX *ap, CBLAS_TEST_COMPLEX *x, CBLAS_INT *incx
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len , FORTRAN_STRLEN diagn_len
+#endif
+) {
   CBLAS_TEST_COMPLEX *A, *AP;
   CBLAS_INT i, j, k, LDA;
   CBLAS_TRANSPOSE trans;
@@ -475,7 +507,11 @@ 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) {
+     CBLAS_INT *n, CBLAS_TEST_COMPLEX *ap, CBLAS_TEST_COMPLEX *x, CBLAS_INT *incx
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
   CBLAS_TEST_COMPLEX *A, *AP;
   CBLAS_INT i, j, k, LDA;
   CBLAS_TRANSPOSE trans;
@@ -531,7 +567,11 @@ void F77_ctpsv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn,
 
 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) {
+      CBLAS_INT *incx
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
   CBLAS_TEST_COMPLEX *A;
   CBLAS_INT i,j,LDA;
   CBLAS_TRANSPOSE trans;
@@ -560,7 +600,11 @@ void F77_ctrmv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn,
 }
 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) {
+              CBLAS_INT *incx
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
   CBLAS_TEST_COMPLEX *A;
   CBLAS_INT i,j,LDA;
   CBLAS_TRANSPOSE trans;
@@ -589,7 +633,11 @@ 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) {
+	     CBLAS_TEST_COMPLEX *x, CBLAS_INT *incx, CBLAS_TEST_COMPLEX *ap
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len
+#endif
+) {
   CBLAS_TEST_COMPLEX *A, *AP;
   CBLAS_INT i,j,k,LDA;
   CBLAS_UPLO uplo;
@@ -665,7 +713,11 @@ void F77_chpr(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, float *alpha,
 
 void F77_chpr2(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_TEST_COMPLEX *alpha,
        CBLAS_TEST_COMPLEX *x, CBLAS_INT *incx, CBLAS_TEST_COMPLEX *y, CBLAS_INT *incy,
-       CBLAS_TEST_COMPLEX *ap) {
+       CBLAS_TEST_COMPLEX *ap
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len
+#endif
+) {
   CBLAS_TEST_COMPLEX *A, *AP;
   CBLAS_INT i,j,k,LDA;
   CBLAS_UPLO uplo;
@@ -741,7 +793,11 @@ 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) {
+  CBLAS_TEST_COMPLEX *x, CBLAS_INT *incx, CBLAS_TEST_COMPLEX *a, CBLAS_INT *lda
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len
+#endif
+) {
   CBLAS_TEST_COMPLEX *A;
   CBLAS_INT i,j,LDA;
   CBLAS_UPLO uplo;
@@ -774,7 +830,11 @@ void F77_cher(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, float *alpha,
 
 void F77_cher2(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_TEST_COMPLEX *alpha,
           CBLAS_TEST_COMPLEX *x, CBLAS_INT *incx, CBLAS_TEST_COMPLEX *y, CBLAS_INT *incy,
-	  CBLAS_TEST_COMPLEX *a, CBLAS_INT *lda) {
+	  CBLAS_TEST_COMPLEX *a, CBLAS_INT *lda
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len
+#endif
+) {
 
   CBLAS_TEST_COMPLEX *A;
   CBLAS_INT i,j,LDA;

CBLAS/testing/c_cblas3.c

@@ -14,7 +14,11 @@
 void F77_cgemm(CBLAS_INT *layout, char *transpa, char *transpb, CBLAS_INT *m, 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 *c, CBLAS_INT *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN transpa_len, FORTRAN_STRLEN transpb_len
+#endif
+) {
 
   CBLAS_TEST_COMPLEX *A, *B, *C;
   CBLAS_INT i,j,LDA, LDB, LDC;
@@ -87,10 +91,95 @@ 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_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 ) {
+
+  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_cgemmtr( CblasRowMajor, uplo, transa, transb, *n, *k, alpha, A, LDA,
+                  B, LDB, beta, C, LDC );
+     for( j=0; j<*n; j++ )
+        for( i=0; i<*n; i++ ) {
+           c[j*(*ldc)+i].real=C[i*LDC+j].real;
+           c[j*(*ldc)+i].imag=C[i*LDC+j].imag;
+        }
+     free(A);
+     free(B);
+     free(C);
+  }
+  else if (*layout == TEST_COL_MJR)
+     cblas_cgemmtr( CblasColMajor, uplo, transa, transb, *n, *k, alpha, a, *lda,
+                  b, *ldb, beta, c, *ldc );
+  else
+     cblas_cgemmtr( UNDEFINED, uplo, transa, transb, *n, *k, alpha, a, *lda,
+                  b, *ldb, beta, c, *ldc );
+}
+
+
 void F77_chemm(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,
-        CBLAS_TEST_COMPLEX *c, CBLAS_INT *ldc ) {
+	      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 rtlf_len, FORTRAN_STRLEN uplow_len
+#endif
+) {
 
   CBLAS_TEST_COMPLEX *A, *B, *C;
   CBLAS_INT i,j,LDA, LDB, LDC;
@@ -153,8 +242,12 @@ void F77_chemm(CBLAS_INT *layout, char *rtlf, char *uplow, CBLAS_INT *m, CBLAS_I
 }
 void F77_csymm(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,
-          CBLAS_TEST_COMPLEX *c, CBLAS_INT *ldc ) {
+	        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 rtlf_len, FORTRAN_STRLEN uplow_len
+#endif
+) {
 
   CBLAS_TEST_COMPLEX *A, *B, *C;
   CBLAS_INT i,j,LDA, LDB, LDC;
@@ -208,7 +301,11 @@ void F77_csymm(CBLAS_INT *layout, char *rtlf, char *uplow, CBLAS_INT *m, CBLAS_I
 
 void F77_cherk(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLAS_INT *k,
      float *alpha, CBLAS_TEST_COMPLEX *a, CBLAS_INT *lda,
-     float *beta, CBLAS_TEST_COMPLEX *c, CBLAS_INT *ldc ) {
+     float *beta, CBLAS_TEST_COMPLEX *c, CBLAS_INT *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len
+#endif
+) {
 
   CBLAS_INT i,j,LDA,LDC;
   CBLAS_TEST_COMPLEX *A, *C;
@@ -264,7 +361,11 @@ void F77_cherk(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLAS
 
 void F77_csyrk(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLAS_INT *k,
      CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, CBLAS_INT *lda,
-     CBLAS_TEST_COMPLEX *beta, CBLAS_TEST_COMPLEX *c, CBLAS_INT *ldc ) {
+     CBLAS_TEST_COMPLEX *beta, CBLAS_TEST_COMPLEX *c, CBLAS_INT *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len
+#endif
+) {
 
   CBLAS_INT i,j,LDA,LDC;
   CBLAS_TEST_COMPLEX *A, *C;
@@ -320,7 +421,11 @@ void F77_csyrk(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLAS
 void F77_cher2k(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLAS_INT *k,
         CBLAS_TEST_COMPLEX *alpha, CBLAS_TEST_COMPLEX *a, CBLAS_INT *lda,
 	CBLAS_TEST_COMPLEX *b, CBLAS_INT *ldb, float *beta,
-        CBLAS_TEST_COMPLEX *c, CBLAS_INT *ldc ) {
+        CBLAS_TEST_COMPLEX *c, CBLAS_INT *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len
+#endif
+) {
   CBLAS_INT i,j,LDA,LDB,LDC;
   CBLAS_TEST_COMPLEX *A, *B, *C;
   CBLAS_UPLO uplo;
@@ -384,7 +489,11 @@ void F77_cher2k(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLA
 void F77_csyr2k(CBLAS_INT *layout, char *uplow, char *transp, 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 *c, CBLAS_INT *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len
+#endif
+) {
   CBLAS_INT i,j,LDA,LDB,LDC;
   CBLAS_TEST_COMPLEX *A, *B, *C;
   CBLAS_UPLO uplo;
@@ -447,7 +556,11 @@ void F77_csyr2k(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLA
 }
 void F77_ctrmm(CBLAS_INT *layout, char *rtlf, char *uplow, char *transp, char *diagn,
        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_INT *lda, CBLAS_TEST_COMPLEX *b, CBLAS_INT *ldb
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
   CBLAS_INT i,j,LDA,LDB;
   CBLAS_TEST_COMPLEX *A, *B;
   CBLAS_SIDE side;
@@ -506,7 +619,11 @@ void F77_ctrmm(CBLAS_INT *layout, char *rtlf, char *uplow, char *transp, char *d
 
 void F77_ctrsm(CBLAS_INT *layout, char *rtlf, char *uplow, char *transp, char *diagn,
          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_INT *lda, CBLAS_TEST_COMPLEX *b, CBLAS_INT *ldb
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
   CBLAS_INT i,j,LDA,LDB;
   CBLAS_TEST_COMPLEX *A, *B;
   CBLAS_SIDE side;

CBLAS/testing/c_cblat2.f

@@ -349,13 +349,13 @@
            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.

CBLAS/testing/c_cblat3.f

@@ -3,10 +3,10 @@
 *  Test program for the COMPLEX          Level 3 Blas.
 *
 *  The program must be driven by a short data file. The first 13 records
-*  of the file are read using list-directed input, the last 9 records
-*  are read using the format ( A12, L2 ). An annotated example of a data
+*  of the file are read using list-directed input, the last 10 records
+*  are read using the format ( A13, L2 ). An annotated example of a data
 *  file can be obtained by deleting the first 3 characters from the
-*  following 22 lines:
+*  following 23 lines:
 *  'CBLAT3.SNAP'     NAME OF SNAPSHOT OUTPUT FILE
 *  -1                UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
 *  F        LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
@@ -20,15 +20,16 @@
 *  (0.0,0.0) (1.0,0.0) (0.7,-0.9)       VALUES OF ALPHA
 *  3                 NUMBER OF VALUES OF BETA
 *  (0.0,0.0) (1.0,0.0) (1.3,-1.1)       VALUES OF BETA
-*  cblas_cgemm  T PUT F FOR NO TEST. SAME COLUMNS.
-*  cblas_chemm  T PUT F FOR NO TEST. SAME COLUMNS.
-*  cblas_csymm  T PUT F FOR NO TEST. SAME COLUMNS.
-*  cblas_ctrmm  T PUT F FOR NO TEST. SAME COLUMNS.
-*  cblas_ctrsm  T PUT F FOR NO TEST. SAME COLUMNS.
-*  cblas_cherk  T PUT F FOR NO TEST. SAME COLUMNS.
-*  cblas_csyrk  T PUT F FOR NO TEST. SAME COLUMNS.
-*  cblas_cher2k T PUT F FOR NO TEST. SAME COLUMNS.
-*  cblas_csyr2k T PUT F FOR NO TEST. SAME COLUMNS.
+*  cblas_cgemm   T PUT F FOR NO TEST. SAME COLUMNS.
+*  cblas_chemm   T PUT F FOR NO TEST. SAME COLUMNS.
+*  cblas_csymm   T PUT F FOR NO TEST. SAME COLUMNS.
+*  cblas_ctrmm   T PUT F FOR NO TEST. SAME COLUMNS.
+*  cblas_ctrsm   T PUT F FOR NO TEST. SAME COLUMNS.
+*  cblas_cherk   T PUT F FOR NO TEST. SAME COLUMNS.
+*  cblas_csyrk   T PUT F FOR NO TEST. SAME COLUMNS.
+*  cblas_cher2k  T PUT F FOR NO TEST. SAME COLUMNS.
+*  cblas_csyr2k  T PUT F FOR NO TEST. SAME COLUMNS.
+*  cblas_cgemmtr T PUT F FOR NO TEST. SAME COLUMNS.
 *
 *  See:
 *
@@ -49,7 +50,7 @@
       INTEGER            NIN, NOUT
       PARAMETER          ( NIN = 5, NOUT = 6 )
       INTEGER            NSUBS
-      PARAMETER          ( NSUBS = 9 )
+      PARAMETER          ( NSUBS = 10 )
       COMPLEX            ZERO, ONE
       PARAMETER          ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) )
       REAL               RZERO, RHALF, RONE
@@ -65,7 +66,7 @@
       LOGICAL            FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
      $                   TSTERR, CORDER, RORDER
       CHARACTER*1        TRANSA, TRANSB
-      CHARACTER*12       SNAMET
+      CHARACTER*13       SNAMET
       CHARACTER*32       SNAPS
 *     .. Local Arrays ..
       COMPLEX            AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ),
@@ -77,19 +78,19 @@
       REAL               G( NMAX )
       INTEGER            IDIM( NIDMAX )
       LOGICAL            LTEST( NSUBS )
-      CHARACTER*12       SNAMES( NSUBS )
+      CHARACTER*13       SNAMES( NSUBS )
 *     .. External Functions ..
       REAL               SDIFF
       LOGICAL            LCE
       EXTERNAL           SDIFF, LCE
 *     .. External Subroutines ..
-      EXTERNAL         CCHK1, CCHK2, CCHK3, CCHK4, CCHK5, CMMCH
+      EXTERNAL         CCHK1, CCHK2, CCHK3, CCHK4, CCHK5, CCHK6, CMMCH
 *     .. Intrinsic Functions ..
       INTRINSIC          MAX, MIN
 *     .. Scalars in Common ..
       INTEGER            INFOT, NOUTC
       LOGICAL            LERR, OK
-      CHARACTER*12       SRNAMT
+      CHARACTER*13       SRNAMT
 *     .. Common blocks ..
       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
       COMMON             /SRNAMC/SRNAMT
@@ -97,7 +98,7 @@
       DATA               SNAMES/'cblas_cgemm ', 'cblas_chemm ',
      $                   'cblas_csymm ', 'cblas_ctrmm ', 'cblas_ctrsm ',
      $                   'cblas_cherk ', 'cblas_csyrk ', 'cblas_cher2k',
-     $                   'cblas_csyr2k'/
+     $                   'cblas_csyr2k', 'cblas_cgemmtr' /
 *     .. Executable Statements ..
 *
       NOUTC = NOUT
@@ -295,7 +296,7 @@
             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 @@
             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 @@
             CALL CCHK5(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
      $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
      $                 NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W,
-     $		0 )
+     $      0 )
             END IF
             IF (RORDER) THEN
             CALL CCHK5(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
      $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
      $                 NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W,
-     $		1 )
+     $      1 )
             END IF
             GO TO 190
+*           Test CGEMMTR, 10.
+  185       IF (CORDER) THEN
+            CALL CCHK6(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
+     $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
+     $                 NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
+     $                 CC, CS, CT, G, 0 )
+            END IF
+            IF (RORDER) THEN
+            CALL CCHK6(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
+     $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
+     $                 NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
+     $                 CC, CS, CT, G, 1 )
+            END IF
+            GO TO 190
+
 *
   190       IF( FATAL.AND.SFATAL )
      $         GO TO 210
@@ -405,7 +421,7 @@
      $      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,
@@ -413,8 +429,8 @@
      $    ' 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' )
@@ -446,7 +462,7 @@
       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 ),
@@ -694,20 +710,20 @@
   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 *',
@@ -722,7 +738,7 @@
       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
@@ -747,7 +763,7 @@
       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
@@ -776,7 +792,7 @@
       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 ),
@@ -1020,20 +1036,20 @@
   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 *',
@@ -1048,7 +1064,7 @@
       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
@@ -1069,7 +1085,7 @@
       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
@@ -1097,7 +1113,7 @@
       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 ),
@@ -1372,20 +1388,20 @@
   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 *',
@@ -1400,7 +1416,7 @@
       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
@@ -1433,7 +1449,7 @@
       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
@@ -1462,7 +1478,7 @@
       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 ),
@@ -1754,24 +1770,24 @@
   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 *',
@@ -1786,7 +1802,7 @@
       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
@@ -1809,7 +1825,7 @@
       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
@@ -1820,7 +1836,7 @@
       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
@@ -1843,7 +1859,7 @@
       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
@@ -1872,7 +1888,7 @@
       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 ),
@@ -2207,24 +2223,24 @@
   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 *',
@@ -2239,7 +2255,7 @@
       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
@@ -2262,7 +2278,7 @@
       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
@@ -2274,7 +2290,7 @@
       COMPLEX          ALPHA
       REAL             BETA
       CHARACTER*1      UPLO, TRANSA
-      CHARACTER*12     SNAME
+      CHARACTER*13     SNAME
       CHARACTER*14     CRC, CU, CA
 
       IF (UPLO.EQ.'U')THEN
@@ -2297,7 +2313,7 @@
       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
@@ -2785,3 +2801,541 @@
 *     End of SDIFF.
 *
       END
+
+      SUBROUTINE CCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
+     $                  FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
+     $                  A, AA, AS, B, BB, BS, C, CC, CS, CT, G,
+     $                  IORDER )
+      IMPLICIT NONE
+*
+*  Tests CGEMMTR.
+*
+*  Auxiliary routine for test program for Level 3 Blas.
+*
+*  -- Written on 24-June-2024.
+*     Martin Koehler, Max Planck Institute Magdeburg
+*
+*     .. Parameters ..
+      COMPLEX            ZERO
+      PARAMETER          ( ZERO = ( 0.0, 0.0 ) )
+      REAL               RZERO
+      PARAMETER          ( RZERO = 0.0 )
+*     .. Scalar Arguments ..
+      REAL               EPS, THRESH
+      INTEGER            NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
+      LOGICAL            FATAL, REWI, TRACE
+      CHARACTER*13       SNAME
+*     .. Array Arguments ..
+      COMPLEX            A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
+     $                   AS( NMAX*NMAX ), B( NMAX, NMAX ),
+     $                   BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
+     $                   C( NMAX, NMAX ), CC( NMAX*NMAX ),
+     $                   CS( NMAX*NMAX ), CT( NMAX )
+      REAL               G( NMAX )
+      INTEGER            IDIM( NIDIM )
+*     .. Local Scalars ..
+      COMPLEX            ALPHA, ALS, BETA, BLS
+      REAL               ERR, ERRMAX
+      INTEGER            I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA,
+     $                   LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS,
+     $                   MA, MB, N, NA, NARGS, NB, NC, NS, IS
+      LOGICAL            NULL, RESET, SAME, TRANA, TRANB
+      CHARACTER*1        TRANAS, TRANBS, TRANSA, TRANSB, UPLO, UPLOS
+      CHARACTER*3        ICH
+      CHARACTER*2        ISHAPE
+*     .. Local Arrays ..
+      LOGICAL            ISAME( 13 )
+*     .. External Functions ..
+      LOGICAL            LCE, LCERES
+      EXTERNAL           LCE, LCERES
+*     .. External Subroutines ..
+      EXTERNAL           CCGEMMTR, CMAKE, CMMTCH, CPRCN8
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     .. Scalars in Common ..
+      INTEGER            INFOT, NOUTC
+      LOGICAL            LERR, OK
+*     .. Common blocks ..
+      COMMON             /INFOC/INFOT, NOUTC, OK, LERR
+*     .. Data statements ..
+      DATA               ICH/'NTC'/
+      DATA               ISHAPE/'UL'/
+*     .. Executable Statements ..
+*
+      NARGS = 13
+      NC = 0
+      RESET = .TRUE.
+      ERRMAX = RZERO
+*
+      DO 100 IN = 1, NIDIM
+         N = IDIM( IN )
+*        Set LDC to 1 more than minimum value if room.
+         LDC = N
+         IF( LDC.LT.NMAX )
+     $      LDC = LDC + 1
+*        Skip tests if not enough room.
+         IF( LDC.GT.NMAX )
+     $      GO TO 100
+         LCC = LDC*N
+         NULL = N.LE.0.
+*
+         DO 90 IK = 1, NIDIM
+            K = IDIM( IK )
+*
+            DO 80 ICA = 1, 3
+               TRANSA = ICH( ICA: ICA )
+               TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
+*
+               IF( TRANA )THEN
+                  MA = K
+                  NA = N
+               ELSE
+                  MA = N
+                  NA = K
+               END IF
+*              Set LDA to 1 more than minimum value if room.
+               LDA = MA
+               IF( LDA.LT.NMAX )
+     $            LDA = LDA + 1
+*              Skip tests if not enough room.
+               IF( LDA.GT.NMAX )
+     $            GO TO 80
+               LAA = LDA*NA
+*
+*              Generate the matrix A.
+*
+               CALL CMAKE( 'ge', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
+     $                     RESET, ZERO )
+*
+               DO 70 ICB = 1, 3
+                  TRANSB = ICH( ICB: ICB )
+                  TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
+*
+                  IF( TRANB )THEN
+                     MB = N
+                     NB = K
+                  ELSE
+                     MB = K
+                     NB = N
+                  END IF
+*                 Set LDB to 1 more than minimum value if room.
+                  LDB = MB
+                  IF( LDB.LT.NMAX )
+     $               LDB = LDB + 1
+*                 Skip tests if not enough room.
+                  IF( LDB.GT.NMAX )
+     $               GO TO 70
+                  LBB = LDB*NB
+*
+*                 Generate the matrix B.
+*
+                  CALL CMAKE( 'ge', ' ', ' ', MB, NB, B, NMAX, BB,
+     $                        LDB, RESET, ZERO )
+*
+                  DO 60 IA = 1, NALF
+                     ALPHA = ALF( IA )
+*
+                     DO 50 IB = 1, NBET
+                        BETA = BET( IB )
+                        DO 45 IS = 1, 2
+                           UPLO = ISHAPE(IS:IS)
+*
+*                          Generate the matrix C.
+*
+                           CALL CMAKE( 'ge', UPLO, ' ', N, N, C, NMAX,
+     $                                 CC, LDC, RESET, ZERO )
+*
+                           NC = NC + 1
+*
+*                          Save every datum before calling the
+*                          subroutine.
+*
+                           UPLOS = UPLO
+                           TRANAS = TRANSA
+                           TRANBS = TRANSB
+                           NS = N
+                           KS = K
+                           ALS = ALPHA
+                           DO 10 I = 1, LAA
+                              AS( I ) = AA( I )
+   10                      CONTINUE
+                           LDAS = LDA
+                           DO 20 I = 1, LBB
+                              BS( I ) = BB( I )
+   20                      CONTINUE
+                           LDBS = LDB
+                           BLS = BETA
+                           DO 30 I = 1, LCC
+                              CS( I ) = CC( I )
+   30                      CONTINUE
+                           LDCS = LDC
+*
+*                          Call the subroutine.
+*
+                           IF( TRACE )
+     $                        CALL CPRCN8(NTRA, NC, SNAME, IORDER, UPLO,
+     $                        TRANSA, TRANSB, N, K, ALPHA, LDA,
+     $                        LDB, BETA, LDC)
+                           IF( REWI )
+     $                        REWIND NTRA
+                           CALL CCGEMMTR(IORDER, UPLO, TRANSA, TRANSB,
+     $                                 N, K, ALPHA, AA, LDA, BB, LDB,
+     $                                 BETA, CC, LDC )
+*
+*                          Check if error-exit was taken incorrectly.
+*
+                           IF( .NOT.OK )THEN
+                              WRITE( NOUT, FMT = 9994 )
+                              FATAL = .TRUE.
+                              GO TO 120
+                           END IF
+*
+*                          See what data changed inside subroutines.
+*
+                           ISAME( 1 ) = UPLO .EQ. UPLOS
+                           ISAME( 2 ) = TRANSA.EQ.TRANAS
+                           ISAME( 3 ) = TRANSB.EQ.TRANBS
+                           ISAME( 4 ) = NS.EQ.N
+                           ISAME( 5 ) = KS.EQ.K
+                           ISAME( 6 ) = ALS.EQ.ALPHA
+                           ISAME( 7 ) = LCE( AS, AA, LAA )
+                           ISAME( 8 ) = LDAS.EQ.LDA
+                           ISAME( 9 ) = LCE( BS, BB, LBB )
+                           ISAME( 10 ) = LDBS.EQ.LDB
+                           ISAME( 11 ) = BLS.EQ.BETA
+                           IF( NULL )THEN
+                              ISAME( 12 ) = LCE( CS, CC, LCC )
+                           ELSE
+                             ISAME( 12 ) = LCERES( 'ge', ' ', N, N, CS,
+     $                                      CC, LDC )
+                           END IF
+                           ISAME( 13 ) = LDCS.EQ.LDC
+*
+*                          If data was incorrectly changed, report
+*                          and return.
+*
+                           SAME = .TRUE.
+                           DO 40 I = 1, NARGS
+                              SAME = SAME.AND.ISAME( I )
+                              IF( .NOT.ISAME( I ) )
+     $                           WRITE( NOUT, FMT = 9998 )I
+   40                      CONTINUE
+                           IF( .NOT.SAME )THEN
+                              FATAL = .TRUE.
+                              GO TO 120
+                           END IF
+*
+                           IF( .NOT.NULL )THEN
+*
+*                             Check the result.
+*
+                              CALL CMMTCH( UPLO, TRANSA, TRANSB, N, K,
+     $                                   ALPHA, A, NMAX, B, NMAX, BETA,
+     $                                   C, NMAX, CT, G, CC, LDC, EPS,
+     $                                   ERR, FATAL, NOUT, .TRUE. )
+                              ERRMAX = MAX( ERRMAX, ERR )
+*                             If got really bad answer, report and
+*                             return.
+                              IF( FATAL )
+     $                           GO TO 120
+                           END IF
+*
+   45                   CONTINUE
+*
+   50                CONTINUE
+*
+   60             CONTINUE
+*
+   70          CONTINUE
+*
+   80       CONTINUE
+*
+   90    CONTINUE
+*
+  100 CONTINUE
+*
+*
+*     Report result.
+*
+      IF( ERRMAX.LT.THRESH )THEN
+         IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC
+         IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC
+      ELSE
+         IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
+         IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
+      END IF
+      GO TO 130
+*
+  120 CONTINUE
+      WRITE( NOUT, FMT = 9996 )SNAME
+      CALL CPRCN8(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, TRANSB,
+     $           N, K, ALPHA, LDA, LDB, BETA, LDC)
+*
+  130 CONTINUE
+      RETURN
+*
+10003 FORMAT( ' ', A13,' COMPLETED THE ROW-MAJOR    COMPUTATIONAL ',
+     $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
+     $ 'RATIO ', F8.2, ' - SUSPECT *******' )
+10002 FORMAT( ' ', A13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
+     $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
+     $ 'RATIO ', F8.2, ' - SUSPECT *******' )
+10001 FORMAT( ' ', A13,' PASSED THE ROW-MAJOR    COMPUTATIONAL TESTS',
+     $ ' (', I6, ' CALL', 'S)' )
+10000 FORMAT( ' ', A13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
+     $ ' (', I6, ' CALL', 'S)' )
+ 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
+     $      'ANGED INCORRECTLY *******' )
+ 9996 FORMAT( ' ******* ', A13,' FAILED ON CALL NUMBER:' )
+ 9995 FORMAT( 1X, I6, ': ', A13,'(''', A1, ''',''', A1, ''',',
+     $     3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3,
+     $     ',(', F4.1, ',', F4.1, '), C,', I3, ').' )
+ 9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
+     $      '******' )
+*
+*     End of CCHK6.
+*
+      END
+
+      SUBROUTINE CPRCN8(NOUT, NC, SNAME, IORDER, UPLO,
+     $                 TRANSA, TRANSB, N,
+     $                 K, ALPHA, LDA, LDB, BETA, LDC)
+      INTEGER          NOUT, NC, IORDER, N, K, LDA, LDB, LDC
+      COMPLEX          ALPHA, BETA
+      CHARACTER*1      TRANSA, TRANSB, UPLO
+      CHARACTER*13     SNAME
+      CHARACTER*14     CRC, CTA,CTB,CUPLO
+
+      IF (UPLO.EQ.'U') THEN
+          CUPLO = 'CblasUpper'
+      ELSE
+          CUPLO = 'CblasLower'
+      END IF
+      IF (TRANSA.EQ.'N')THEN
+         CTA = '  CblasNoTrans'
+      ELSE IF (TRANSA.EQ.'T')THEN
+         CTA = '    CblasTrans'
+      ELSE
+         CTA = 'CblasConjTrans'
+      END IF
+      IF (TRANSB.EQ.'N')THEN
+         CTB = '  CblasNoTrans'
+      ELSE IF (TRANSB.EQ.'T')THEN
+         CTB = '    CblasTrans'
+      ELSE
+         CTB = 'CblasConjTrans'
+      END IF
+      IF (IORDER.EQ.1)THEN
+         CRC = ' CblasRowMajor'
+      ELSE
+         CRC = ' CblasColMajor'
+      END IF
+      WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CUPLO, CTA,CTB
+      WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, LDB, BETA, LDC
+
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', A14, ',', A14, ',', A14, ',',
+     $        A14, ',')
+ 9994 FORMAT( 10X, 2( I3, ',' ) ,' (', F4.1,',',F4.1,') , A,',
+     $ I3, ', B,', I3, ', (', F4.1,',',F4.1,') , C,', I3, ').' )
+      END
+
+      SUBROUTINE CMMTCH(UPLO, TRANSA, TRANSB, N, KK, ALPHA, A, LDA,
+     $                  B, LDB,
+     $                  BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL,
+     $                  NOUT, MV )
+      IMPLICIT NONE
+*
+*  Checks the results of the computational tests for GEMMTR.
+*
+*  Auxiliary routine for test program for Level 3 Blas.
+*
+*  -- Written on 24-June-2024.
+*     Martin Koehler, Max Planck Institute, Magdeburg
+*
+*     .. Parameters ..
+      COMPLEX            ZERO
+      PARAMETER          ( ZERO = ( 0.0, 0.0 ) )
+      REAL               RZERO, RONE
+      PARAMETER          ( RZERO = 0.0, RONE = 1.0 )
+*     .. Scalar Arguments ..
+      COMPLEX            ALPHA, BETA
+      REAL               EPS, ERR
+      INTEGER            KK, LDA, LDB, LDC, LDCC, N, NOUT
+      LOGICAL            FATAL, MV
+      CHARACTER*1        TRANSA, TRANSB, UPLO
+*     .. Array Arguments ..
+      COMPLEX            A( LDA, * ), B( LDB, * ), C( LDC, * ),
+     $                   CC( LDCC, * ), CT( * )
+      REAL               G( * )
+*     .. Local Scalars ..
+      COMPLEX            CL
+      REAL               ERRI
+      INTEGER            I, J, K, ISTART, ISTOP
+      LOGICAL            CTRANA, CTRANB, TRANA, TRANB, UPPER
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, CONJG, MAX, REAL, SQRT
+*     .. Statement Functions ..
+      REAL               ABS1
+*     .. Statement Function definitions ..
+      ABS1( CL ) = ABS( REAL( CL ) ) + ABS( AIMAG( CL ) )
+*     .. Executable Statements ..
+
+      UPPER = UPLO.EQ.'U'
+      TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
+      TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
+      CTRANA = TRANSA.EQ.'C'
+      CTRANB = TRANSB.EQ.'C'
+
+      ISTART = 1
+      ISTOP = N
+*
+*     Compute expected result, one column at a time, in CT using data
+*     in A, B and C.
+*     Compute gauges in G.
+*
+      DO 220 J = 1, N
+*
+         IF (UPPER) THEN
+             ISTART = 1
+             ISTOP =  J
+         ELSE
+             ISTART = J
+             ISTOP  = N
+         END IF
+         DO 10 I = ISTART, ISTOP
+            CT( I ) = ZERO
+            G( I ) = RZERO
+   10    CONTINUE
+         IF( .NOT.TRANA.AND..NOT.TRANB )THEN
+            DO 30 K = 1, KK
+               DO 20 I = ISTART, ISTOP
+                  CT( I ) = CT( I ) + A( I, K )*B( K, J )
+                  G( I ) = G( I ) + ABS1( A( I, K ) )*ABS1( B( K, J ) )
+   20          CONTINUE
+   30       CONTINUE
+         ELSE IF( TRANA.AND..NOT.TRANB )THEN
+            IF( CTRANA )THEN
+               DO 50 K = 1, KK
+                  DO 40 I =  ISTART, ISTOP
+                     CT( I ) = CT( I ) + CONJG( A( K, I ) )*B( K, J )
+                     G( I ) = G( I ) + ABS1( A( K, I ) )*
+     $                        ABS1( B( K, J ) )
+   40             CONTINUE
+   50          CONTINUE
+            ELSE
+               DO 70 K = 1, KK
+                  DO 60 I = ISTART, ISTOP
+                     CT( I ) = CT( I ) + A( K, I )*B( K, J )
+                     G( I ) = G( I ) + ABS1( A( K, I ) )*
+     $                        ABS1( B( K, J ) )
+   60             CONTINUE
+   70          CONTINUE
+            END IF
+         ELSE IF( .NOT.TRANA.AND.TRANB )THEN
+            IF( CTRANB )THEN
+               DO 90 K = 1, KK
+                  DO 80 I =  ISTART, ISTOP
+                     CT( I ) = CT( I ) + A( I, K )*CONJG( B( J, K ) )
+                     G( I ) = G( I ) + ABS1( A( I, K ) )*
+     $                        ABS1( B( J, K ) )
+   80             CONTINUE
+   90          CONTINUE
+            ELSE
+               DO 110 K = 1, KK
+                  DO 100 I = ISTART, ISTOP
+                     CT( I ) = CT( I ) + A( I, K )*B( J, K )
+                     G( I ) = G( I ) + ABS1( A( I, K ) )*
+     $                        ABS1( B( J, K ) )
+  100             CONTINUE
+  110          CONTINUE
+            END IF
+         ELSE IF( TRANA.AND.TRANB )THEN
+            IF( CTRANA )THEN
+               IF( CTRANB )THEN
+                  DO 130 K = 1, KK
+                     DO 120 I = ISTART, ISTOP
+                        CT( I ) = CT( I ) + CONJG( A( K, I ) )*
+     $                            CONJG( B( J, K ) )
+                        G( I ) = G( I ) + ABS1( A( K, I ) )*
+     $                           ABS1( B( J, K ) )
+  120                CONTINUE
+  130             CONTINUE
+               ELSE
+                  DO 150 K = 1, KK
+                     DO 140 I =  ISTART, ISTOP
+                       CT( I ) = CT( I ) + CONJG( A( K, I ) )*B( J, K )
+                       G( I ) = G( I ) + ABS1( A( K, I ) )*
+     $                           ABS1( B( J, K ) )
+  140                CONTINUE
+  150             CONTINUE
+               END IF
+            ELSE
+               IF( CTRANB )THEN
+                  DO 170 K = 1, KK
+                     DO 160 I =  ISTART, ISTOP
+                       CT( I ) = CT( I ) + A( K, I )*CONJG( B( J, K ) )
+                       G( I ) = G( I ) + ABS1( A( K, I ) )*
+     $                           ABS1( B( J, K ) )
+  160                CONTINUE
+  170             CONTINUE
+               ELSE
+                  DO 190 K = 1, KK
+                     DO 180 I =  ISTART, ISTOP
+                        CT( I ) = CT( I ) + A( K, I )*B( J, K )
+                        G( I ) = G( I ) + ABS1( A( K, I ) )*
+     $                           ABS1( B( J, K ) )
+  180                CONTINUE
+  190             CONTINUE
+               END IF
+            END IF
+         END IF
+         DO 200 I =  ISTART, ISTOP
+            CT( I ) = ALPHA*CT( I ) + BETA*C( I, J )
+            G( I ) = ABS1( ALPHA )*G( I ) +
+     $               ABS1( BETA )*ABS1( C( I, J ) )
+  200    CONTINUE
+*
+*        Compute the error ratio for this result.
+*
+         ERR = ZERO
+         DO 210 I =  ISTART, ISTOP
+            ERRI = ABS1( CT( I ) - CC( I, J ) )/EPS
+            IF( G( I ).NE.RZERO )
+     $         ERRI = ERRI/G( I )
+            ERR = MAX( ERR, ERRI )
+            IF( ERR*SQRT( EPS ).GE.RONE )
+     $         GO TO 230
+  210    CONTINUE
+*
+  220 CONTINUE
+*
+*     If the loop completes, all results are at least half accurate.
+      GO TO 250
+*
+*     Report fatal error.
+*
+  230 FATAL = .TRUE.
+      WRITE( NOUT, FMT = 9999 )
+      DO 240 I =  ISTART, ISTOP
+         IF( MV )THEN
+            WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J )
+         ELSE
+            WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I )
+         END IF
+  240 CONTINUE
+      IF( N.GT.1 )
+     $   WRITE( NOUT, FMT = 9997 )J
+*
+  250 CONTINUE
+      RETURN
+*
+ 9999 FORMAT(' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
+     $     'F ACCURATE *******', /'                       EXPECTED RE',
+     $     'SULT                    COMPUTED RESULT' )
+ 9998 FORMAT( 1X, I7, 2( '  (', G15.6, ',', G15.6, ')' ) )
+ 9997 FORMAT( '      THESE ARE THE RESULTS FOR COLUMN ', I3 )
+*
+*     End of CMMTCH.
+*
+      END
+

CBLAS/testing/c_d2chke.c

@@ -8,10 +8,14 @@ CBLAS_INT link_xerbla=TRUE;
 char *cblas_rout;
 
 #ifdef F77_Char
-void F77_xerbla(F77_Char F77_srname, void *vinfo);
+void F77_xerbla(F77_Char F77_srname, void *vinfo
 #else
-void F77_xerbla(char *srname, void *vinfo);
+void F77_xerbla(char *srname, void *vinfo
 #endif
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN srname_len
+#endif
+);
 
 void chkxer(void) {
    extern CBLAS_INT cblas_ok, cblas_lerr, cblas_info;
@@ -24,7 +28,11 @@ void chkxer(void) {
    cblas_lerr = 1 ;
 }
 
-void F77_d2chke(char *rout) {
+void F77_d2chke(char *rout
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN rout_len
+#endif
+) {
    char *sf = ( rout ) ;
    double A[2] = {0.0,0.0},
           X[2] = {0.0,0.0},
@@ -38,7 +46,7 @@ void F77_d2chke(char *rout) {
    if (link_xerbla) /* call these first to link */
    {
       cblas_xerbla(cblas_info,cblas_rout,"");
-      F77_xerbla(cblas_rout,&cblas_info);
+      F77_xerbla(cblas_rout,&cblas_info, 1);
    }
 #endif
 

CBLAS/testing/c_d3chke.c

@@ -8,10 +8,14 @@ CBLAS_INT link_xerbla=TRUE;
 char *cblas_rout;
 
 #ifdef F77_Char
-void F77_xerbla(F77_Char F77_srname, void *vinfo);
+void F77_xerbla(F77_Char F77_srname, void *vinfo
 #else
-void F77_xerbla(char *srname, void *vinfo);
+void F77_xerbla(char *srname, void *vinfo
 #endif
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN srname_len
+#endif
+);
 
 void chkxer(void) {
    extern CBLAS_INT cblas_ok, cblas_lerr, cblas_info;
@@ -24,7 +28,11 @@ void chkxer(void) {
    cblas_lerr = 1 ;
 }
 
-void F77_d3chke(char *rout) {
+void F77_d3chke(char *rout
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN rout_len
+#endif
+) {
    char *sf = ( rout ) ;
    double A[2] = {0.0,0.0},
           B[2] = {0.0,0.0},
@@ -38,14 +46,244 @@ void F77_d3chke(char *rout) {
    if (link_xerbla) /* call these first to link */
    {
       cblas_xerbla(cblas_info,cblas_rout,"");
-      F77_xerbla(cblas_rout,&cblas_info);
+      F77_xerbla(cblas_rout,&cblas_info, 1);
    }
 #endif
 
    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;
@@ -1267,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);
 }

CBLAS/testing/c_dblas2.c

@@ -10,7 +10,11 @@
 
 void F77_dgemv(CBLAS_INT *layout, char *transp, CBLAS_INT *m, CBLAS_INT *n, double *alpha,
 	       double *a, CBLAS_INT *lda, double *x, CBLAS_INT *incx, double *beta,
-	       double *y, CBLAS_INT *incy ) {
+	       double *y, CBLAS_INT *incy
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN transp_len
+#endif
+) {
 
   double *A;
   CBLAS_INT i,j,LDA;
@@ -61,7 +65,11 @@ 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) {
+	      CBLAS_INT *n, double *a, CBLAS_INT *lda, double *x, CBLAS_INT *incx
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
   double *A;
   CBLAS_INT i,j,LDA;
   CBLAS_TRANSPOSE trans;
@@ -89,7 +97,11 @@ 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 ) {
+	       CBLAS_INT *n, double *a, CBLAS_INT *lda, double *x, CBLAS_INT *incx
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
   double *A;
   CBLAS_INT i,j,LDA;
   CBLAS_TRANSPOSE trans;
@@ -114,7 +126,11 @@ void F77_dtrsv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn,
 }
 void F77_dsymv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, double *alpha, double *a,
 	      CBLAS_INT *lda, double *x, CBLAS_INT *incx, double *beta, double *y,
-	      CBLAS_INT *incy) {
+	      CBLAS_INT *incy
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len
+#endif
+) {
   double *A;
   CBLAS_INT i,j,LDA;
   CBLAS_UPLO uplo;
@@ -137,7 +153,11 @@ 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) {
+	     CBLAS_INT *incx, double *a, CBLAS_INT *lda
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len
+#endif
+) {
   double *A;
   CBLAS_INT i,j,LDA;
   CBLAS_UPLO uplo;
@@ -161,7 +181,11 @@ 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) {
+	     CBLAS_INT *incx, double *y, CBLAS_INT *incy, double *a, CBLAS_INT *lda
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len
+#endif
+) {
   double *A;
   CBLAS_INT i,j,LDA;
   CBLAS_UPLO uplo;
@@ -186,7 +210,11 @@ void F77_dsyr2(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, double *alpha, doub
 
 void F77_dgbmv(CBLAS_INT *layout, char *transp, CBLAS_INT *m, CBLAS_INT *n, CBLAS_INT *kl, CBLAS_INT *ku,
 	       double *alpha, double *a, CBLAS_INT *lda, double *x, CBLAS_INT *incx,
-	       double *beta, double *y, CBLAS_INT *incy ) {
+	       double *beta, double *y, CBLAS_INT *incy
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN transp_len
+#endif
+) {
 
   double *A;
   CBLAS_INT i,irow,j,jcol,LDA;
@@ -223,7 +251,11 @@ 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) {
+	      CBLAS_INT *n, CBLAS_INT *k, double *a, CBLAS_INT *lda, double *x, CBLAS_INT *incx
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
   double *A;
   CBLAS_INT irow, jcol, i, j, LDA;
   CBLAS_TRANSPOSE trans;
@@ -269,7 +301,11 @@ 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) {
+	      CBLAS_INT *n, CBLAS_INT *k, double *a, CBLAS_INT *lda, double *x, CBLAS_INT *incx
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
   double *A;
   CBLAS_INT irow, jcol, i, j, LDA;
   CBLAS_TRANSPOSE trans;
@@ -316,7 +352,11 @@ void F77_dtbsv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn,
 
 void F77_dsbmv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_INT *k, double *alpha,
 	      double *a, CBLAS_INT *lda, double *x, CBLAS_INT *incx, double *beta,
-	      double *y, CBLAS_INT *incy) {
+	      double *y, CBLAS_INT *incy
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len
+#endif
+) {
   double *A;
   CBLAS_INT i,j,irow,jcol,LDA;
   CBLAS_UPLO uplo;
@@ -360,7 +400,11 @@ 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) {
+	      double *x, CBLAS_INT *incx, double *beta, double *y, CBLAS_INT *incy
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len
+#endif
+) {
   double *A,*AP;
   CBLAS_INT i,j,k,LDA;
   CBLAS_UPLO uplo;
@@ -398,7 +442,11 @@ 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) {
+	      CBLAS_INT *n, double *ap, double *x, CBLAS_INT *incx
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
   double *A, *AP;
   CBLAS_INT i, j, k, LDA;
   CBLAS_TRANSPOSE trans;
@@ -438,7 +486,11 @@ 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) {
+	      CBLAS_INT *n, double *ap, double *x, CBLAS_INT *incx
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
   double *A, *AP;
   CBLAS_INT i, j, k, LDA;
   CBLAS_TRANSPOSE trans;
@@ -479,7 +531,11 @@ 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 ){
+	     CBLAS_INT *incx, double *ap
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len
+#endif
+){
   double *A, *AP;
   CBLAS_INT i,j,k,LDA;
   CBLAS_UPLO uplo;
@@ -531,7 +587,11 @@ 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 ){
+	     CBLAS_INT *incx, double *y, CBLAS_INT *incy, double *ap
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len
+#endif
+){
   double *A, *AP;
   CBLAS_INT i,j,k,LDA;
   CBLAS_UPLO uplo;

CBLAS/testing/c_dblas3.c

@@ -13,7 +13,11 @@
 
 void F77_dgemm(CBLAS_INT *layout, char *transpa, char *transpb, CBLAS_INT *m, 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 *beta, double *c, CBLAS_INT *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN transpa_len, FORTRAN_STRLEN transpb_len
+#endif
+) {
 
   double *A, *B, *C;
   CBLAS_INT i,j,LDA, LDB, LDC;
@@ -73,9 +77,92 @@ 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 ) {
+              double *beta, double *c, CBLAS_INT *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len
+#endif
+) {
 
   double *A, *B, *C;
   CBLAS_INT i,j,LDA, LDB, LDC;
@@ -129,7 +216,11 @@ void F77_dsymm(CBLAS_INT *layout, char *rtlf, char *uplow, CBLAS_INT *m, CBLAS_I
 
 void F77_dsyrk(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLAS_INT *k,
               double *alpha, double *a, CBLAS_INT *lda,
-              double *beta, double *c, CBLAS_INT *ldc ) {
+              double *beta, double *c, CBLAS_INT *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len
+#endif
+) {
 
   CBLAS_INT i,j,LDA,LDC;
   double *A, *C;
@@ -177,7 +268,11 @@ void F77_dsyrk(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLAS
 
 void F77_dsyr2k(CBLAS_INT *layout, char *uplow, char *transp, 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 *beta, double *c, CBLAS_INT *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len
+#endif
+) {
   CBLAS_INT i,j,LDA,LDB,LDC;
   double *A, *B, *C;
   CBLAS_UPLO uplo;
@@ -232,7 +327,11 @@ void F77_dsyr2k(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLA
 }
 void F77_dtrmm(CBLAS_INT *layout, char *rtlf, char *uplow, char *transp, char *diagn,
               CBLAS_INT *m, CBLAS_INT *n, double *alpha, double *a, CBLAS_INT *lda, double *b,
-              CBLAS_INT *ldb) {
+              CBLAS_INT *ldb
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diag_len
+#endif
+) {
   CBLAS_INT i,j,LDA,LDB;
   double *A, *B;
   CBLAS_SIDE side;
@@ -283,7 +382,11 @@ void F77_dtrmm(CBLAS_INT *layout, char *rtlf, char *uplow, char *transp, char *d
 
 void F77_dtrsm(CBLAS_INT *layout, char *rtlf, char *uplow, char *transp, char *diagn,
               CBLAS_INT *m, CBLAS_INT *n, double *alpha, double *a, CBLAS_INT *lda, double *b,
-              CBLAS_INT *ldb) {
+              CBLAS_INT *ldb
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
   CBLAS_INT i,j,LDA,LDB;
   double *A, *B;
   CBLAS_SIDE side;

CBLAS/testing/c_dblat3.f

@@ -4,7 +4,7 @@
 *
 *  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 @@
 *  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 @@
       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 @@
 *     .. 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 @@
      $                   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 @@
             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 @@
             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 @@
             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 @@
  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 @@
      $      '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 @@
       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 @@
      $                        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 @@
   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 @@
       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 @@
       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 @@
       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 @@
   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 @@
       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 @@
       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 @@
       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 @@
      $                           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 @@
      $                           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 @@
   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 @@
       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 @@
       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 @@
       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 @@
   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 @@
       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 @@
       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 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 @@
       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 @@
      $                     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 @@
   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 @@
       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 @@
       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 @@
 *     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
+
+

CBLAS/testing/c_s2chke.c

@@ -8,10 +8,14 @@ CBLAS_INT link_xerbla=TRUE;
 char *cblas_rout;
 
 #ifdef F77_Char
-void F77_xerbla(F77_Char F77_srname, void *vinfo);
+void F77_xerbla(F77_Char F77_srname, void *vinfo
 #else
-void F77_xerbla(char *srname, void *vinfo);
+void F77_xerbla(char *srname, void *vinfo
 #endif
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN
+#endif
+);
 
 void chkxer(void) {
    extern CBLAS_INT cblas_ok, cblas_lerr, cblas_info;
@@ -24,7 +28,11 @@ void chkxer(void) {
    cblas_lerr = 1 ;
 }
 
-void F77_s2chke(char *rout) {
+void F77_s2chke(char *rout
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN rout_len
+#endif
+) {
    char *sf = ( rout ) ;
    float  A[2] = {0.0,0.0},
           X[2] = {0.0,0.0},
@@ -38,7 +46,7 @@ void F77_s2chke(char *rout) {
    if (link_xerbla) /* call these first to link */
    {
       cblas_xerbla(cblas_info,cblas_rout,"");
-      F77_xerbla(cblas_rout,&cblas_info);
+      F77_xerbla(cblas_rout,&cblas_info, 1);
    }
 #endif
 

CBLAS/testing/c_s3chke.c

@@ -8,10 +8,14 @@ CBLAS_INT link_xerbla=TRUE;
 char *cblas_rout;
 
 #ifdef F77_Char
-void F77_xerbla(F77_Char F77_srname, void *vinfo);
+void F77_xerbla(F77_Char F77_srname, void *vinfo
 #else
-void F77_xerbla(char *srname, void *vinfo);
+void F77_xerbla(char *srname, void *vinfo
 #endif
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN srname_len
+#endif
+);
 
 void chkxer(void) {
    extern CBLAS_INT cblas_ok, cblas_lerr, cblas_info;
@@ -24,7 +28,11 @@ void chkxer(void) {
    cblas_lerr = 1 ;
 }
 
-void F77_s3chke(char *rout) {
+void F77_s3chke(char *rout
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN rout_len
+#endif
+) {
    char *sf = ( rout ) ;
    float  A[2] = {0.0,0.0},
           B[2] = {0.0,0.0},
@@ -38,14 +46,244 @@ void F77_s3chke(char *rout) {
    if (link_xerbla) /* call these first to link */
    {
       cblas_xerbla(cblas_info,cblas_rout,"");
-      F77_xerbla(cblas_rout,&cblas_info);
+      F77_xerbla(cblas_rout,&cblas_info, 1);
    }
 #endif
 
    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,
@@ -1269,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);
 }

CBLAS/testing/c_sblas2.c

@@ -10,7 +10,11 @@
 
 void F77_sgemv(CBLAS_INT *layout, char *transp, CBLAS_INT *m, CBLAS_INT *n, float *alpha,
 	       float *a, CBLAS_INT *lda, float *x, CBLAS_INT *incx, float *beta,
-	       float *y, CBLAS_INT *incy ) {
+	       float *y, CBLAS_INT *incy
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN transp_len
+#endif
+) {
 
   float *A;
   CBLAS_INT i,j,LDA;
@@ -61,7 +65,11 @@ 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) {
+	      CBLAS_INT *n, float *a, CBLAS_INT *lda, float *x, CBLAS_INT *incx
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
   float *A;
   CBLAS_INT i,j,LDA;
   CBLAS_TRANSPOSE trans;
@@ -89,7 +97,11 @@ 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 ) {
+	       CBLAS_INT *n, float *a, CBLAS_INT *lda, float *x, CBLAS_INT *incx
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
   float *A;
   CBLAS_INT i,j,LDA;
   CBLAS_TRANSPOSE trans;
@@ -114,7 +126,11 @@ void F77_strsv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn,
 }
 void F77_ssymv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, float *alpha, float *a,
 	      CBLAS_INT *lda, float *x, CBLAS_INT *incx, float *beta, float *y,
-	      CBLAS_INT *incy) {
+	      CBLAS_INT *incy
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len
+#endif
+) {
   float *A;
   CBLAS_INT i,j,LDA;
   CBLAS_UPLO uplo;
@@ -137,7 +153,11 @@ 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) {
+	     CBLAS_INT *incx, float *a, CBLAS_INT *lda
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len
+#endif
+) {
   float *A;
   CBLAS_INT i,j,LDA;
   CBLAS_UPLO uplo;
@@ -161,7 +181,11 @@ 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) {
+	     CBLAS_INT *incx, float *y, CBLAS_INT *incy, float *a, CBLAS_INT *lda
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len
+#endif
+) {
   float *A;
   CBLAS_INT i,j,LDA;
   CBLAS_UPLO uplo;
@@ -186,7 +210,11 @@ void F77_ssyr2(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, float *alpha, float
 
 void F77_sgbmv(CBLAS_INT *layout, char *transp, CBLAS_INT *m, CBLAS_INT *n, CBLAS_INT *kl, CBLAS_INT *ku,
 	       float *alpha, float *a, CBLAS_INT *lda, float *x, CBLAS_INT *incx,
-	       float *beta, float *y, CBLAS_INT *incy ) {
+	       float *beta, float *y, CBLAS_INT *incy
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN transp_len
+#endif
+) {
 
   float *A;
   CBLAS_INT i,irow,j,jcol,LDA;
@@ -223,7 +251,11 @@ 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) {
+	      CBLAS_INT *n, CBLAS_INT *k, float *a, CBLAS_INT *lda, float *x, CBLAS_INT *incx
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
   float *A;
   CBLAS_INT irow, jcol, i, j, LDA;
   CBLAS_TRANSPOSE trans;
@@ -269,7 +301,11 @@ 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) {
+	      CBLAS_INT *n, CBLAS_INT *k, float *a, CBLAS_INT *lda, float *x, CBLAS_INT *incx
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
   float *A;
   CBLAS_INT irow, jcol, i, j, LDA;
   CBLAS_TRANSPOSE trans;
@@ -316,7 +352,11 @@ void F77_stbsv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn,
 
 void F77_ssbmv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_INT *k, float *alpha,
 	      float *a, CBLAS_INT *lda, float *x, CBLAS_INT *incx, float *beta,
-	      float *y, CBLAS_INT *incy) {
+	      float *y, CBLAS_INT *incy
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len
+#endif
+) {
   float *A;
   CBLAS_INT i,j,irow,jcol,LDA;
   CBLAS_UPLO uplo;
@@ -360,7 +400,11 @@ 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) {
+	      float *x, CBLAS_INT *incx, float *beta, float *y, CBLAS_INT *incy
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len
+#endif
+) {
   float *A,*AP;
   CBLAS_INT i,j,k,LDA;
   CBLAS_UPLO uplo;
@@ -397,7 +441,11 @@ 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) {
+	      CBLAS_INT *n, float *ap, float *x, CBLAS_INT *incx
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
   float *A, *AP;
   CBLAS_INT i, j, k, LDA;
   CBLAS_TRANSPOSE trans;
@@ -436,7 +484,11 @@ 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) {
+	      CBLAS_INT *n, float *ap, float *x, CBLAS_INT *incx
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
   float *A, *AP;
   CBLAS_INT i, j, k, LDA;
   CBLAS_TRANSPOSE trans;
@@ -476,7 +528,11 @@ 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 ){
+	     CBLAS_INT *incx, float *ap
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len
+#endif
+){
   float *A, *AP;
   CBLAS_INT i,j,k,LDA;
   CBLAS_UPLO uplo;
@@ -527,7 +583,11 @@ 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 ){
+	     CBLAS_INT *incx, float *y, CBLAS_INT *incy, float *ap
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len
+#endif
+){
   float *A, *AP;
   CBLAS_INT i,j,k,LDA;
   CBLAS_UPLO uplo;

CBLAS/testing/c_sblas3.c

@@ -11,7 +11,11 @@
 
 void F77_sgemm(CBLAS_INT *layout, char *transpa, char *transpb, CBLAS_INT *m, 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 *beta, float *c, CBLAS_INT *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN transpa_len, FORTRAN_STRLEN transpb_len
+#endif
+) {
 
   float *A, *B, *C;
   CBLAS_INT i,j,LDA, LDB, LDC;
@@ -70,9 +74,89 @@ 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_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 ) {
+
+  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 ) {
+              float *beta, float *c, CBLAS_INT *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len
+#endif
+) {
 
   float *A, *B, *C;
   CBLAS_INT i,j,LDA, LDB, LDC;
@@ -126,7 +210,11 @@ void F77_ssymm(CBLAS_INT *layout, char *rtlf, char *uplow, CBLAS_INT *m, CBLAS_I
 
 void F77_ssyrk(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLAS_INT *k,
               float *alpha, float *a, CBLAS_INT *lda,
-              float *beta, float *c, CBLAS_INT *ldc ) {
+              float *beta, float *c, CBLAS_INT *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len
+#endif
+) {
 
   CBLAS_INT i,j,LDA,LDC;
   float *A, *C;
@@ -174,7 +262,11 @@ void F77_ssyrk(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLAS
 
 void F77_ssyr2k(CBLAS_INT *layout, char *uplow, char *transp, 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 *beta, float *c, CBLAS_INT *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len
+#endif
+) {
   CBLAS_INT i,j,LDA,LDB,LDC;
   float *A, *B, *C;
   CBLAS_UPLO uplo;
@@ -229,7 +321,11 @@ void F77_ssyr2k(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLA
 }
 void F77_strmm(CBLAS_INT *layout, char *rtlf, char *uplow, char *transp, char *diagn,
               CBLAS_INT *m, CBLAS_INT *n, float *alpha, float *a, CBLAS_INT *lda, float *b,
-              CBLAS_INT *ldb) {
+              CBLAS_INT *ldb
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
   CBLAS_INT i,j,LDA,LDB;
   float *A, *B;
   CBLAS_SIDE side;
@@ -280,7 +376,11 @@ void F77_strmm(CBLAS_INT *layout, char *rtlf, char *uplow, char *transp, char *d
 
 void F77_strsm(CBLAS_INT *layout, char *rtlf, char *uplow, char *transp, char *diagn,
               CBLAS_INT *m, CBLAS_INT *n, float *alpha, float *a, CBLAS_INT *lda, float *b,
-              CBLAS_INT *ldb) {
+              CBLAS_INT *ldb
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
   CBLAS_INT i,j,LDA,LDB;
   float *A, *B;
   CBLAS_SIDE side;

CBLAS/testing/c_sblat3.f

@@ -4,7 +4,7 @@
 *
 *  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 @@
 *  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 @@
       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 @@
       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 @@
      $                   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 @@
             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 @@
      $                  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 @@
  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 @@
      $      '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 @@
       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 @@
   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 @@
       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 @@
       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 @@
       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 @@
   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 @@
       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 @@
       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 @@
       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 @@
   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 @@
       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 @@
       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 @@
       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 @@
   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 @@
       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 @@
       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 @@
       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 @@
   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 @@
       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 @@
       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 @@
 *     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
+
+

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;
@@ -85,16 +90,20 @@ void cblas_xerbla(CBLAS_INT info, const char *rout, const char *form, ...)
 }
 
 #ifdef F77_Char
-void F77_xerbla(F77_Char F77_srname, void *vinfo)
+void F77_xerbla(F77_Char F77_srname, void *vinfo
 #else
-void F77_xerbla(char *srname, void *vinfo)
+void F77_xerbla(char *srname, void *vinfo
 #endif
+#ifdef BLAS_FORTRAN_STRLEN_END
+, FORTRAN_STRLEN srname_len
+#endif
+)
 {
 #ifdef F77_Char
    char *srname;
 #endif
 
-   char rout[] = {'c','b','l','a','s','_','\0','\0','\0','\0','\0','\0','\0'};
+   char rout[] = {'c','b','l','a','s','_','\0','\0','\0','\0','\0','\0','\0', '\0'};
 
 #ifdef F77_Integer
    F77_Integer *info=vinfo;
@@ -115,8 +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.

CBLAS/testing/c_z2chke.c

@@ -8,10 +8,14 @@ CBLAS_INT link_xerbla=TRUE;
 char *cblas_rout;
 
 #ifdef F77_Char
-void F77_xerbla(F77_Char F77_srname, void *vinfo);
+void F77_xerbla(F77_Char F77_srname, void *vinfo
 #else
-void F77_xerbla(char *srname, void *vinfo);
+void F77_xerbla(char *srname, void *vinfo
 #endif
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN srname_len
+#endif
+);
 
 void chkxer(void) {
    extern CBLAS_INT cblas_ok, cblas_lerr, cblas_info;
@@ -24,7 +28,11 @@ void chkxer(void) {
    cblas_lerr = 1 ;
 }
 
-void F77_z2chke(char *rout) {
+void F77_z2chke(char *rout
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN rout_len
+#endif
+) {
    char *sf = ( rout ) ;
    double  A[2] = {0.0,0.0},
           X[2] = {0.0,0.0},
@@ -40,7 +48,7 @@ void F77_z2chke(char *rout) {
    if (link_xerbla) /* call these first to link */
    {
       cblas_xerbla(cblas_info,cblas_rout,"");
-      F77_xerbla(cblas_rout,&cblas_info);
+      F77_xerbla(cblas_rout,&cblas_info, 1);
    }
 #endif
 

CBLAS/testing/c_z3chke.c

@@ -8,10 +8,14 @@ CBLAS_INT link_xerbla=TRUE;
 char *cblas_rout;
 
 #ifdef F77_Char
-void F77_xerbla(F77_Char F77_srname, void *vinfo);
+void F77_xerbla(F77_Char F77_srname, void *vinfo
 #else
-void F77_xerbla(char *srname, void *vinfo);
+void F77_xerbla(char *srname, void *vinfo
 #endif
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN srname_len
+#endif
+);
 
 void chkxer(void) {
    extern CBLAS_INT cblas_ok, cblas_lerr, cblas_info;
@@ -24,7 +28,11 @@ void chkxer(void) {
    cblas_lerr = 1 ;
 }
 
-void  F77_z3chke(char *  rout) {
+void F77_z3chke(char *rout
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN rout_len
+#endif
+) {
    char *sf = ( rout ) ;
    double  A[4]     = {0.0,0.0,0.0,0.0},
            B[4]     = {0.0,0.0,0.0,0.0},
@@ -43,11 +51,240 @@ void  F77_z3chke(char *  rout) {
    if (link_xerbla) /* call these first to link */
    {
       cblas_xerbla(cblas_info,cblas_rout,"");
-      F77_xerbla(cblas_rout,&cblas_info);
+      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;
@@ -1702,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);
 }

CBLAS/testing/c_zblas2.c

@@ -11,7 +11,11 @@
 void F77_zgemv(CBLAS_INT *layout, char *transp, CBLAS_INT *m, CBLAS_INT *n,
           const void *alpha,
           CBLAS_TEST_ZOMPLEX *a, CBLAS_INT *lda, const void *x, CBLAS_INT *incx,
-          const void *beta, void *y, CBLAS_INT *incy) {
+          const void *beta, void *y, CBLAS_INT *incy
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN transp_len
+#endif
+) {
 
   CBLAS_TEST_ZOMPLEX *A;
   CBLAS_INT i,j,LDA;
@@ -41,7 +45,11 @@ void F77_zgemv(CBLAS_INT *layout, char *transp, CBLAS_INT *m, CBLAS_INT *n,
 void F77_zgbmv(CBLAS_INT *layout, char *transp, CBLAS_INT *m, CBLAS_INT *n, CBLAS_INT *kl, CBLAS_INT *ku,
 	      CBLAS_TEST_ZOMPLEX *alpha, 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) {
+	      CBLAS_TEST_ZOMPLEX *beta, CBLAS_TEST_ZOMPLEX *y, CBLAS_INT *incy
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN transp_len
+#endif
+) {
 
   CBLAS_TEST_ZOMPLEX *A;
   CBLAS_INT i,j,irow,jcol,LDA;
@@ -144,7 +152,11 @@ void F77_zgerc(CBLAS_INT *layout, CBLAS_INT *m, CBLAS_INT *n, CBLAS_TEST_ZOMPLEX
 
 void F77_zhemv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_TEST_ZOMPLEX *alpha,
       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){
+      CBLAS_INT *incx, CBLAS_TEST_ZOMPLEX *beta, CBLAS_TEST_ZOMPLEX *y, CBLAS_INT *incy
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len
+#endif
+){
 
   CBLAS_TEST_ZOMPLEX *A;
   CBLAS_INT i,j,LDA;
@@ -175,7 +187,11 @@ void F77_zhemv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_TEST_ZOMPLEX
 void F77_zhbmv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_INT *k,
      CBLAS_TEST_ZOMPLEX *alpha, 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){
+     CBLAS_TEST_ZOMPLEX *y, CBLAS_INT *incy
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len
+#endif
+){
 
 CBLAS_TEST_ZOMPLEX *A;
 CBLAS_INT i,irow,j,jcol,LDA;
@@ -238,7 +254,11 @@ CBLAS_INT i,irow,j,jcol,LDA;
 
 void F77_zhpmv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_TEST_ZOMPLEX *alpha,
      CBLAS_TEST_ZOMPLEX *ap, CBLAS_TEST_ZOMPLEX *x, CBLAS_INT *incx,
-     CBLAS_TEST_ZOMPLEX *beta, CBLAS_TEST_ZOMPLEX *y, CBLAS_INT *incy){
+     CBLAS_TEST_ZOMPLEX *beta, CBLAS_TEST_ZOMPLEX *y, CBLAS_INT *incy
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len
+#endif
+){
 
   CBLAS_TEST_ZOMPLEX *A, *AP;
   CBLAS_INT i,j,k,LDA;
@@ -294,7 +314,11 @@ void F77_zhpmv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_TEST_ZOMPLEX
 
 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) {
+     CBLAS_INT *incx
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
   CBLAS_TEST_ZOMPLEX *A;
   CBLAS_INT irow, jcol, i, j, LDA;
   CBLAS_TRANSPOSE trans;
@@ -357,7 +381,11 @@ void F77_ztbmv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn,
 
 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) {
+      CBLAS_INT *incx
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
 
   CBLAS_TEST_ZOMPLEX *A;
   CBLAS_INT irow, jcol, i, j, LDA;
@@ -420,7 +448,11 @@ 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) {
+      CBLAS_INT *n, CBLAS_TEST_ZOMPLEX *ap, CBLAS_TEST_ZOMPLEX *x, CBLAS_INT *incx
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
   CBLAS_TEST_ZOMPLEX *A, *AP;
   CBLAS_INT i, j, k, LDA;
   CBLAS_TRANSPOSE trans;
@@ -475,7 +507,11 @@ 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) {
+     CBLAS_INT *n, CBLAS_TEST_ZOMPLEX *ap, CBLAS_TEST_ZOMPLEX *x, CBLAS_INT *incx
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
   CBLAS_TEST_ZOMPLEX *A, *AP;
   CBLAS_INT i, j, k, LDA;
   CBLAS_TRANSPOSE trans;
@@ -531,7 +567,11 @@ void F77_ztpsv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn,
 
 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) {
+      CBLAS_INT *incx
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
   CBLAS_TEST_ZOMPLEX *A;
   CBLAS_INT i,j,LDA;
   CBLAS_TRANSPOSE trans;
@@ -560,7 +600,11 @@ void F77_ztrmv(CBLAS_INT *layout, char *uplow, char *transp, char *diagn,
 }
 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) {
+              CBLAS_INT *incx
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
   CBLAS_TEST_ZOMPLEX *A;
   CBLAS_INT i,j,LDA;
   CBLAS_TRANSPOSE trans;
@@ -589,7 +633,11 @@ 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) {
+	     CBLAS_TEST_ZOMPLEX *x, CBLAS_INT *incx, CBLAS_TEST_ZOMPLEX *ap
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len
+#endif
+) {
   CBLAS_TEST_ZOMPLEX *A, *AP;
   CBLAS_INT i,j,k,LDA;
   CBLAS_UPLO uplo;
@@ -665,7 +713,11 @@ void F77_zhpr(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, double *alpha,
 
 void F77_zhpr2(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_TEST_ZOMPLEX *alpha,
        CBLAS_TEST_ZOMPLEX *x, CBLAS_INT *incx, CBLAS_TEST_ZOMPLEX *y, CBLAS_INT *incy,
-       CBLAS_TEST_ZOMPLEX *ap) {
+       CBLAS_TEST_ZOMPLEX *ap
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len
+#endif
+) {
   CBLAS_TEST_ZOMPLEX *A, *AP;
   CBLAS_INT i,j,k,LDA;
   CBLAS_UPLO uplo;
@@ -741,7 +793,11 @@ 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) {
+  CBLAS_TEST_ZOMPLEX *x, CBLAS_INT *incx, CBLAS_TEST_ZOMPLEX *a, CBLAS_INT *lda
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len
+#endif
+) {
   CBLAS_TEST_ZOMPLEX *A;
   CBLAS_INT i,j,LDA;
   CBLAS_UPLO uplo;
@@ -774,7 +830,11 @@ void F77_zher(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, double *alpha,
 
 void F77_zher2(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, CBLAS_TEST_ZOMPLEX *alpha,
           CBLAS_TEST_ZOMPLEX *x, CBLAS_INT *incx, CBLAS_TEST_ZOMPLEX *y, CBLAS_INT *incy,
-	  CBLAS_TEST_ZOMPLEX *a, CBLAS_INT *lda) {
+	  CBLAS_TEST_ZOMPLEX *a, CBLAS_INT *lda
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len
+#endif
+) {
 
   CBLAS_TEST_ZOMPLEX *A;
   CBLAS_INT i,j,LDA;

CBLAS/testing/c_zblas3.c

@@ -5,6 +5,7 @@
  *     Modified by T. H. Do, 4/15/98, SGI/CRAY Research.
  */
 #include <stdlib.h>
+#include <stdio.h>
 #include "cblas.h"
 #include "cblas_test.h"
 #define  TEST_COL_MJR	0
@@ -14,7 +15,11 @@
 void F77_zgemm(CBLAS_INT *layout, char *transpa, char *transpb, CBLAS_INT *m, 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 *c, CBLAS_INT *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN transpa_len, FORTRAN_STRLEN transpb_len
+#endif
+) {
 
   CBLAS_TEST_ZOMPLEX *A, *B, *C;
   CBLAS_INT i,j,LDA, LDB, LDC;
@@ -87,10 +92,96 @@ 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_zgemmtr( CblasRowMajor, uplo, transa, transb, *n, *k, alpha, A, LDA,
+              B, LDB, beta, C, LDC );
+      for( j=0; j<*n; j++ )
+          for( i=0; i<*n; i++ ) {
+              c[j*(*ldc)+i].real=C[i*LDC+j].real;
+              c[j*(*ldc)+i].imag=C[i*LDC+j].imag;
+          }
+      free(A);
+      free(B);
+      free(C);
+  }
+  else if (*layout == TEST_COL_MJR)
+      cblas_zgemmtr( CblasColMajor, uplo, transa, transb, *n, *k, alpha, a, *lda,
+              b, *ldb, beta, c, *ldc );
+  else
+      cblas_zgemmtr( UNDEFINED, uplo, transa, transb, *n, *k, alpha, a, *lda,
+              b, *ldb, beta, c, *ldc );
+}
+
+
 void F77_zhemm(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,
-        CBLAS_TEST_ZOMPLEX *c, CBLAS_INT *ldc ) {
+        CBLAS_TEST_ZOMPLEX *c, CBLAS_INT *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len
+#endif
+) {
 
   CBLAS_TEST_ZOMPLEX *A, *B, *C;
   CBLAS_INT i,j,LDA, LDB, LDC;
@@ -154,7 +245,11 @@ void F77_zhemm(CBLAS_INT *layout, char *rtlf, char *uplow, CBLAS_INT *m, CBLAS_I
 void F77_zsymm(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,
-          CBLAS_TEST_ZOMPLEX *c, CBLAS_INT *ldc ) {
+          CBLAS_TEST_ZOMPLEX *c, CBLAS_INT *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len
+#endif
+) {
 
   CBLAS_TEST_ZOMPLEX *A, *B, *C;
   CBLAS_INT i,j,LDA, LDB, LDC;
@@ -208,7 +303,11 @@ void F77_zsymm(CBLAS_INT *layout, char *rtlf, char *uplow, CBLAS_INT *m, CBLAS_I
 
 void F77_zherk(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLAS_INT *k,
      double *alpha, CBLAS_TEST_ZOMPLEX *a, CBLAS_INT *lda,
-     double *beta, CBLAS_TEST_ZOMPLEX *c, CBLAS_INT *ldc ) {
+     double *beta, CBLAS_TEST_ZOMPLEX *c, CBLAS_INT *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len
+#endif
+) {
 
   CBLAS_INT i,j,LDA,LDC;
   CBLAS_TEST_ZOMPLEX *A, *C;
@@ -264,7 +363,11 @@ void F77_zherk(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLAS
 
 void F77_zsyrk(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLAS_INT *k,
      CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, CBLAS_INT *lda,
-     CBLAS_TEST_ZOMPLEX *beta, CBLAS_TEST_ZOMPLEX *c, CBLAS_INT *ldc ) {
+     CBLAS_TEST_ZOMPLEX *beta, CBLAS_TEST_ZOMPLEX *c, CBLAS_INT *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len
+#endif
+) {
 
   CBLAS_INT i,j,LDA,LDC;
   CBLAS_TEST_ZOMPLEX *A, *C;
@@ -320,7 +423,11 @@ void F77_zsyrk(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLAS
 void F77_zher2k(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLAS_INT *k,
         CBLAS_TEST_ZOMPLEX *alpha, CBLAS_TEST_ZOMPLEX *a, CBLAS_INT *lda,
 	CBLAS_TEST_ZOMPLEX *b, CBLAS_INT *ldb, double *beta,
-        CBLAS_TEST_ZOMPLEX *c, CBLAS_INT *ldc ) {
+        CBLAS_TEST_ZOMPLEX *c, CBLAS_INT *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len
+#endif
+) {
   CBLAS_INT i,j,LDA,LDB,LDC;
   CBLAS_TEST_ZOMPLEX *A, *B, *C;
   CBLAS_UPLO uplo;
@@ -384,7 +491,11 @@ void F77_zher2k(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLA
 void F77_zsyr2k(CBLAS_INT *layout, char *uplow, char *transp, 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 *c, CBLAS_INT *ldc
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len
+#endif
+) {
   CBLAS_INT i,j,LDA,LDB,LDC;
   CBLAS_TEST_ZOMPLEX *A, *B, *C;
   CBLAS_UPLO uplo;
@@ -447,7 +558,11 @@ void F77_zsyr2k(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLA
 }
 void F77_ztrmm(CBLAS_INT *layout, char *rtlf, char *uplow, char *transp, char *diagn,
        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_INT *lda, CBLAS_TEST_ZOMPLEX *b, CBLAS_INT *ldb
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
   CBLAS_INT i,j,LDA,LDB;
   CBLAS_TEST_ZOMPLEX *A, *B;
   CBLAS_SIDE side;
@@ -506,7 +621,11 @@ void F77_ztrmm(CBLAS_INT *layout, char *rtlf, char *uplow, char *transp, char *d
 
 void F77_ztrsm(CBLAS_INT *layout, char *rtlf, char *uplow, char *transp, char *diagn,
          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_INT *lda, CBLAS_TEST_ZOMPLEX *b, CBLAS_INT *ldb
+#ifdef BLAS_FORTRAN_STRLEN_END
+  , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len, FORTRAN_STRLEN diagn_len
+#endif
+) {
   CBLAS_INT i,j,LDA,LDB;
   CBLAS_TEST_ZOMPLEX *A, *B;
   CBLAS_SIDE side;

CBLAS/testing/c_zblat2.f

@@ -349,13 +349,13 @@
            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.

CBLAS/testing/c_zblat3.f

@@ -4,7 +4,7 @@
 *
 *  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 @@
 *  (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 @@
       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 @@
       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 @@
       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 @@
       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 @@
             OK = .TRUE.
             FATAL = .FALSE.
             GO TO ( 140, 150, 150, 160, 160, 170, 170,
-     $              180, 180 )ISNUM
+     $              180, 180, 185) ISNUM
 *           Test ZGEMM, 01.
   140       IF (CORDER) THEN
             CALL ZCHK1(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
@@ -330,13 +331,13 @@
             CALL ZCHK3(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
      $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB,
      $                 AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C,
-     $		       0 )
+     $             0 )
             END IF
             IF (RORDER) THEN
             CALL ZCHK3(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
      $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB,
      $                 AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C,
-     $		       1 )
+     $             1 )
             END IF
             GO TO 190
 *           Test ZHERK, 06, ZSYRK, 07.
@@ -358,13 +359,27 @@
             CALL ZCHK5(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
      $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
      $                 NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W,
-     $		       0 )
+     $             0 )
             END IF
             IF (RORDER) THEN
             CALL ZCHK5(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
      $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
      $                 NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W,
-     $		       1 )
+     $             1 )
+            END IF
+            GO TO 190
+*           Test ZGEMMTR, 10
+  185       IF (CORDER) THEN
+            CALL ZCHK6(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
+     $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
+     $                 NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
+     $                 CC, CS, CT, G, 0 )
+            END IF
+            IF (RORDER) THEN
+            CALL ZCHK6(SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
+     $                 REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
+     $                 NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
+     $                 CC, CS, CT, G, 1 )
             END IF
             GO TO 190
 *
@@ -406,7 +421,7 @@
      $      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 @@
      $    ' 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 @@
       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 @@
   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 @@
       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 @@
       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 @@
       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 @@
   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 @@
       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 @@
       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 @@
       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 @@
   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 @@
       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 @@
       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 @@
       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 @@
   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 @@
       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 @@
       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 @@
       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 @@
       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 @@
       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 @@
   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 @@
       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 @@
       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 @@
       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 @@
       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,540 @@
 *
       END
 
+      SUBROUTINE ZCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
+     $                  FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
+     $                  A, AA, AS, B, BB, BS, C, CC, CS, CT, G,
+     $                  IORDER )
+      IMPLICIT NONE
+*
+*  Tests CGEMMTR.
+*
+*  Auxiliary routine for test program for Level 3 Blas.
+*
+*  -- Written on 24-June-2024.
+*     Martin Koehler, Max Planck Institute Magdeburg
+*
+*     .. Parameters ..
+      COMPLEX*16         ZERO
+      PARAMETER          ( ZERO = ( 0.0, 0.0 ) )
+      DOUBLE PRECISION   RZERO
+      PARAMETER          ( RZERO = 0.0 )
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION   EPS, THRESH
+      INTEGER            NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
+      LOGICAL            FATAL, REWI, TRACE
+      CHARACTER*13       SNAME
+*     .. Array Arguments ..
+      COMPLEX*16         A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
+     $                   AS( NMAX*NMAX ), B( NMAX, NMAX ),
+     $                   BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
+     $                   C( NMAX, NMAX ), CC( NMAX*NMAX ),
+     $                   CS( NMAX*NMAX ), CT( NMAX )
+      DOUBLE PRECISION   G( NMAX )
+      INTEGER            IDIM( NIDIM )
+*     .. Local Scalars ..
+      COMPLEX*16         ALPHA, ALS, BETA, BLS
+      DOUBLE PRECISION   ERR, ERRMAX
+      INTEGER            I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA,
+     $                   LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS,
+     $                   MA, MB, N, NA, NARGS, NB, NC, NS, IS
+      LOGICAL            NULL, RESET, SAME, TRANA, TRANB
+      CHARACTER*1        TRANAS, TRANBS, TRANSA, TRANSB, UPLO, UPLOS
+      CHARACTER*3        ICH
+      CHARACTER*2        ISHAPE
+*     .. Local Arrays ..
+      LOGICAL            ISAME( 13 )
+*     .. External Functions ..
+      LOGICAL            LZE, LZERES
+      EXTERNAL           LZE, LZERES
+*     .. External Subroutines ..
+      EXTERNAL           CZGEMMTR, ZMAKE, ZMMTCH, ZPRCN8
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     .. Scalars in Common ..
+      INTEGER            INFOT, NOUTC
+      LOGICAL            LERR, OK
+*     .. Common blocks ..
+      COMMON             /INFOC/INFOT, NOUTC, OK, LERR
+*     .. Data statements ..
+      DATA               ICH/'NTC'/
+      DATA               ISHAPE/'UL'/
+*     .. Executable Statements ..
+*
+      NARGS = 13
+      NC = 0
+      RESET = .TRUE.
+      ERRMAX = RZERO
+*
+      DO 100 IN = 1, NIDIM
+         N = IDIM( IN )
+*        Set LDC to 1 more than minimum value if room.
+         LDC = N
+         IF( LDC.LT.NMAX )
+     $      LDC = LDC + 1
+*        Skip tests if not enough room.
+         IF( LDC.GT.NMAX )
+     $      GO TO 100
+         LCC = LDC*N
+         NULL = N.LE.0.
+*
+         DO 90 IK = 1, NIDIM
+            K = IDIM( IK )
+*
+            DO 80 ICA = 1, 3
+               TRANSA = ICH( ICA: ICA )
+               TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
+*
+               IF( TRANA )THEN
+                  MA = K
+                  NA = N
+               ELSE
+                  MA = N
+                  NA = K
+               END IF
+*              Set LDA to 1 more than minimum value if room.
+               LDA = MA
+               IF( LDA.LT.NMAX )
+     $            LDA = LDA + 1
+*              Skip tests if not enough room.
+               IF( LDA.GT.NMAX )
+     $            GO TO 80
+               LAA = LDA*NA
+*
+*              Generate the matrix A.
+*
+               CALL ZMAKE( 'ge', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
+     $                     RESET, ZERO )
+*
+               DO 70 ICB = 1, 3
+                  TRANSB = ICH( ICB: ICB )
+                  TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
+*
+                  IF( TRANB )THEN
+                     MB = N
+                     NB = K
+                  ELSE
+                     MB = K
+                     NB = N
+                  END IF
+*                 Set LDB to 1 more than minimum value if room.
+                  LDB = MB
+                  IF( LDB.LT.NMAX )
+     $               LDB = LDB + 1
+*                 Skip tests if not enough room.
+                  IF( LDB.GT.NMAX )
+     $               GO TO 70
+                  LBB = LDB*NB
+*
+*                 Generate the matrix B.
+*
+                  CALL ZMAKE( 'ge', ' ', ' ', MB, NB, B, NMAX, BB,
+     $                        LDB, RESET, ZERO )
+*
+                  DO 60 IA = 1, NALF
+                     ALPHA = ALF( IA )
+*
+                     DO 50 IB = 1, NBET
+                        BETA = BET( IB )
+                        DO 45 IS = 1, 2
+                           UPLO = ISHAPE(IS:IS)
+*
+*                          Generate the matrix C.
+*
+                           CALL ZMAKE( 'ge', UPLO, ' ', N, N, C, NMAX,
+     $                                 CC, LDC, RESET, ZERO )
+*
+                           NC = NC + 1
+*
+*                          Save every datum before calling the
+*                          subroutine.
+*
+                           UPLOS = UPLO
+                           TRANAS = TRANSA
+                           TRANBS = TRANSB
+                           NS = N
+                           KS = K
+                           ALS = ALPHA
+                           DO 10 I = 1, LAA
+                              AS( I ) = AA( I )
+   10                      CONTINUE
+                           LDAS = LDA
+                           DO 20 I = 1, LBB
+                              BS( I ) = BB( I )
+   20                      CONTINUE
+                           LDBS = LDB
+                           BLS = BETA
+                           DO 30 I = 1, LCC
+                              CS( I ) = CC( I )
+   30                      CONTINUE
+                           LDCS = LDC
+*
+*                          Call the subroutine.
+*
+                           IF( TRACE )
+     $                        CALL ZPRCN8(NTRA, NC, SNAME, IORDER, UPLO,
+     $                        TRANSA, TRANSB, N, K, ALPHA, LDA,
+     $                        LDB, BETA, LDC)
+                           IF( REWI )
+     $                        REWIND NTRA
+                           CALL CZGEMMTR(IORDER, UPLO, TRANSA, TRANSB,
+     $                                 N, K, ALPHA, AA, LDA, BB, LDB,
+     $                                 BETA, CC, LDC )
+*
+*                          Check if error-exit was taken incorrectly.
+*
+                           IF( .NOT.OK )THEN
+                              WRITE( NOUT, FMT = 9994 )
+                              FATAL = .TRUE.
+                              GO TO 120
+                           END IF
+*
+*                          See what data changed inside subroutines.
+*
+                           ISAME( 1 ) = UPLO .EQ. UPLOS
+                           ISAME( 2 ) = TRANSA.EQ.TRANAS
+                           ISAME( 3 ) = TRANSB.EQ.TRANBS
+                           ISAME( 4 ) = NS.EQ.N
+                           ISAME( 5 ) = KS.EQ.K
+                           ISAME( 6 ) = ALS.EQ.ALPHA
+                           ISAME( 7 ) = LZE( AS, AA, LAA )
+                           ISAME( 8 ) = LDAS.EQ.LDA
+                           ISAME( 9 ) = LZE( BS, BB, LBB )
+                           ISAME( 10 ) = LDBS.EQ.LDB
+                           ISAME( 11 ) = BLS.EQ.BETA
+                           IF( NULL )THEN
+                              ISAME( 12 ) = LZE( CS, CC, LCC )
+                           ELSE
+                             ISAME( 12 ) = LZERES( 'ge', ' ', N, N, CS,
+     $                                      CC, LDC )
+                           END IF
+                           ISAME( 13 ) = LDCS.EQ.LDC
+*
+*                          If data was incorrectly changed, report
+*                          and return.
+*
+                           SAME = .TRUE.
+                           DO 40 I = 1, NARGS
+                              SAME = SAME.AND.ISAME( I )
+                              IF( .NOT.ISAME( I ) )
+     $                           WRITE( NOUT, FMT = 9998 )I
+   40                      CONTINUE
+                           IF( .NOT.SAME )THEN
+                              FATAL = .TRUE.
+                              GO TO 120
+                           END IF
+*
+                           IF( .NOT.NULL )THEN
+*
+*                             Check the result.
+*
+                              CALL ZMMTCH( UPLO, TRANSA, TRANSB, N, K,
+     $                                   ALPHA, A, NMAX, B, NMAX, BETA,
+     $                                   C, NMAX, CT, G, CC, LDC, EPS,
+     $                                   ERR, FATAL, NOUT, .TRUE. )
+                              ERRMAX = MAX( ERRMAX, ERR )
+*                             If got really bad answer, report and
+*                             return.
+                              IF( FATAL )
+     $                           GO TO 120
+                           END IF
+*
+   45                   CONTINUE
+*
+   50                CONTINUE
+*
+   60             CONTINUE
+*
+   70          CONTINUE
+*
+   80       CONTINUE
+*
+   90    CONTINUE
+*
+  100 CONTINUE
+*
+*
+*     Report result.
+*
+      IF( ERRMAX.LT.THRESH )THEN
+         IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC
+         IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC
+      ELSE
+         IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX
+         IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX
+      END IF
+      GO TO 130
+*
+  120 CONTINUE
+      WRITE( NOUT, FMT = 9996 )SNAME
+      CALL ZPRCN8(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, TRANSB,
+     $           N, K, ALPHA, LDA, LDB, BETA, LDC)
+*
+  130 CONTINUE
+      RETURN
+*
+10003 FORMAT( ' ', A13,' COMPLETED THE ROW-MAJOR    COMPUTATIONAL ',
+     $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
+     $ 'RATIO ', F8.2, ' - SUSPECT *******' )
+10002 FORMAT( ' ', A13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
+     $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
+     $ 'RATIO ', F8.2, ' - SUSPECT *******' )
+10001 FORMAT( ' ', A13,' PASSED THE ROW-MAJOR    COMPUTATIONAL TESTS',
+     $ ' (', I6, ' CALL', 'S)' )
+10000 FORMAT( ' ', A13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
+     $ ' (', I6, ' CALL', 'S)' )
+ 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
+     $      'ANGED INCORRECTLY *******' )
+ 9996 FORMAT( ' ******* ', A13,' FAILED ON CALL NUMBER:' )
+ 9995 FORMAT( 1X, I6, ': ', A13,'(''', A1, ''',''', A1, ''',',
+     $     3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3,
+     $     ',(', F4.1, ',', F4.1, '), C,', I3, ').' )
+ 9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
+     $      '******' )
+*
+*     End of ZCHK6.
+*
+      END
+
+      SUBROUTINE ZPRCN8(NOUT, NC, SNAME, IORDER, UPLO,
+     $                 TRANSA, TRANSB, N,
+     $                 K, ALPHA, LDA, LDB, BETA, LDC)
+      INTEGER          NOUT, NC, IORDER, N, K, LDA, LDB, LDC
+      COMPLEX*16       ALPHA, BETA
+      CHARACTER*1      TRANSA, TRANSB, UPLO
+      CHARACTER*13     SNAME
+      CHARACTER*14     CRC, CTA,CTB,CUPLO
+
+      IF (UPLO.EQ.'U') THEN
+          CUPLO = 'CblasUpper'
+      ELSE
+          CUPLO = 'CblasLower'
+      END IF
+      IF (TRANSA.EQ.'N')THEN
+         CTA = '  CblasNoTrans'
+      ELSE IF (TRANSA.EQ.'T')THEN
+         CTA = '    CblasTrans'
+      ELSE
+         CTA = 'CblasConjTrans'
+      END IF
+      IF (TRANSB.EQ.'N')THEN
+         CTB = '  CblasNoTrans'
+      ELSE IF (TRANSB.EQ.'T')THEN
+         CTB = '    CblasTrans'
+      ELSE
+         CTB = 'CblasConjTrans'
+      END IF
+      IF (IORDER.EQ.1)THEN
+         CRC = ' CblasRowMajor'
+      ELSE
+         CRC = ' CblasColMajor'
+      END IF
+      WRITE(NOUT, FMT = 9995)NC,SNAME,CRC, CUPLO, CTA,CTB
+      WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, LDB, BETA, LDC
+
+ 9995 FORMAT( 1X, I6, ': ', A13,'(', A14, ',', A14, ',', A14, ',',
+     $        A14, ',')
+ 9994 FORMAT( 10X, 2( I3, ',' ) ,' (', F4.1,',',F4.1,') , A,',
+     $ I3, ', B,', I3, ', (', F4.1,',',F4.1,') , C,', I3, ').' )
+      END
+
+      SUBROUTINE ZMMTCH(UPLO, TRANSA, TRANSB, N, KK, ALPHA, A, LDA,
+     $                  B, LDB,
+     $                  BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL,
+     $                  NOUT, MV )
+      IMPLICIT NONE
+*
+*  Checks the results of the computational tests for GEMMTR.
+*
+*  Auxiliary routine for test program for Level 3 Blas.
+*
+*  -- Written on 24-June-2024.
+*     Martin Koehler, Max Planck Institute, Magdeburg
+*
+*     .. Parameters ..
+      COMPLEX*16         ZERO
+      PARAMETER          ( ZERO = ( 0.0, 0.0 ) )
+      DOUBLE PRECISION   RZERO, RONE
+      PARAMETER          ( RZERO = 0.0, RONE = 1.0 )
+*     .. Scalar Arguments ..
+      COMPLEX*16         ALPHA, BETA
+      DOUBLE PRECISION   EPS, ERR
+      INTEGER            KK, LDA, LDB, LDC, LDCC, N, NOUT
+      LOGICAL            FATAL, MV
+      CHARACTER*1        TRANSA, TRANSB, UPLO
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), B( LDB, * ), C( LDC, * ),
+     $                   CC( LDCC, * ), CT( * )
+      DOUBLE PRECISION   G( * )
+*     .. Local Scalars ..
+      COMPLEX*16         CL
+      DOUBLE PRECISION   ERRI
+      INTEGER            I, J, K, ISTART, ISTOP
+      LOGICAL            CTRANA, CTRANB, TRANA, TRANB, UPPER
+*     .. Intrinsic Functions ..
+      INTRINSIC          DABS, DIMAG, DCONJG, MAX, DBLE, DSQRT
+*     .. Statement Functions ..
+      DOUBLE PRECISION   ABS1
+*     .. Statement Function definitions ..
+      ABS1( CL ) = DABS( DBLE( CL ) ) + DABS( DIMAG( CL ) )
+*     .. Executable Statements ..
+
+      UPPER = UPLO.EQ.'U'
+      TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
+      TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
+      CTRANA = TRANSA.EQ.'C'
+      CTRANB = TRANSB.EQ.'C'
+
+      ISTART = 1
+      ISTOP = N
+*
+*     Compute expected result, one column at a time, in CT using data
+*     in A, B and C.
+*     Compute gauges in G.
+*
+      DO 220 J = 1, N
+*
+         IF (UPPER) THEN
+             ISTART = 1
+             ISTOP =  J
+         ELSE
+             ISTART = J
+             ISTOP  = N
+         END IF
+         DO 10 I = ISTART, ISTOP
+            CT( I ) = ZERO
+            G( I ) = RZERO
+   10    CONTINUE
+         IF( .NOT.TRANA.AND..NOT.TRANB )THEN
+            DO 30 K = 1, KK
+               DO 20 I = ISTART, ISTOP
+                  CT( I ) = CT( I ) + A( I, K )*B( K, J )
+                  G( I ) = G( I ) + ABS1( A( I, K ) )*ABS1( B( K, J ) )
+   20          CONTINUE
+   30       CONTINUE
+         ELSE IF( TRANA.AND..NOT.TRANB )THEN
+            IF( CTRANA )THEN
+               DO 50 K = 1, KK
+                  DO 40 I =  ISTART, ISTOP
+                     CT( I ) = CT( I ) + DCONJG( A( K, I ) )*B( K, J )
+                     G( I ) = G( I ) + ABS1( A( K, I ) )*
+     $                        ABS1( B( K, J ) )
+   40             CONTINUE
+   50          CONTINUE
+            ELSE
+               DO 70 K = 1, KK
+                  DO 60 I = ISTART, ISTOP
+                     CT( I ) = CT( I ) + A( K, I )*B( K, J )
+                     G( I ) = G( I ) + ABS1( A( K, I ) )*
+     $                        ABS1( B( K, J ) )
+   60             CONTINUE
+   70          CONTINUE
+            END IF
+         ELSE IF( .NOT.TRANA.AND.TRANB )THEN
+            IF( CTRANB )THEN
+               DO 90 K = 1, KK
+                  DO 80 I =  ISTART, ISTOP
+                     CT( I ) = CT( I ) + A( I, K )*DCONJG( B( J, K ) )
+                     G( I ) = G( I ) + ABS1( A( I, K ) )*
+     $                        ABS1( B( J, K ) )
+   80             CONTINUE
+   90          CONTINUE
+            ELSE
+               DO 110 K = 1, KK
+                  DO 100 I = ISTART, ISTOP
+                     CT( I ) = CT( I ) + A( I, K )*B( J, K )
+                     G( I ) = G( I ) + ABS1( A( I, K ) )*
+     $                        ABS1( B( J, K ) )
+  100             CONTINUE
+  110          CONTINUE
+            END IF
+         ELSE IF( TRANA.AND.TRANB )THEN
+            IF( CTRANA )THEN
+               IF( CTRANB )THEN
+                  DO 130 K = 1, KK
+                     DO 120 I = ISTART, ISTOP
+                        CT( I ) = CT( I ) + DCONJG( A( K, I ) )*
+     $                            DCONJG( B( J, K ) )
+                        G( I ) = G( I ) + ABS1( A( K, I ) )*
+     $                           ABS1( B( J, K ) )
+  120                CONTINUE
+  130             CONTINUE
+               ELSE
+                  DO 150 K = 1, KK
+                     DO 140 I =  ISTART, ISTOP
+                       CT( I ) = CT( I ) + DCONJG( A( K, I ) )*B( J, K )
+                       G( I ) = G( I ) + ABS1( A( K, I ) )*
+     $                           ABS1( B( J, K ) )
+  140                CONTINUE
+  150             CONTINUE
+               END IF
+            ELSE
+               IF( CTRANB )THEN
+                  DO 170 K = 1, KK
+                     DO 160 I =  ISTART, ISTOP
+                       CT( I ) = CT( I ) + A( K, I )*DCONJG( B( J, K ) )
+                       G( I ) = G( I ) + ABS1( A( K, I ) )*
+     $                           ABS1( B( J, K ) )
+  160                CONTINUE
+  170             CONTINUE
+               ELSE
+                  DO 190 K = 1, KK
+                     DO 180 I =  ISTART, ISTOP
+                        CT( I ) = CT( I ) + A( K, I )*B( J, K )
+                        G( I ) = G( I ) + ABS1( A( K, I ) )*
+     $                           ABS1( B( J, K ) )
+  180                CONTINUE
+  190             CONTINUE
+               END IF
+            END IF
+         END IF
+         DO 200 I =  ISTART, ISTOP
+            CT( I ) = ALPHA*CT( I ) + BETA*C( I, J )
+            G( I ) = ABS1( ALPHA )*G( I ) +
+     $               ABS1( BETA )*ABS1( C( I, J ) )
+  200    CONTINUE
+*
+*        Compute the error ratio for this result.
+*
+         ERR = ZERO
+         DO 210 I =  ISTART, ISTOP
+            ERRI = ABS1( CT( I ) - CC( I, J ) )/EPS
+            IF( G( I ).NE.RZERO )
+     $         ERRI = ERRI/G( I )
+            ERR = MAX( ERR, ERRI )
+            IF( ERR*DSQRT( EPS ).GE.RONE )
+     $         GO TO 230
+  210    CONTINUE
+*
+  220 CONTINUE
+*
+*     If the loop completes, all results are at least half accurate.
+      GO TO 250
+*
+*     Report fatal error.
+*
+  230 FATAL = .TRUE.
+      WRITE( NOUT, FMT = 9999 )
+      DO 240 I =  ISTART, ISTOP
+         IF( MV )THEN
+            WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J )
+         ELSE
+            WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I )
+         END IF
+  240 CONTINUE
+      IF( N.GT.1 )
+     $   WRITE( NOUT, FMT = 9997 )J
+*
+  250 CONTINUE
+      RETURN
+*
+ 9999 FORMAT(' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
+     $     'F ACCURATE *******', /'                       EXPECTED RE',
+     $     'SULT                    COMPUTED RESULT' )
+ 9998 FORMAT( 1X, I7, 2( '  (', G15.6, ',', G15.6, ')' ) )
+ 9997 FORMAT( '      THESE ARE THE RESULTS FOR COLUMN ', I3 )
+*
+*     End of ZMMTCH.
+*
+      END
+

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_cgemmtr T PUT F FOR NO TEST. SAME COLUMNS.

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.

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.

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.

CMAKE/CheckLAPACKCompilerFlags.cmake

@@ -10,34 +10,32 @@
 # Copyright 2011
 #=============================================================================
 
-macro( CheckLAPACKCompilerFlags )
+macro(CheckLAPACKCompilerFlags)
 
-set( FPE_EXIT FALSE )
-
-# FORTRAN ILP default
-set(FOPT_ILP64)
-if( CMAKE_Fortran_COMPILER_ID MATCHES "Intel" )
-    if ( WIN32 )
-        set(FOPT_ILP64 /integer-size:64)
-    else ()
-        set(FOPT_ILP64 "-integer-size 64")
+  # FORTRAN ILP default
+  set(FOPT_ILP64)
+  if(CMAKE_Fortran_COMPILER_ID MATCHES "Intel")
+    if(WIN32)
+      set(FOPT_ILP64 /integer-size:64)
+    else()
+      set(FOPT_ILP64 "SHELL:-integer-size 64")
     endif()
-elseif( (CMAKE_Fortran_COMPILER_ID STREQUAL "VisualAge" ) OR  # CMake 2.6
-        (CMAKE_Fortran_COMPILER_ID STREQUAL "XL" ) )          # CMake 2.8
+  elseif((CMAKE_Fortran_COMPILER_ID STREQUAL "VisualAge") OR  # CMake 2.6
+         (CMAKE_Fortran_COMPILER_ID STREQUAL "XL"))           # CMake 2.8
     set(FOPT_ILP64 -qintsize=8)
-elseif( CMAKE_Fortran_COMPILER_ID STREQUAL "NAG" )
-    if ( WIN32 )
-        set(FOPT_ILP64 /i8)
-    else ()
-        set(FOPT_ILP64 -i8)
+  elseif(CMAKE_Fortran_COMPILER_ID STREQUAL "NAG")
+    if(WIN32)
+      set(FOPT_ILP64 /i8)
+    else()
+      set(FOPT_ILP64 -i8)
     endif()
-elseif( CMAKE_Fortran_COMPILER_ID STREQUAL "NVHPC" )
-    if ( WIN32 )
-        set(FOPT_ILP64 /i8)
-    else ()
-        set(FOPT_ILP64 -i8)
+  elseif(CMAKE_Fortran_COMPILER_ID STREQUAL "NVHPC")
+    if(WIN32)
+      set(FOPT_ILP64 /i8)
+    else()
+      set(FOPT_ILP64 -i8)
     endif()
-else()
+  else()
     set(CPE_ENV $ENV{PE_ENV})
     if(CPE_ENV STREQUAL "CRAY")
       set(FOPT_ILP64 -sinteger64)
@@ -46,210 +44,166 @@ else()
     else()
       set(FOPT_ILP64 -fdefault-integer-8)
     endif()
-endif()
-if ( FORTRAN_ILP )
-    set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} ${FOPT_ILP64}")
-endif()
-
-# GNU Fortran
-if( CMAKE_Fortran_COMPILER_ID STREQUAL "GNU" )
-  if( "${CMAKE_Fortran_FLAGS}" MATCHES "-ffpe-trap=[izoupd]")
-    set( FPE_EXIT TRUE )
   endif()
-  if( NOT ("${CMAKE_Fortran_FLAGS}" MATCHES "-frecursive") )
-    set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -frecursive"
-      CACHE STRING "Recursive flag must be set" FORCE)
+  if(FORTRAN_ILP)
+    add_compile_options("$<$<COMPILE_LANGUAGE:Fortran>:${FOPT_ILP64}>")
   endif()
 
-# Intel Fortran
-elseif( CMAKE_Fortran_COMPILER_ID MATCHES "Intel" )
-  if( "${CMAKE_Fortran_FLAGS}" MATCHES "[-/]fpe(-all=|)0" )
-    set( FPE_EXIT TRUE )
-  endif()
+  # GNU Fortran
+  if(CMAKE_Fortran_COMPILER_ID STREQUAL "GNU")
+    set(FPE_EXIT_FLAG "-ffpe-trap=[izoupd]")
 
-  if( NOT ("${CMAKE_Fortran_FLAGS}" MATCHES "-recursive") )
-    set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -recursive"
-      CACHE STRING "Recursive flag must be set" FORCE)
-  endif()
+    add_compile_options("$<$<COMPILE_LANGUAGE:Fortran>:-frecursive>")
 
-  if( UNIX AND NOT ("${CMAKE_Fortran_FLAGS}" MATCHES "-fp-model[ \t]strict") )
-    set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fp-model strict")
-  endif()
+    if(CMAKE_Fortran_COMPILER_VERSION VERSION_LESS "8")
+      add_compile_definitions("$<$<COMPILE_LANGUAGE:C>:FORTRAN_STRLEN=int>")
+    endif()
 
-# SunPro F95
-elseif( CMAKE_Fortran_COMPILER_ID STREQUAL "SunPro" )
-  if( ("${CMAKE_Fortran_FLAGS}" MATCHES "-ftrap=") AND
-      NOT ("${CMAKE_Fortran_FLAGS}" MATCHES "-ftrap=(%|)none") )
-    set( FPE_EXIT TRUE )
-  elseif( NOT (CMAKE_Fortran_FLAGS MATCHES "-ftrap=") )
-    message( STATUS "Disabling FPE trap handlers with -ftrap=%none" )
-    set( CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -ftrap=%none"
-         CACHE STRING "Flags for Fortran compiler." FORCE )
-  endif()
+  # Intel Fortran
+  elseif(CMAKE_Fortran_COMPILER_ID MATCHES "Intel")
+    set(FPE_EXIT_FLAG "[-/]fpe(-all=|)0")
 
-  if(UNIX)
-    # Delete libmtsk in linking sequence for Sun/Oracle Fortran Compiler.
-    # This library is not present in the Sun package SolarisStudio12.3-linux-x86-bin
-    string(REPLACE \;mtsk\; \; CMAKE_Fortran_IMPLICIT_LINK_LIBRARIES "${CMAKE_Fortran_IMPLICIT_LINK_LIBRARIES}")
-  endif()
+    add_compile_options("$<$<COMPILE_LANGUAGE:Fortran>:-recursive>")
+    if(UNIX)
+      add_compile_options("$<$<COMPILE_LANGUAGE:Fortran>:SHELL:-fp-model strict>")
+    endif()
 
-# IBM XL Fortran
-elseif( (CMAKE_Fortran_COMPILER_ID STREQUAL "VisualAge" ) OR  # CMake 2.6
-        (CMAKE_Fortran_COMPILER_ID STREQUAL "XL" ) )          # CMake 2.8
-  if( "${CMAKE_Fortran_FLAGS}" MATCHES "-qflttrap=[a-zA-Z:]:enable" )
-    set( FPE_EXIT TRUE )
-  endif()
+  # SunPro F95
+  elseif(CMAKE_Fortran_COMPILER_ID STREQUAL "SunPro")
+    set(FPE_EXIT_FLAG "-ftrap=")
+    set(FPE_DISABLE_FLAG "-ftrap=(%|)none")
 
-  if( NOT ("${CMAKE_Fortran_FLAGS}" MATCHES "-qrecur") )
-    set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -qrecur"
-      CACHE STRING "Recursive flag must be set" FORCE)
-  endif()
+    message(STATUS "Disabling FPE trap handlers with -ftrap=%none")
+    add_compile_options("$<$<COMPILE_LANGUAGE:Fortran>:-ftrap=%none>")
 
-  if( UNIX AND NOT ("${CMAKE_Fortran_FLAGS}" MATCHES "-qnosave") )
-    set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -qnosave")
-  endif()
+    if(UNIX)
+      # Delete libmtsk in linking sequence for Sun/Oracle Fortran Compiler.
+      # This library is not present in the Sun package SolarisStudio12.3-linux-x86-bin
+      string(REPLACE \;mtsk\; \; CMAKE_Fortran_IMPLICIT_LINK_LIBRARIES
+             "${CMAKE_Fortran_IMPLICIT_LINK_LIBRARIES}")
+    endif()
 
+  # IBM XL Fortran
+  elseif((CMAKE_Fortran_COMPILER_ID STREQUAL "VisualAge") OR  # CMake 2.6
+         (CMAKE_Fortran_COMPILER_ID STREQUAL "XL"))           # CMake 2.8
+    set(FPE_EXIT_FLAG "-qflttrap=[a-zA-Z:]:enable")
 
-  if( UNIX AND NOT ("${CMAKE_Fortran_FLAGS}" MATCHES "-qstrict") )
-    set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -qstrict")
-  endif()
+    add_compile_options("$<$<COMPILE_LANGUAGE:Fortran>:-qrecur>")
+    if(UNIX)
+      add_compile_options("$<$<COMPILE_LANGUAGE:Fortran>:-qnosave>")
+      add_compile_options("$<$<COMPILE_LANGUAGE:Fortran>:-qstrict>")
+    endif()
 
-# HP Fortran
-elseif( CMAKE_Fortran_COMPILER_ID STREQUAL "HP" )
-  if( "${CMAKE_Fortran_FLAGS}" MATCHES "\\+fp_exception" )
-    set( FPE_EXIT TRUE )
-  endif()
+  # HP Fortran
+  elseif(CMAKE_Fortran_COMPILER_ID STREQUAL "HP")
+    set(FPE_EXIT_FLAG "\\+fp_exception")
 
-  if( NOT ("${CMAKE_Fortran_FLAGS}" MATCHES "\\+fltconst_strict") )
-    message( STATUS "Enabling strict float conversion with +fltconst_strict" )
-    set( CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} +fltconst_strict"
-         CACHE STRING "Flags for Fortran compiler." FORCE )
-  endif()
+    message(STATUS "Enabling strict float conversion with +fltconst_strict")
+    add_compile_options("$<$<COMPILE_LANGUAGE:Fortran>:+fltconst_strict>")
 
-  # Most versions of cmake don't have good default options for the HP compiler
-  set( CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_DEBUG} -g"
-       CACHE STRING "Flags used by the compiler during debug builds" FORCE )
-  set( CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_MINSIZEREL} +Osize"
-       CACHE STRING "Flags used by the compiler during release minsize builds" FORCE )
-  set( CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_RELEASE} +O2"
-       CACHE STRING "Flags used by the compiler during release builds" FORCE )
-  set( CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_RELWITHDEBINFO} +O2 -g"
-       CACHE STRING "Flags used by the compiler during release with debug info builds" FORCE )
+    # Most versions of cmake don't have good default options for the HP compiler
+    add_compile_options("$<$<AND:$<COMPILE_LANGUAGE:Fortran>,$<CONFIG:DEBUG>>:-g>")
+    add_compile_options("$<$<AND:$<COMPILE_LANGUAGE:Fortran>,$<CONFIG:MINSIZEREL>>:+Osize>")
+    add_compile_options("$<$<AND:$<COMPILE_LANGUAGE:Fortran>,$<CONFIG:RELEASE>>:+O2>")
+    add_compile_options("$<$<AND:$<COMPILE_LANGUAGE:Fortran>,$<CONFIG:RELWITHDEBINFO>>:+O2 -g>")
 
-# NAG Fortran
-elseif( CMAKE_Fortran_COMPILER_ID STREQUAL "NAG" )
-  if( "${CMAKE_Fortran_FLAGS}" MATCHES "[-/]ieee=(stop|nonstd)" )
-    set( FPE_EXIT TRUE )
-  endif()
+  # NAG Fortran
+  elseif(CMAKE_Fortran_COMPILER_ID STREQUAL "NAG")
+    set(FPE_EXIT_FLAG "[-/]ieee=(stop|nonstd)")
 
-  if( NOT ("${CMAKE_Fortran_FLAGS}" MATCHES "[-/]ieee=full") )
-    set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -ieee=full")
-  endif()
+    add_compile_options("$<$<COMPILE_LANGUAGE:Fortran>:-ieee=full>")
+    add_compile_options("$<$<COMPILE_LANGUAGE:Fortran>:-dcfuns>")
+    add_compile_options("$<$<COMPILE_LANGUAGE:Fortran>:-thread_safe>")
+    add_link_options("$<$<COMPILE_LANGUAGE:Fortran>:-thread_safe>")
+    add_compile_options("$<$<COMPILE_LANGUAGE:Fortran>:-recursive>")
 
-  if( NOT ("${CMAKE_Fortran_FLAGS}" MATCHES "[-/]dcfuns") )
-    set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -dcfuns")
-  endif()
+    # By default NAG Fortran uses 32bit integers as hidden STRLEN arguments
+    if(UNIX)
+      if(APPLE)
+        add_compile_definitions("$<$<COMPILE_LANGUAGE:C>:FORTRAN_STRLEN=int>")
+      else()
+        # Get all flags added via `add_compile_options(...)`
+        get_directory_property(COMP_OPTIONS COMPILE_OPTIONS)
 
-  if( NOT ("${CMAKE_Fortran_FLAGS}" MATCHES "[-/]thread_safe") )
-    set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -thread_safe")
-  endif()
-
-  # Disable warnings
-  if( NOT ("${CMAKE_Fortran_FLAGS}" MATCHES "[-/]w=obs") )
-    set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -w=obs")
-  endif()
-
-  if( NOT ("${CMAKE_Fortran_FLAGS}" MATCHES "[-/]w=x77") )
-    set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -w=x77")
-  endif()
-
-  if( NOT ("${CMAKE_Fortran_FLAGS}" MATCHES "[-/]w=ques") )
-    set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -w=ques")
-  endif()
-
-  if( NOT ("${CMAKE_Fortran_FLAGS}" MATCHES "[-/]w=unused") )
-    set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -w=unused")
-  endif()
-
-  if( NOT ("${CMAKE_Fortran_FLAGS}" MATCHES "-recursive") )
-    set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -recursive"
-      CACHE STRING "Recursive flag must be set" FORCE)
-  endif()
-
-  # Suppress compiler banner and summary
-  include(CheckFortranCompilerFlag)
-  check_fortran_compiler_flag("-quiet" _quiet)
-  if( _quiet AND NOT ("${CMAKE_Fortran_FLAGS}" MATCHES "[-/]quiet") )
-    set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -quiet")
-  endif()
-
-# NVIDIA HPC SDK
-elseif( CMAKE_Fortran_COMPILER_ID STREQUAL "NVHPC" )
-  if( ("${CMAKE_Fortran_FLAGS}" MATCHES "-Ktrap=") AND
-      NOT ("${CMAKE_Fortran_FLAGS}" MATCHES "-Ktrap=none") )
-    set( FPE_EXIT TRUE )
-  endif()
-
-  if( NOT ("${CMAKE_Fortran_FLAGS}" MATCHES "[-/]Kieee") )
-    set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -Kieee")
-  endif()
-
-  if( NOT ("${CMAKE_Fortran_FLAGS}" MATCHES "-Mrecursive") )
-    set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -Mrecursive"
-      CACHE STRING "Recursive flag must be set" FORCE)
-  endif()
-
-# Flang Fortran
-elseif( CMAKE_Fortran_COMPILER_ID STREQUAL "Flang" )
-  if( NOT ("${CMAKE_Fortran_FLAGS}" MATCHES "-Mrecursive") )
-    set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -Mrecursive"
-      CACHE STRING "Recursive flag must be set" FORCE)
-  endif()
-
-# Compaq Fortran
-elseif(CMAKE_Fortran_COMPILER_ID STREQUAL "Compaq")
-  if(WIN32)
-    if(CMAKE_GENERATOR STREQUAL "NMake Makefiles")
-      get_filename_component(CMAKE_Fortran_COMPILER_CMDNAM ${CMAKE_Fortran_COMPILER} NAME_WE)
-      message(STATUS "Using Compaq Fortran compiler with command name ${CMAKE_Fortran_COMPILER_CMDNAM}")
-      set(cmd ${CMAKE_Fortran_COMPILER_CMDNAM})
-      string(TOLOWER "${cmd}" cmdlc)
-      if(cmdlc STREQUAL "df")
-        message(STATUS "Assume the Compaq Visual Fortran Compiler is being used")
-        set(CMAKE_Fortran_USE_RESPONSE_FILE_FOR_OBJECTS 1)
-        set(CMAKE_Fortran_USE_RESPONSE_FILE_FOR_INCLUDES 1)
-        #This is a workaround that is needed to avoid forward-slashes in the
-        #filenames listed in response files from incorrectly being interpreted as
-        #introducing compiler command options
-        if(${BUILD_SHARED_LIBS})
-          message(FATAL_ERROR "Making of shared libraries with CVF has not been tested.")
+        if(NOT("${CMAKE_Fortran_FLAGS};${COMP_OPTIONS}" MATCHES "-abi=64c"))
+          add_compile_definitions("$<$<COMPILE_LANGUAGE:C>:FORTRAN_STRLEN=int>")
         endif()
-        set(str "NMake version 9 or later should be used. NMake version 6.0 which is\n")
-        set(str "${str}   included with the CVF distribution fails to build Lapack because\n")
-        set(str "${str}   the number of source files exceeds the limit for NMake v6.0\n")
-        message(STATUS ${str})
-        set(CMAKE_Fortran_LINK_EXECUTABLE "LINK /out:<TARGET> <LINK_FLAGS> <LINK_LIBRARIES> <OBJECTS>")
       endif()
     endif()
+
+    # Disable warnings
+    add_compile_options("$<$<COMPILE_LANGUAGE:Fortran>:-w=obs>")
+    add_compile_options("$<$<COMPILE_LANGUAGE:Fortran>:-w=x77>")
+    add_compile_options("$<$<COMPILE_LANGUAGE:Fortran>:-w=ques>")
+    add_compile_options("$<$<COMPILE_LANGUAGE:Fortran>:-w=unused>")
+
+    # Suppress compiler banner and summary
+    include(CheckFortranCompilerFlag)
+    check_fortran_compiler_flag("-quiet" _quiet)
+    add_compile_options("$<$<AND:$<COMPILE_LANGUAGE:Fortran>,$<BOOL:${_quiet}>>:-quiet>")
+    add_link_options("$<$<AND:$<COMPILE_LANGUAGE:Fortran>,$<BOOL:${_quiet}>>:-quiet>")
+
+  # NVIDIA HPC SDK
+  elseif(CMAKE_Fortran_COMPILER_ID STREQUAL "NVHPC")
+    set(FPE_EXIT_FLAG "-Ktrap=")
+    set(FPE_DISABLE_FLAG "-Ktrap=none")
+
+    add_compile_options("$<$<COMPILE_LANGUAGE:Fortran>:-Kieee>")
+    add_compile_options("$<$<COMPILE_LANGUAGE:Fortran>:-Mrecursive>")
+
+  # Flang Fortran
+  elseif(CMAKE_Fortran_COMPILER_ID STREQUAL "Flang")
+    add_compile_options("$<$<COMPILE_LANGUAGE:Fortran>:-Mrecursive>")
+
+  # Compaq Fortran
+  elseif(CMAKE_Fortran_COMPILER_ID STREQUAL "Compaq")
+    if(WIN32)
+      if(CMAKE_GENERATOR STREQUAL "NMake Makefiles")
+        get_filename_component(CMAKE_Fortran_COMPILER_CMDNAM ${CMAKE_Fortran_COMPILER} NAME_WE)
+        message(STATUS "Using Compaq Fortran compiler with command name ${CMAKE_Fortran_COMPILER_CMDNAM}")
+        set(cmd ${CMAKE_Fortran_COMPILER_CMDNAM})
+        string(TOLOWER "${cmd}" cmdlc)
+        if(cmdlc STREQUAL "df")
+          message(STATUS "Assume the Compaq Visual Fortran Compiler is being used")
+          set(CMAKE_Fortran_USE_RESPONSE_FILE_FOR_OBJECTS 1)
+          set(CMAKE_Fortran_USE_RESPONSE_FILE_FOR_INCLUDES 1)
+          #This is a workaround that is needed to avoid forward-slashes in the
+          #filenames listed in response files from incorrectly being interpreted as
+          #introducing compiler command options
+          if(${BUILD_SHARED_LIBS})
+            message(FATAL_ERROR "Making of shared libraries with CVF has not been tested.")
+          endif()
+          set(str "NMake version 9 or later should be used. NMake version 6.0 which is\n")
+          set(str "${str}   included with the CVF distribution fails to build Lapack because\n")
+          set(str "${str}   the number of source files exceeds the limit for NMake v6.0\n")
+          message(STATUS ${str})
+          set(CMAKE_Fortran_LINK_EXECUTABLE "LINK /out:<TARGET> <LINK_FLAGS> <LINK_LIBRARIES> <OBJECTS>")
+        endif()
+      endif()
+    endif()
+
+  else()
+    message(WARNING "Fortran local arrays should be allocated on the stack."
+      " Please use a compiler which guarantees that feature."
+      " See https://github.com/Reference-LAPACK/lapack/pull/188 and references therein.")
   endif()
 
-else()
-  message(WARNING "Fortran local arrays should be allocated on the stack."
-    " Please use a compiler which guarantees that feature."
-    " See https://github.com/Reference-LAPACK/lapack/pull/188 and references therein.")
-endif()
+  if("${CMAKE_Fortran_FLAGS_RELEASE}" MATCHES "O[3-9]")
+    message(STATUS "Reducing RELEASE optimization level to O2")
+    string(REGEX REPLACE "O[3-9]" "O2" CMAKE_Fortran_FLAGS_RELEASE
+           "${CMAKE_Fortran_FLAGS_RELEASE}")
+  endif()
 
-if( "${CMAKE_Fortran_FLAGS_RELEASE}" MATCHES "O[3-9]" )
-  message( STATUS "Reducing RELEASE optimization level to O2" )
-  string( REGEX REPLACE "O[3-9]" "O2" CMAKE_Fortran_FLAGS_RELEASE
-          "${CMAKE_Fortran_FLAGS_RELEASE}" )
-  set( CMAKE_Fortran_FLAGS_RELEASE "${CMAKE_Fortran_FLAGS_RELEASE}"
-       CACHE STRING "Flags used by the compiler during release builds" FORCE )
-endif()
+  # Get all flags added via `add_compile_options(...)`
+  get_directory_property(COMP_OPTIONS COMPILE_OPTIONS)
 
-
-if( FPE_EXIT )
-  message( FATAL_ERROR "Floating Point Exception (FPE) trap handlers are currently explicitly enabled in the compiler flags.  LAPACK is designed to check for and handle these cases internally and enabling these traps will likely cause LAPACK to crash.  Please re-configure with floating point exception trapping disabled." )
-endif()
+  if(("${CMAKE_Fortran_FLAGS};${COMP_OPTIONS}" MATCHES "${FPE_EXIT_FLAG}") AND NOT
+     ("${CMAKE_Fortran_FLAGS};${COMP_OPTIONS}" MATCHES "${FPE_DISABLE_FLAG}"))
+    message( FATAL_ERROR "Floating Point Exception (FPE) trap handlers are"
+      " currently explicitly enabled in the compiler flags.  LAPACK is designed"
+      " to check for and handle these cases internally and enabling these traps"
+      " will likely cause LAPACK to crash.  Please re-configure with floating"
+      " point exception trapping disabled.")
+  endif()
 
 endmacro()

CMakeLists.txt

@@ -1,6 +1,6 @@
-cmake_minimum_required(VERSION 3.9)
+cmake_minimum_required(VERSION 3.13)
 
-project(LAPACK)
+project(LAPACK C)
 
 set(LAPACK_MAJOR_VERSION 3)
 set(LAPACK_MINOR_VERSION 12)
@@ -107,28 +107,22 @@ else()
   set(LAPACKELIB "lapacke")
   set(TMGLIB "tmglib")
 endif()
-# By default build extended _64 API for supported compilers only
+
+# By default build extended _64 API for supported compilers only. This needs
+# CMake >= 3.18! Let's disable it by default for CMake < 3.18.
+if(CMAKE_VERSION VERSION_LESS "3.18")
+  set(INDEX64_EXT_API_DEFAULT OFF)
+else()
+  set(INDEX64_EXT_API_DEFAULT ON)
+endif()
 set(INDEX64_EXT_API_COMPILERS "Intel|GNU")
-option(BUILD_INDEX64_EXT_API "Build Index-64 API as extended API with _64 suffix" ON)
+option(BUILD_INDEX64_EXT_API
+  "Build Index-64 API as extended API with _64 suffix (needs CMake >= 3.18)"
+  ${INDEX64_EXT_API_DEFAULT})
 message(STATUS "Build Index-64 API as extended API with _64 suffix: ${BUILD_INDEX64_EXT_API}")
 
 include(GNUInstallDirs)
 
-# Updated OSX RPATH settings
-# In response to CMake 3.0 generating warnings regarding policy CMP0042,
-# the OSX RPATH settings have been updated per recommendations found
-# in the CMake Wiki:
-#  http://www.cmake.org/Wiki/CMake_RPATH_handling#Mac_OS_X_and_the_RPATH
-set(CMAKE_MACOSX_RPATH ON)
-set(CMAKE_SKIP_BUILD_RPATH FALSE)
-set(CMAKE_BUILD_WITH_INSTALL_RPATH FALSE)
-list(FIND CMAKE_PLATFORM_IMPLICIT_LINK_DIRECTORIES ${CMAKE_INSTALL_FULL_LIBDIR} isSystemDir)
-if("${isSystemDir}" STREQUAL "-1")
-  set(CMAKE_INSTALL_RPATH ${CMAKE_INSTALL_FULL_LIBDIR})
-  set(CMAKE_INSTALL_RPATH_USE_LINK_PATH TRUE)
-endif()
-
-
 # Configure the warning and code coverage suppression file
 configure_file(
   "${LAPACK_SOURCE_DIR}/CTestCustom.cmake.in"
@@ -159,12 +153,18 @@ endif()
 # --------------------------------------------------
 set(LAPACK_INSTALL_EXPORT_NAME ${LAPACKLIB}-targets)
 
+set(LAPACK_BINARY_PATH_SUFFIX "" CACHE STRING "Path suffix appended to the install path of binaries")
+
+if(NOT "${LAPACK_BINARY_PATH_SUFFIX}" STREQUAL "" AND NOT "${LAPACK_BINARY_PATH_SUFFIX}" MATCHES "^/")
+  set(LAPACK_BINARY_PATH_SUFFIX "/${LAPACK_BINARY_PATH_SUFFIX}")
+endif()
+
 macro(lapack_install_library lib)
   install(TARGETS ${lib}
     EXPORT ${LAPACK_INSTALL_EXPORT_NAME}
-    ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR} COMPONENT Development
-    LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR} COMPONENT RuntimeLibraries
-    RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR} COMPONENT RuntimeLibraries
+    ARCHIVE DESTINATION "${CMAKE_INSTALL_LIBDIR}${LAPACK_BINARY_PATH_SUFFIX}" COMPONENT Development
+    LIBRARY DESTINATION "${CMAKE_INSTALL_LIBDIR}${LAPACK_BINARY_PATH_SUFFIX}" COMPONENT RuntimeLibraries
+    RUNTIME DESTINATION "${CMAKE_INSTALL_BINDIR}${LAPACK_BINARY_PATH_SUFFIX}" COMPONENT RuntimeLibraries
   )
 endmacro()
 
@@ -250,15 +250,7 @@ if(NOT BLAS_FOUND)
   add_subdirectory(BLAS)
   set(BLAS_LIBRARIES ${BLASLIB})
 else()
-  set(CMAKE_EXE_LINKER_FLAGS
-    "${CMAKE_EXE_LINKER_FLAGS} ${BLAS_LINKER_FLAGS}"
-    CACHE STRING "Linker flags for executables" FORCE)
-  set(CMAKE_MODULE_LINKER_FLAGS
-    "${CMAKE_MODULE_LINKER_FLAGS} ${BLAS_LINKER_FLAGS}"
-    CACHE STRING "Linker flags for modules" FORCE)
-  set(CMAKE_SHARED_LINKER_FLAGS
-    "${CMAKE_SHARED_LINKER_FLAGS} ${BLAS_LINKER_FLAGS}"
-    CACHE STRING "Linker flags for shared libs" FORCE)
+  add_link_options(${BLAS_LINKER_FLAGS})
 endif()
 
 
@@ -340,15 +332,7 @@ if(NOT LATESTLAPACK_FOUND)
 
   add_subdirectory(SRC)
 else()
-  set(CMAKE_EXE_LINKER_FLAGS
-    "${CMAKE_EXE_LINKER_FLAGS} ${LAPACK_LINKER_FLAGS}"
-    CACHE STRING "Linker flags for executables" FORCE)
-  set(CMAKE_MODULE_LINKER_FLAGS
-    "${CMAKE_MODULE_LINKER_FLAGS} ${LAPACK_LINKER_FLAGS}"
-    CACHE STRING "Linker flags for modules" FORCE)
-  set(CMAKE_SHARED_LINKER_FLAGS
-    "${CMAKE_SHARED_LINKER_FLAGS} ${LAPACK_LINKER_FLAGS}"
-    CACHE STRING "Linker flags for shared libs" FORCE)
+  add_link_options(${LAPACK_LINKER_FLAGS})
 endif()
 
 if(BUILD_TESTING)
@@ -557,7 +541,7 @@ install(FILES
 if (LAPACK++)
   install(
   DIRECTORY "${LAPACK_BINARY_DIR}/lib/"
-  DESTINATION ${CMAKE_INSTALL_LIBDIR}
+  DESTINATION "${CMAKE_INSTALL_LIBDIR}${LAPACK_BINARY_PATH_SUFFIX}"
   FILES_MATCHING REGEX "liblapackpp.(a|so)$"
   )
   install(
@@ -590,7 +574,7 @@ if (BLAS++)
   )
   install(
   DIRECTORY "${LAPACK_BINARY_DIR}/lib/"
-  DESTINATION ${CMAKE_INSTALL_LIBDIR}
+  DESTINATION "${CMAKE_INSTALL_LIBDIR}${LAPACK_BINARY_PATH_SUFFIX}"
   FILES_MATCHING REGEX "libblaspp.(a|so)$"
   )
   install(

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

INSTALL/CMakeLists.txt

@@ -1,5 +1,13 @@
-cmake_minimum_required(VERSION 3.6)
+cmake_minimum_required(VERSION 3.13)
 project(TIMING Fortran)
+
+# Add the CMake directory for custom CMake modules
+set(CMAKE_MODULE_PATH "${TIMING_SOURCE_DIR}/../CMAKE" ${CMAKE_MODULE_PATH})
+
+# Check for any necessary platform specific compiler flags
+include(CheckLAPACKCompilerFlags)
+CheckLAPACKCompilerFlags()
+
 add_executable(secondtst_NONE second_NONE.f secondtst.f)
 add_executable(secondtst_EXT_ETIME second_EXT_ETIME.f secondtst.f)
 add_executable(secondtst_EXT_ETIME_ second_EXT_ETIME_.f secondtst.f)

LAPACKE/mangling/CMakeLists.txt

@@ -1,4 +1,4 @@
-cmake_minimum_required(VERSION 3.6)
+cmake_minimum_required(VERSION 3.13)
 project(MANGLING C Fortran)
 
 add_executable(xintface Fintface.f Cintface.c)

LAPACKE/src/lapacke_ctfsm.c

@@ -44,9 +44,11 @@ lapack_int API_SUFFIX(LAPACKE_ctfsm)( int matrix_layout, char transr, char side,
     }
 #ifndef LAPACK_DISABLE_NAN_CHECK
     if( LAPACKE_get_nancheck() ) {
+        lapack_int mn = m;
+        if( API_SUFFIX(LAPACKE_lsame)( side, 'r' ) ) mn = n;
         /* Optionally check input matrices for NaNs */
         if( IS_C_NONZERO(alpha) ) {
-            if( API_SUFFIX(LAPACKE_ctf_nancheck)( matrix_layout, transr, uplo, diag, n, a ) ) {
+            if( API_SUFFIX(LAPACKE_ctf_nancheck)( matrix_layout, transr, uplo, diag, mn, a ) ) {
                 return -10;
             }
         }

LAPACKE/src/lapacke_ctfsm_work.c

@@ -48,10 +48,12 @@ lapack_int API_SUFFIX(LAPACKE_ctfsm_work)( int matrix_layout, char transr, char
         }
     } else if( matrix_layout == LAPACK_ROW_MAJOR ) {
         lapack_int ldb_t = MAX(1,m);
+        lapack_int mn = m;
         lapack_complex_float* b_t = NULL;
         lapack_complex_float* a_t = NULL;
+        if( API_SUFFIX(LAPACKE_lsame)( side, 'r' ) ) mn = n;
         /* Check leading dimension(s) */
-        if( ldb < n ) {
+        if( ldb < m ) {
             info = -12;
             API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_ctfsm_work", info );
             return info;
@@ -66,7 +68,7 @@ lapack_int API_SUFFIX(LAPACKE_ctfsm_work)( int matrix_layout, char transr, char
         if( IS_C_NONZERO(alpha) ) {
             a_t = (lapack_complex_float*)
                 LAPACKE_malloc( sizeof(lapack_complex_float) *
-                                ( MAX(1,n) * MAX(2,n+1) ) / 2 );
+                                ( MAX(1,mn) * MAX(2,mn+1) ) / 2 );
             if( a_t == NULL ) {
                 info = LAPACK_TRANSPOSE_MEMORY_ERROR;
                 goto exit_level_1;
@@ -77,7 +79,7 @@ lapack_int API_SUFFIX(LAPACKE_ctfsm_work)( int matrix_layout, char transr, char
             API_SUFFIX(LAPACKE_cge_trans)( matrix_layout, m, n, b, ldb, b_t, ldb_t );
         }
         if( IS_C_NONZERO(alpha) ) {
-            API_SUFFIX(LAPACKE_ctf_trans)( matrix_layout, transr, uplo, diag, n, a, a_t );
+            API_SUFFIX(LAPACKE_ctf_trans)( matrix_layout, transr, uplo, diag, mn, a, a_t );
         }
         /* Call LAPACK function and adjust info */
         LAPACK_ctfsm( &transr, &side, &uplo, &trans, &diag, &m, &n, &alpha, a_t,

LAPACKE/src/lapacke_ctpmqrt_work.c

@@ -51,8 +51,8 @@ lapack_int API_SUFFIX(LAPACKE_ctpmqrt_work)( int matrix_layout, char side, char
         }
     } else if( matrix_layout == LAPACK_ROW_MAJOR ) {
         lapack_int nrowsA, ncolsA, nrowsV;
-        if      ( side == API_SUFFIX(LAPACKE_lsame)(side, 'l') ) { nrowsA = k; ncolsA = n; nrowsV = m; }
-        else if ( side == API_SUFFIX(LAPACKE_lsame)(side, 'r') ) { nrowsA = m; ncolsA = k; nrowsV = n; }
+        if      ( API_SUFFIX(LAPACKE_lsame)(side, 'l') ) { nrowsA = k; ncolsA = n; nrowsV = m; }
+        else if ( API_SUFFIX(LAPACKE_lsame)(side, 'r') ) { nrowsA = m; ncolsA = k; nrowsV = n; }
         else {
             info = -2;
             API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_ctpmqrt_work", info );

LAPACKE/src/lapacke_dtfsm.c

@@ -44,8 +44,10 @@ lapack_int API_SUFFIX(LAPACKE_dtfsm)( int matrix_layout, char transr, char side,
 #ifndef LAPACK_DISABLE_NAN_CHECK
     if( LAPACKE_get_nancheck() ) {
         /* Optionally check input matrices for NaNs */
+        lapack_int mn = m;
+        if( API_SUFFIX(LAPACKE_lsame)( side, 'r' ) ) mn = n;
         if( IS_D_NONZERO(alpha) ) {
-            if( API_SUFFIX(LAPACKE_dtf_nancheck)( matrix_layout, transr, uplo, diag, n, a ) ) {
+            if( API_SUFFIX(LAPACKE_dtf_nancheck)( matrix_layout, transr, uplo, diag, mn, a ) ) {
                 return -10;
             }
         }

LAPACKE/src/lapacke_dtfsm_work.c

@@ -47,10 +47,12 @@ lapack_int API_SUFFIX(LAPACKE_dtfsm_work)( int matrix_layout, char transr, char
         }
     } else if( matrix_layout == LAPACK_ROW_MAJOR ) {
         lapack_int ldb_t = MAX(1,m);
+        lapack_int mn = m;
         double* b_t = NULL;
         double* a_t = NULL;
+        if( API_SUFFIX(LAPACKE_lsame)( side, 'r' ) ) mn = n;
         /* Check leading dimension(s) */
-        if( ldb < n ) {
+        if( ldb < m ) {
             info = -12;
             API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dtfsm_work", info );
             return info;
@@ -64,7 +66,7 @@ lapack_int API_SUFFIX(LAPACKE_dtfsm_work)( int matrix_layout, char transr, char
         if( IS_D_NONZERO(alpha) ) {
             a_t = (double*)
                 LAPACKE_malloc( sizeof(double) *
-                                ( MAX(1,n) * MAX(2,n+1) ) / 2 );
+                                ( MAX(1,mn) * MAX(2,mn+1) ) / 2 );
             if( a_t == NULL ) {
                 info = LAPACK_TRANSPOSE_MEMORY_ERROR;
                 goto exit_level_1;
@@ -75,7 +77,7 @@ lapack_int API_SUFFIX(LAPACKE_dtfsm_work)( int matrix_layout, char transr, char
             API_SUFFIX(LAPACKE_dge_trans)( matrix_layout, m, n, b, ldb, b_t, ldb_t );
         }
         if( IS_D_NONZERO(alpha) ) {
-            API_SUFFIX(LAPACKE_dtf_trans)( matrix_layout, transr, uplo, diag, n, a, a_t );
+            API_SUFFIX(LAPACKE_dtf_trans)( matrix_layout, transr, uplo, diag, mn, a, a_t );
         }
         /* Call LAPACK function and adjust info */
         LAPACK_dtfsm( &transr, &side, &uplo, &trans, &diag, &m, &n, &alpha, a_t,

LAPACKE/src/lapacke_dtpmqrt_work.c

@@ -49,8 +49,8 @@ lapack_int API_SUFFIX(LAPACKE_dtpmqrt_work)( int matrix_layout, char side, char
         }
     } else if( matrix_layout == LAPACK_ROW_MAJOR ) {
         lapack_int nrowsA, ncolsA, nrowsV;
-        if      ( side == API_SUFFIX(LAPACKE_lsame)(side, 'l') ) { nrowsA = k; ncolsA = n; nrowsV = m; }
-        else if ( side == API_SUFFIX(LAPACKE_lsame)(side, 'r') ) { nrowsA = m; ncolsA = k; nrowsV = n; }
+        if      ( API_SUFFIX(LAPACKE_lsame)(side, 'l') ) { nrowsA = k; ncolsA = n; nrowsV = m; }
+        else if ( API_SUFFIX(LAPACKE_lsame)(side, 'r') ) { nrowsA = m; ncolsA = k; nrowsV = n; }
         else {
             info = -2;
             API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dtpmqrt_work", info );

LAPACKE/src/lapacke_nancheck.c

@@ -47,7 +47,7 @@ int LAPACKE_get_nancheck( )
     }
 
     /* Check environment variable, once and only once */
-    env = getenv( "API_SUFFIX(LAPACKE_)NANCHECK" );
+    env = getenv( "LAPACKE_NANCHECK" );
     if ( !env ) {
         /* By default, NaN checking is enabled */
         nancheck_flag = 1;

LAPACKE/src/lapacke_stfsm.c

@@ -43,9 +43,11 @@ lapack_int API_SUFFIX(LAPACKE_stfsm)( int matrix_layout, char transr, char side,
     }
 #ifndef LAPACK_DISABLE_NAN_CHECK
     if( LAPACKE_get_nancheck() ) {
+        lapack_int mn = m;
+        if( API_SUFFIX(LAPACKE_lsame)( side, 'r' ) ) mn = n;
         /* Optionally check input matrices for NaNs */
         if( IS_S_NONZERO(alpha) ) {
-            if( API_SUFFIX(LAPACKE_stf_nancheck)( matrix_layout, transr, uplo, diag, n, a ) ) {
+            if( API_SUFFIX(LAPACKE_stf_nancheck)( matrix_layout, transr, uplo, diag, mn, a ) ) {
                 return -10;
             }
         }

LAPACKE/src/lapacke_stfsm_work.c

@@ -47,10 +47,12 @@ lapack_int API_SUFFIX(LAPACKE_stfsm_work)( int matrix_layout, char transr, char
         }
     } else if( matrix_layout == LAPACK_ROW_MAJOR ) {
         lapack_int ldb_t = MAX(1,m);
+        lapack_int mn = MAX(1,m);
         float* b_t = NULL;
         float* a_t = NULL;
+        if( API_SUFFIX(LAPACKE_lsame)( side, 'r' ) ) mn = n;
         /* Check leading dimension(s) */
-        if( ldb < n ) {
+        if( ldb < m ) {
             info = -12;
             API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_stfsm_work", info );
             return info;
@@ -63,7 +65,7 @@ lapack_int API_SUFFIX(LAPACKE_stfsm_work)( int matrix_layout, char transr, char
         }
         if( IS_S_NONZERO(alpha) ) {
             a_t = (float*)
-                LAPACKE_malloc( sizeof(float) * ( MAX(1,n) * MAX(2,n+1) ) / 2 );
+                LAPACKE_malloc( sizeof(float) * ( MAX(1,mn) * MAX(2,mn+1) ) / 2 );
             if( a_t == NULL ) {
                 info = LAPACK_TRANSPOSE_MEMORY_ERROR;
                 goto exit_level_1;
@@ -74,7 +76,7 @@ lapack_int API_SUFFIX(LAPACKE_stfsm_work)( int matrix_layout, char transr, char
             API_SUFFIX(LAPACKE_sge_trans)( matrix_layout, m, n, b, ldb, b_t, ldb_t );
         }
         if( IS_S_NONZERO(alpha) ) {
-            API_SUFFIX(LAPACKE_stf_trans)( matrix_layout, transr, uplo, diag, n, a, a_t );
+            API_SUFFIX(LAPACKE_stf_trans)( matrix_layout, transr, uplo, diag, mn, a, a_t );
         }
         /* Call LAPACK function and adjust info */
         LAPACK_stfsm( &transr, &side, &uplo, &trans, &diag, &m, &n, &alpha, a_t,

LAPACKE/src/lapacke_stpmqrt_work.c

@@ -49,8 +49,8 @@ lapack_int API_SUFFIX(LAPACKE_stpmqrt_work)( int matrix_layout, char side, char
         }
     } else if( matrix_layout == LAPACK_ROW_MAJOR ) {
         lapack_int nrowsA, ncolsA, nrowsV;
-        if      ( side == API_SUFFIX(LAPACKE_lsame)(side, 'l') ) { nrowsA = k; ncolsA = n; nrowsV = m; }
-        else if ( side == API_SUFFIX(LAPACKE_lsame)(side, 'r') ) { nrowsA = m; ncolsA = k; nrowsV = n; }
+        if      ( API_SUFFIX(LAPACKE_lsame)(side, 'l') ) { nrowsA = k; ncolsA = n; nrowsV = m; }
+        else if ( API_SUFFIX(LAPACKE_lsame)(side, 'r') ) { nrowsA = m; ncolsA = k; nrowsV = n; }
         else {
             info = -2;
             API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_stpmqrt_work", info );

LAPACKE/src/lapacke_ztfsm.c

@@ -44,9 +44,11 @@ lapack_int API_SUFFIX(LAPACKE_ztfsm)( int matrix_layout, char transr, char side,
     }
 #ifndef LAPACK_DISABLE_NAN_CHECK
     if( LAPACKE_get_nancheck() ) {
+        lapack_int mn = m;
+        if( API_SUFFIX(LAPACKE_lsame)( side, 'r' ) ) mn = n;
         /* Optionally check input matrices for NaNs */
         if( IS_Z_NONZERO(alpha) ) {
-            if( API_SUFFIX(LAPACKE_ztf_nancheck)( matrix_layout, transr, uplo, diag, n, a ) ) {
+            if( API_SUFFIX(LAPACKE_ztf_nancheck)( matrix_layout, transr, uplo, diag, mn, a ) ) {
                 return -10;
             }
         }

LAPACKE/src/lapacke_ztfsm_work.c

@@ -48,10 +48,12 @@ lapack_int API_SUFFIX(LAPACKE_ztfsm_work)( int matrix_layout, char transr, char
         }
     } else if( matrix_layout == LAPACK_ROW_MAJOR ) {
         lapack_int ldb_t = MAX(1,m);
+        lapack_int mn = m;
         lapack_complex_double* b_t = NULL;
         lapack_complex_double* a_t = NULL;
+        if( API_SUFFIX(LAPACKE_lsame)( side, 'r' ) ) mn = n;
         /* Check leading dimension(s) */
-        if( ldb < n ) {
+        if( ldb < m ) {
             info = -12;
             API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_ztfsm_work", info );
             return info;
@@ -66,7 +68,7 @@ lapack_int API_SUFFIX(LAPACKE_ztfsm_work)( int matrix_layout, char transr, char
         if( IS_Z_NONZERO(alpha) ) {
             a_t = (lapack_complex_double*)
                 LAPACKE_malloc( sizeof(lapack_complex_double) *
-                                ( MAX(1,n) * MAX(2,n+1) ) / 2 );
+                                ( MAX(1,mn) * MAX(2,mn+1) ) / 2 );
             if( a_t == NULL ) {
                 info = LAPACK_TRANSPOSE_MEMORY_ERROR;
                 goto exit_level_1;
@@ -77,7 +79,7 @@ lapack_int API_SUFFIX(LAPACKE_ztfsm_work)( int matrix_layout, char transr, char
             API_SUFFIX(LAPACKE_zge_trans)( matrix_layout, m, n, b, ldb, b_t, ldb_t );
         }
         if( IS_Z_NONZERO(alpha) ) {
-            API_SUFFIX(LAPACKE_ztf_trans)( matrix_layout, transr, uplo, diag, n, a, a_t );
+            API_SUFFIX(LAPACKE_ztf_trans)( matrix_layout, transr, uplo, diag, mn, a, a_t );
         }
         /* Call LAPACK function and adjust info */
         LAPACK_ztfsm( &transr, &side, &uplo, &trans, &diag, &m, &n, &alpha, a_t,

LAPACKE/src/lapacke_ztpmqrt_work.c

@@ -51,8 +51,8 @@ lapack_int API_SUFFIX(LAPACKE_ztpmqrt_work)( int matrix_layout, char side, char
         }
     } else if( matrix_layout == LAPACK_ROW_MAJOR ) {
         lapack_int nrowsA, ncolsA, nrowsV;
-        if      ( side == API_SUFFIX(LAPACKE_lsame)(side, 'l') ) { nrowsA = k; ncolsA = n; nrowsV = m; }
-        else if ( side == API_SUFFIX(LAPACKE_lsame)(side, 'r') ) { nrowsA = m; ncolsA = k; nrowsV = n; }
+        if      ( API_SUFFIX(LAPACKE_lsame)(side, 'l') ) { nrowsA = k; ncolsA = n; nrowsV = m; }
+        else if ( API_SUFFIX(LAPACKE_lsame)(side, 'r') ) { nrowsA = m; ncolsA = k; nrowsV = n; }
         else {
             info = -2;
             API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_ztpmqrt_work", info );

LAPACKE/utils/lapacke_lsame.c

@@ -34,7 +34,7 @@
 
 lapack_logical API_SUFFIX(LAPACKE_lsame)( char ca,  char cb )
 {
-    return (lapack_logical) LAPACK_lsame( &ca, &cb, 1, 1 );
+    return (lapack_logical) LAPACK_lsame( &ca, &cb );
 }
 
 

README.md

@@ -79,7 +79,7 @@ CBLAS, a C interface to the BLAS, and (5) LAPACKE, a C interface to LAPACK.
    ```sh
    mkdir build
    cd build
-   cmake -DCMAKE_INSTALL_LIBDIR=$HOME/.local/lapack ..
+   cmake -DCMAKE_INSTALL_PREFIX=$HOME/.local/lapack ..
    cmake --build . -j --target install
    ```
  - LAPACK can be built and installed using [vcpkg](https://github.com/Microsoft/vcpkg/) dependency manager:

SRC/CMakeLists.txt

@@ -106,7 +106,7 @@ set(SLASRC
    slaqgb.f slaqge.f slaqp2.f slaqps.f slaqp2rk.f slaqp3rk.f slaqsb.f slaqsp.f slaqsy.f
    slaqr0.f slaqr1.f slaqr2.f slaqr3.f slaqr4.f slaqr5.f
    slaqtr.f slar1v.f slar2v.f ilaslr.f ilaslc.f
-   slarf.f  slarfb.f slarfb_gett.f slarfg.f slarfgp.f slarft.f slarfx.f slarfy.f
+   slarf.f  slarf1f.f slarf1l.f slarfb.f slarfb_gett.f slarfg.f slarfgp.f slarft.f slarfx.f slarfy.f
    slargv.f slarmm.f slarrv.f slartv.f
    slarz.f  slarzb.f slarzt.f slasy2.f
    slasyf.f slasyf_rook.f slasyf_rk.f slasyf_aa.f
@@ -218,7 +218,7 @@ set(CLASRC
    claqhb.f claqhe.f claqhp.f claqp2.f claqps.f claqp2rk.f claqp3rk.f claqsb.f
    claqr0.f claqr1.f claqr2.f claqr3.f claqr4.f claqr5.f
    claqsp.f claqsy.f clar1v.f clar2v.f ilaclr.f ilaclc.f
-   clarf.f  clarfb.f clarfb_gett.f clarfg.f clarfgp.f clarft.f
+   clarf.f  clarf1f.f clarf1l.f clarfb.f clarfb_gett.f clarfg.f clarfgp.f clarft.f
    clarfx.f clarfy.f clargv.f clarnv.f clarrv.f clartg.f90 clartv.f
    clarz.f  clarzb.f clarzt.f clascl.f claset.f clasr.f  classq.f90
    claswp.f clasyf.f clasyf_rook.f clasyf_rk.f clasyf_aa.f
@@ -307,7 +307,7 @@ set(DLASRC
    dlaqgb.f dlaqge.f dlaqp2.f dlaqps.f dlaqp2rk.f dlaqp3rk.f dlaqsb.f dlaqsp.f dlaqsy.f
    dlaqr0.f dlaqr1.f dlaqr2.f dlaqr3.f dlaqr4.f dlaqr5.f
    dlaqtr.f dlar1v.f dlar2v.f iladlr.f iladlc.f
-   dlarf.f  dlarfb.f dlarfb_gett.f dlarfg.f dlarfgp.f dlarft.f dlarfx.f dlarfy.f
+   dlarf.f  dlarfb.f dlarfb_gett.f dlarfg.f dlarfgp.f dlarft.f dlarfx.f dlarfy.f dlarf1f.f dlarf1l.f
    dlargv.f dlarmm.f dlarrv.f dlartv.f
    dlarz.f  dlarzb.f dlarzt.f dlaswp.f dlasy2.f
    dlasyf.f dlasyf_rook.f dlasyf_rk.f dlasyf_aa.f
@@ -418,7 +418,7 @@ set(ZLASRC
    zlaqhb.f zlaqhe.f zlaqhp.f zlaqp2.f zlaqps.f zlaqp2rk.f zlaqp3rk.f zlaqsb.f
    zlaqr0.f zlaqr1.f zlaqr2.f zlaqr3.f zlaqr4.f zlaqr5.f
    zlaqsp.f zlaqsy.f zlar1v.f zlar2v.f ilazlr.f ilazlc.f
-   zlarcm.f zlarf.f  zlarfb.f zlarfb_gett.f
+   zlarcm.f zlarf.f  zlarfb.f zlarfb_gett.f zlarf1f.f zlarf1l.f
    zlarfg.f zlarfgp.f zlarft.f
    zlarfx.f zlarfy.f zlargv.f zlarnv.f zlarrv.f zlartg.f90 zlartv.f
    zlarz.f  zlarzb.f zlarzt.f zlascl.f zlaset.f zlasr.f
@@ -541,6 +541,7 @@ if(BUILD_INDEX64_EXT_API)
     set(BUILD_INDEX64_EXT_API OFF)
     set(BUILD_INDEX64_EXT_API OFF PARENT_SCOPE)
   else()
+    cmake_minimum_required(VERSION 3.18)
     set(SOURCES_64)
     file(MAKE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/${LAPACKLIB}_64_obj)
     file(COPY ${SOURCES} DESTINATION ${CMAKE_CURRENT_BINARY_DIR}/${LAPACKLIB}_64_obj)

SRC/Makefile

@@ -137,7 +137,7 @@ SLASRC = \
    slaqgb.o slaqge.o slaqp2.o slaqps.o slaqp2rk.o slaqp3rk.o slaqsb.o slaqsp.o slaqsy.o \
    slaqr0.o slaqr1.o slaqr2.o slaqr3.o slaqr4.o slaqr5.o \
    slaqtr.o slar1v.o slar2v.o ilaslr.o ilaslc.o \
-   slarf.o  slarfb.o slarfb_gett.o slarfg.o slarfgp.o slarft.o slarfx.o slarfy.o \
+   slarf.o  slarf1f.o slarf1l.o slarfb.o slarfb_gett.o slarfg.o slarfgp.o slarft.o slarfx.o slarfy.o \
    slargv.o slarmm.o slarrv.o slartv.o \
    slarz.o  slarzb.o slarzt.o slaswp.o slasy2.o slasyf.o slasyf_rook.o \
    slasyf_rk.o \
@@ -249,7 +249,7 @@ CLASRC = \
    claqhb.o claqhe.o claqhp.o claqp2.o claqps.o claqp2rk.o claqp3rk.o claqsb.o \
    claqr0.o claqr1.o claqr2.o claqr3.o claqr4.o claqr5.o \
    claqsp.o claqsy.o clar1v.o clar2v.o ilaclr.o ilaclc.o \
-   clarf.o  clarfb.o clarfb_gett.o clarfg.o clarft.o clarfgp.o \
+   clarf.o  clarf1f.o clarf1l.o clarfb.o clarfb_gett.o clarfg.o clarft.o clarfgp.o \
    clarfx.o clarfy.o clargv.o clarnv.o clarrv.o clartg.o clartv.o \
    clarz.o  clarzb.o clarzt.o clascl.o claset.o clasr.o  classq.o \
    claswp.o clasyf.o clasyf_rook.o clasyf_rk.o clasyf_aa.o \
@@ -339,7 +339,7 @@ DLASRC = \
    dlaqgb.o dlaqge.o dlaqp2.o dlaqps.o dlaqp2rk.o dlaqp3rk.o dlaqsb.o dlaqsp.o dlaqsy.o \
    dlaqr0.o dlaqr1.o dlaqr2.o dlaqr3.o dlaqr4.o dlaqr5.o \
    dlaqtr.o dlar1v.o dlar2v.o iladlr.o iladlc.o \
-   dlarf.o  dlarfb.o dlarfb_gett.o dlarfg.o dlarfgp.o dlarft.o dlarfx.o dlarfy.o \
+   dlarf.o  dlarfb.o dlarfb_gett.o dlarfg.o dlarfgp.o dlarft.o dlarfx.o dlarfy.o dlarf1f.o dlarf1l.o\
    dlargv.o dlarmm.o dlarrv.o dlartv.o \
    dlarz.o  dlarzb.o dlarzt.o dlaswp.o dlasy2.o \
    dlasyf.o dlasyf_rook.o dlasyf_rk.o \
@@ -453,7 +453,7 @@ ZLASRC = \
    zlaqhb.o zlaqhe.o zlaqhp.o zlaqp2.o zlaqps.o zlaqp2rk.o zlaqp3rk.o zlaqsb.o \
    zlaqr0.o zlaqr1.o zlaqr2.o zlaqr3.o zlaqr4.o zlaqr5.o \
    zlaqsp.o zlaqsy.o zlar1v.o zlar2v.o ilazlr.o ilazlc.o \
-   zlarcm.o zlarf.o  zlarfb.o zlarfb_gett.o \
+   zlarcm.o zlarf.o  zlarfb.o zlarfb_gett.o zlarf1f.o zlarf1l.o \
    zlarfg.o zlarft.o zlarfgp.o \
    zlarfx.o zlarfy.o zlargv.o zlarnv.o zlarrv.o zlartg.o zlartv.o \
    zlarz.o  zlarzb.o zlarzt.o zlascl.o zlaset.o zlasr.o \

SRC/cbdsqr.f

@@ -166,7 +166,9 @@
 *>
 *> \param[out] RWORK
 *> \verbatim
-*>          RWORK is REAL array, dimension (4*(N-1))
+*>          RWORK is REAL array, dimension (LRWORK)
+*>          LRWORK = 4*N, if NCVT = NRU = NCC = 0, and
+*>          LRWORK = 4*(N-1), otherwise
 *> \endverbatim
 *>
 *> \param[out] INFO

SRC/cgebd2.f

@@ -203,16 +203,15 @@
 *  =====================================================================
 *
 *     .. Parameters ..
-      COMPLEX            ZERO, ONE
-      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ),
-     $                   ONE = ( 1.0E+0, 0.0E+0 ) )
+      COMPLEX            ZERO
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ) )
 *     ..
 *     .. Local Scalars ..
       INTEGER            I
       COMPLEX            ALPHA
 *     ..
 *     .. External Subroutines ..
-      EXTERNAL           CLACGV, CLARF, CLARFG, XERBLA
+      EXTERNAL           CLACGV, CLARF1F, CLARFG, XERBLA
 *     ..
 *     .. Intrinsic Functions ..
       INTRINSIC          CONJG, MAX, MIN
@@ -246,13 +245,13 @@
             CALL CLARFG( M-I+1, ALPHA, A( MIN( I+1, M ), I ), 1,
      $                   TAUQ( I ) )
             D( I ) = REAL( ALPHA )
-            A( I, I ) = ONE
 *
 *           Apply H(i)**H to A(i:m,i+1:n) from the left
 *
             IF( I.LT.N )
-     $         CALL CLARF( 'Left', M-I+1, N-I, A( I, I ), 1,
-     $                     CONJG( TAUQ( I ) ), A( I, I+1 ), LDA, WORK )
+     $         CALL CLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1,
+     $                       CONJG( TAUQ( I ) ), A( I, I+1 ), LDA,
+     $                       WORK )
             A( I, I ) = D( I )
 *
             IF( I.LT.N ) THEN
@@ -265,12 +264,11 @@
                CALL CLARFG( N-I, ALPHA, A( I, MIN( I+2, N ) ),
      $                      LDA, TAUP( I ) )
                E( I ) = REAL( ALPHA )
-               A( I, I+1 ) = ONE
 *
 *              Apply G(i) to A(i+1:m,i+1:n) from the right
 *
-               CALL CLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA,
-     $                     TAUP( I ), A( I+1, I+1 ), LDA, WORK )
+               CALL CLARF1F( 'Right', M-I, N-I, A( I, I+1 ), LDA,
+     $                       TAUP( I ), A( I+1, I+1 ), LDA, WORK )
                CALL CLACGV( N-I, A( I, I+1 ), LDA )
                A( I, I+1 ) = E( I )
             ELSE
@@ -290,13 +288,12 @@
             CALL CLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA,
      $                   TAUP( I ) )
             D( I ) = REAL( ALPHA )
-            A( I, I ) = ONE
 *
 *           Apply G(i) to A(i+1:m,i:n) from the right
 *
             IF( I.LT.M )
-     $         CALL CLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
-     $                     TAUP( I ), A( I+1, I ), LDA, WORK )
+     $         CALL CLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA,
+     $                       TAUP( I ), A( I+1, I ), LDA, WORK )
             CALL CLACGV( N-I+1, A( I, I ), LDA )
             A( I, I ) = D( I )
 *
@@ -309,13 +306,12 @@
                CALL CLARFG( M-I, ALPHA, A( MIN( I+2, M ), I ), 1,
      $                      TAUQ( I ) )
                E( I ) = REAL( ALPHA )
-               A( I+1, I ) = ONE
 *
 *              Apply H(i)**H to A(i+1:m,i+1:n) from the left
 *
-               CALL CLARF( 'Left', M-I, N-I, A( I+1, I ), 1,
-     $                     CONJG( TAUQ( I ) ), A( I+1, I+1 ), LDA,
-     $                     WORK )
+               CALL CLARF1F( 'Left', M-I, N-I, A( I+1, I ), 1,
+     $                       CONJG( TAUQ( I ) ), A( I+1, I+1 ), LDA,
+     $                       WORK )
                A( I+1, I ) = E( I )
             ELSE
                TAUQ( I ) = ZERO

SRC/cgedmd.f90

@@ -11,7 +11,7 @@
 !                        W, LDW,  S, LDS, ZWORK,  LZWORK,   &
 !                        RWORK, LRWORK, IWORK, LIWORK, INFO )
 !.....
-!     USE                   iso_fortran_env
+!     USE, INTRINSIC :: iso_fortran_env, only: real32
 !     IMPLICIT NONE
 !     INTEGER, PARAMETER :: WP = real32
 !
@@ -506,7 +506,7 @@
 !  -- Colorado Denver and NAG Ltd..                                   --
 !
 !.....
-      USE                   iso_fortran_env
+      USE, INTRINSIC :: iso_fortran_env, only: real32
       IMPLICIT NONE
       INTEGER, PARAMETER :: WP = real32
 !

SRC/cgedmdq.f90

@@ -12,7 +12,7 @@
 !                   S, LDS, ZWORK, LZWORK, WORK,  LWORK,   &
 !                   IWORK, LIWORK, INFO )
 !.....
-!     USE                   iso_fortran_env
+!     USE, INTRINSIC :: iso_fortran_env, only: real32
 !     IMPLICIT NONE
 !     INTEGER, PARAMETER :: WP = real32
 !.....
@@ -563,7 +563,7 @@ SUBROUTINE CGEDMDQ( JOBS,  JOBZ, JOBR, JOBQ, JOBT, JOBF,   &
 !  -- Colorado Denver and NAG Ltd..                                   --
 !
 !.....
-      USE                   iso_fortran_env
+      USE, INTRINSIC :: iso_fortran_env, only: real32
       IMPLICIT NONE
       INTEGER, PARAMETER :: WP = real32
 !

SRC/cgehd2.f

@@ -160,16 +160,11 @@
 *
 *  =====================================================================
 *
-*     .. Parameters ..
-      COMPLEX            ONE
-      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
-*     ..
 *     .. Local Scalars ..
       INTEGER            I
-      COMPLEX            ALPHA
 *     ..
 *     .. External Subroutines ..
-      EXTERNAL           CLARF, CLARFG, XERBLA
+      EXTERNAL           CLARF1F, CLARFG, XERBLA
 *     ..
 *     .. Intrinsic Functions ..
       INTRINSIC          CONJG, MAX, MIN
@@ -197,22 +192,19 @@
 *
 *        Compute elementary reflector H(i) to annihilate A(i+2:ihi,i)
 *
-         ALPHA = A( I+1, I )
-         CALL CLARFG( IHI-I, ALPHA, A( MIN( I+2, N ), I ), 1,
+         CALL CLARFG( IHI-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1,
      $                TAU( I ) )
-         A( I+1, I ) = ONE
 *
 *        Apply H(i) to A(1:ihi,i+1:ihi) from the right
 *
-         CALL CLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ),
-     $               A( 1, I+1 ), LDA, WORK )
+         CALL CLARF1F( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ),
+     $                 A( 1, I+1 ), LDA, WORK )
 *
 *        Apply H(i)**H to A(i+1:ihi,i+1:n) from the left
 *
-         CALL CLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1,
-     $               CONJG( TAU( I ) ), A( I+1, I+1 ), LDA, WORK )
+         CALL CLARF1F( 'Left', IHI-I, N-I, A( I+1, I ), 1,
+     $                 CONJG( TAU( I ) ), A( I+1, I+1 ), LDA, WORK )
 *
-         A( I+1, I ) = ALPHA
    10 CONTINUE
 *
       RETURN

SRC/cgehrd.f

@@ -232,7 +232,7 @@
          IF( NH.LE.1 ) THEN
             LWKOPT = 1
          ELSE
-            NB = MIN( NBMAX, ILAENV( 1, 'DGEHRD', ' ', N, ILO, IHI,
+            NB = MIN( NBMAX, ILAENV( 1, 'CGEHRD', ' ', N, ILO, IHI,
      $                              -1 ) )
             LWKOPT = N*NB + TSIZE
          END IF

SRC/cgelq2.f

@@ -140,16 +140,11 @@
 *
 *  =====================================================================
 *
-*     .. Parameters ..
-      COMPLEX            ONE
-      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
-*     ..
 *     .. Local Scalars ..
       INTEGER            I, K
-      COMPLEX            ALPHA
 *     ..
 *     .. External Subroutines ..
-      EXTERNAL           CLACGV, CLARF, CLARFG, XERBLA
+      EXTERNAL           CLACGV, CLARF1F, CLARFG, XERBLA
 *     ..
 *     .. Intrinsic Functions ..
       INTRINSIC          MAX, MIN
@@ -178,19 +173,15 @@
 *        Generate elementary reflector H(i) to annihilate A(i,i+1:n)
 *
          CALL CLACGV( N-I+1, A( I, I ), LDA )
-         ALPHA = A( I, I )
-         CALL CLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA,
+         CALL CLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA,
      $                TAU( I ) )
          IF( I.LT.M ) THEN
 *
 *           Apply H(i) to A(i+1:m,i:n) from the right
 *
-            A( I, I ) = ONE
-            CALL CLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
-     $                  TAU( I ),
-     $                  A( I+1, I ), LDA, WORK )
+            CALL CLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA,
+     $                    TAU( I ), A( I+1, I ), LDA, WORK )
          END IF
-         A( I, I ) = ALPHA
          CALL CLACGV( N-I+1, A( I, I ), LDA )
    10 CONTINUE
       RETURN

SRC/cgels.f

@@ -37,7 +37,17 @@
 *>
 *> CGELS solves overdetermined or underdetermined complex linear systems
 *> involving an M-by-N matrix A, or its conjugate-transpose, using a QR
-*> or LQ factorization of A.  It is assumed that A has full rank.
+*> or LQ factorization of A.
+*>
+*> It is assumed that A has full rank, and only a rudimentary protection
+*> against rank-deficient matrices is provided. This subroutine only detects
+*> exact rank-deficiency, where a diagonal element of the triangular factor
+*> of A is exactly zero.
+*>
+*> It is conceivable for one (or more) of the diagonal elements of the triangular
+*> factor of A to be subnormally tiny numbers without this subroutine signalling
+*> an error. The solutions computed for such almost-rank-deficient matrices may
+*> be less accurate due to a loss of numerical precision.
 *>
 *> The following options are provided:
 *>
@@ -161,7 +171,7 @@
 *>          = 0:  successful exit
 *>          < 0:  if INFO = -i, the i-th argument had an illegal value
 *>          > 0:  if INFO =  i, the i-th diagonal element of the
-*>                triangular factor of A is zero, so that A does not have
+*>                triangular factor of A is exactly zero, so that A does not have
 *>                full rank; the least squares solution could not be
 *>                computed.
 *> \endverbatim

SRC/cgelst.f

@@ -38,7 +38,16 @@
 *> CGELST solves overdetermined or underdetermined real linear systems
 *> involving an M-by-N matrix A, or its conjugate-transpose, using a QR
 *> or LQ factorization of A with compact WY representation of Q.
-*> It is assumed that A has full rank.
+*>
+*> It is assumed that A has full rank, and only a rudimentary protection
+*> against rank-deficient matrices is provided. This subroutine only detects
+*> exact rank-deficiency, where a diagonal element of the triangular factor
+*> of A is exactly zero.
+*>
+*> It is conceivable for one (or more) of the diagonal elements of the triangular
+*> factor of A to be subnormally tiny numbers without this subroutine signalling
+*> an error. The solutions computed for such almost-rank-deficient matrices may
+*> be less accurate due to a loss of numerical precision.
 *>
 *> The following options are provided:
 *>
@@ -163,7 +172,7 @@
 *>          = 0:  successful exit
 *>          < 0:  if INFO = -i, the i-th argument had an illegal value
 *>          > 0:  if INFO =  i, the i-th diagonal element of the
-*>                triangular factor of A is zero, so that A does not have
+*>                triangular factor of A is exactly zero, so that A does not have
 *>                full rank; the least squares solution could not be
 *>                computed.
 *> \endverbatim