cchk1()

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

Definition at line 425 of file c_cblat3.f.

*
*  Tests CGEMM.
*
*  Auxiliary routine for test program for Level 3 Blas.
*
*  -- Written on 8-February-1989.
*     Jack Dongarra, Argonne National Laboratory.
*     Iain Duff, AERE Harwell.
*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
*     Sven Hammarling, Numerical Algorithms Group Ltd.
*
*     .. Parameters ..
      COMPLEX            ZERO
      parameter( zero = ( 0.0, 0.0 ) )
      REAL               RZERO
      parameter( rzero = 0.0 )
*     .. Scalar Arguments ..
      REAL               EPS, THRESH
      INTEGER            NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
      LOGICAL            FATAL, REWI, TRACE
      CHARACTER*12       SNAME
*     .. Array Arguments ..
      COMPLEX            A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
     $                   AS( NMAX*NMAX ), B( NMAX, NMAX ),
     $                   BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
     $                   C( NMAX, NMAX ), CC( NMAX*NMAX ),
     $                   CS( NMAX*NMAX ), CT( NMAX )
      REAL               G( NMAX )
      INTEGER            IDIM( NIDIM )
*     .. Local Scalars ..
      COMPLEX            ALPHA, ALS, BETA, BLS
      REAL               ERR, ERRMAX
      INTEGER            I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA,
     $                   LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M,
     $                   MA, MB, MS, N, NA, NARGS, NB, NC, NS
      LOGICAL            NULL, RESET, SAME, TRANA, TRANB
      CHARACTER*1        TRANAS, TRANBS, TRANSA, TRANSB
      CHARACTER*3        ICH
*     .. Local Arrays ..
      LOGICAL            ISAME( 13 )
*     .. External Functions ..
      LOGICAL            LCE, LCERES
      EXTERNAL           lce, lceres
*     .. External Subroutines ..
      EXTERNAL           ccgemm, cmake, cmmch
*     .. Intrinsic Functions ..
      INTRINSIC          max
*     .. Scalars in Common ..
      INTEGER            INFOT, NOUTC
      LOGICAL            LERR, OK
*     .. Common blocks ..
      COMMON             /infoc/infot, noutc, ok, lerr
*     .. Data statements ..
      DATA               ich/'NTC'/
*     .. Executable Statements ..
*
      nargs = 13
      nc = 0
      reset = .true.
      errmax = rzero
*
      DO 110 im = 1, nidim
         m = idim( im )
*
         DO 100 in = 1, nidim
            n = idim( in )
*           Set LDC to 1 more than minimum value if room.
            ldc = m
            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.OR.m.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 = m
                  ELSE
                     ma = m
                     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 )
*
*                          Generate the matrix C.
*
                           CALL cmake( 'ge', ' ', ' ', m, n, c, nmax,
     $                                 cc, ldc, reset, zero )
*
                           nc = nc + 1
*
*                          Save every datum before calling the
*                          subroutine.
*
                           tranas = transa
                           tranbs = transb
                           ms = m
                           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 cprcn1(ntra, nc, sname, iorder,
     $                        transa, transb, m, n, k, alpha, lda,
     $                        ldb, beta, ldc)
                           IF( rewi )
     $                        rewind ntra
                           CALL ccgemm( iorder, transa, transb, m, 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 ) = transa.EQ.tranas
                           isame( 2 ) = transb.EQ.tranbs
                           isame( 3 ) = ms.EQ.m
                           isame( 4 ) = ns.EQ.n
                           isame( 5 ) = ks.EQ.k
                           isame( 6 ) = als.EQ.alpha
                           isame( 7 ) = lce( as, aa, laa )
                           isame( 8 ) = ldas.EQ.lda
                           isame( 9 ) = lce( bs, bb, lbb )
                           isame( 10 ) = ldbs.EQ.ldb
                           isame( 11 ) = bls.EQ.beta
                           IF( null )THEN
                              isame( 12 ) = lce( cs, cc, lcc )
                           ELSE
                             isame( 12 ) = lceres( 'ge', ' ', m, n, cs,
     $                                      cc, ldc )
                           END IF
                           isame( 13 ) = ldcs.EQ.ldc
*
*                          If data was incorrectly changed, report
*                          and return.
*
                           same = .true.
                           DO 40 i = 1, nargs
                              same = same.AND.isame( i )
                              IF( .NOT.isame( i ) )
     $                           WRITE( nout, fmt = 9998 )i
   40                      CONTINUE
                           IF( .NOT.same )THEN
                              fatal = .true.
                              GO TO 120
                           END IF
*
                           IF( .NOT.null )THEN
*
*                             Check the result.
*
                             CALL cmmch( transa, transb, m, 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
*
   50                   CONTINUE
*
   60                CONTINUE
*
   70             CONTINUE
*
   80          CONTINUE
*
   90       CONTINUE
*
  100    CONTINUE
*
  110 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 cprcn1(nout, nc, sname, iorder, transa, transb,
     $           m, n, k, alpha, lda, ldb, beta, ldc)
*
  130 CONTINUE
      RETURN
*
10003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR    COMPUTATIONAL ',
     $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
     $ 'RATIO ', f8.2, ' - SUSPECT *******' )
10002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
     $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
     $ 'RATIO ', f8.2, ' - SUSPECT *******' )
10001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR    COMPUTATIONAL TESTS',
     $ ' (', i6, ' CALL', 'S)' )
10000 FORMAT( ' ', a12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
     $ ' (', i6, ' CALL', 'S)' )
 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
     $      'ANGED INCORRECTLY *******' )
 9996 FORMAT( ' ******* ', a12,' FAILED ON CALL NUMBER:' )
 9995 FORMAT( 1x, i6, ': ', a12,'(''', a1, ''',''', a1, ''',',
     $     3( i3, ',' ), '(', f4.1, ',', f4.1, '), A,', i3, ', B,', i3,
     $     ',(', f4.1, ',', f4.1, '), C,', i3, ').' )
 9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
     $      '******' )
*
*     End of CCHK1.
*

Here is the call graph for this function: