dmmtch()

subroutine dmmtch	(	character*1	uplo,
		character*1	transa,
		character*1	transb,
		integer	n,
		integer	kk,
		double precision	alpha,
		double precision, dimension( lda, * )	a,
		integer	lda,
		double precision, dimension( ldb, * )	b,
		integer	ldb,
		double precision	beta,
		double precision, dimension( ldc, * )	c,
		integer	ldc,
		double precision, dimension( * )	ct,
		double precision, dimension( * )	g,
		double precision, dimension( ldcc, * )	cc,
		integer	ldcc,
		double precision	eps,
		double precision	err,
		logical	fatal,
		integer	nout,
		logical	mv )

Definition at line 3242 of file dblat3.f.

*
*  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
*

Here is the caller graph for this function: