schk6()

subroutine schk6	(	character*13	sname,
		real	eps,
		real	thresh,
		integer	nout,
		integer	ntra,
		logical	trace,
		logical	rewi,
		logical	fatal,
		integer	nidim,
		integer, dimension( nidim )	idim,
		integer	nalf,
		real, dimension( nalf )	alf,
		integer	nbet,
		real, dimension( nbet )	bet,
		integer	nmax,
		real, dimension( nmax, nmax )	a,
		real, dimension( nmax*nmax )	aa,
		real, dimension( nmax*nmax )	as,
		real, dimension( nmax, nmax )	b,
		real, dimension( nmax*nmax )	bb,
		real, dimension( nmax*nmax )	bs,
		real, dimension( nmax, nmax )	c,
		real, dimension( nmax*nmax )	cc,
		real, dimension( nmax*nmax )	cs,
		real, dimension( nmax )	ct,
		real, dimension( nmax )	g,
		integer	iorder )

Definition at line 2501 of file c_sblat3.f.

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

Here is the call graph for this function: