schk4()

subroutine schk4	(	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 1432 of file c_sblat3.f.

*
*  Tests SSYRK.
*
*  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 ..
      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, BETS, ERR, ERRMAX
      INTEGER            I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS,
     $                   LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA,
     $                   NARGS, NC, NS
      LOGICAL            NULL, RESET, SAME, TRAN, UPPER
      CHARACTER*1        TRANS, TRANSS, UPLO, UPLOS
      CHARACTER*2        ICHU
      CHARACTER*3        ICHT
*     .. Local Arrays ..
      LOGICAL            ISAME( 13 )
*     .. External Functions ..
      LOGICAL            LSE, LSERES
      EXTERNAL           lse, lseres
*     .. External Subroutines ..
      EXTERNAL           smake, smmch, cssyrk
*     .. Intrinsic Functions ..
      INTRINSIC          max
*     .. Scalars in Common ..
      INTEGER            INFOT, NOUTC
      LOGICAL            OK
*     .. Common blocks ..
      COMMON             /infoc/infot, noutc, ok
*     .. Data statements ..
      DATA               icht/'NTC'/, ichu/'UL'/
*     .. Executable Statements ..
*
      nargs = 10
      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 ict = 1, 3
               trans = icht( ict: ict )
               tran = trans.EQ.'T'.OR.trans.EQ.'C'
               IF( tran )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 icu = 1, 2
                  uplo = ichu( icu: icu )
                  upper = uplo.EQ.'U'
*
                  DO 60 ia = 1, nalf
                     alpha = alf( ia )
*
                     DO 50 ib = 1, nbet
                        beta = bet( ib )
*
*                       Generate the matrix C.
*
                        CALL smake( 'SY', uplo, ' ', n, n, c, nmax, cc,
     $                              ldc, reset, zero )
*
                        nc = nc + 1
*
*                       Save every datum before calling the subroutine.
*
                        uplos = uplo
                        transs = trans
                        ns = n
                        ks = k
                        als = alpha
                        DO 10 i = 1, laa
                           as( i ) = aa( i )
   10                   CONTINUE
                        ldas = lda
                        bets = beta
                        DO 20 i = 1, lcc
                           cs( i ) = cc( i )
   20                   CONTINUE
                        ldcs = ldc
*
*                       Call the subroutine.
*
                        IF( trace )
     $                     CALL sprcn4( ntra, nc, sname, iorder, uplo,
     $                     trans, n, k, alpha, lda, beta, ldc)
                        IF( rewi )
     $                     rewind ntra
                        CALL cssyrk( iorder, uplo, trans, n, k, alpha,
     $                              aa, lda, beta, cc, ldc )
*
*                       Check if error-exit was taken incorrectly.
*
                        IF( .NOT.ok )THEN
                           WRITE( nout, fmt = 9993 )
                           fatal = .true.
                           GO TO 120
                        END IF
*
*                       See what data changed inside subroutines.
*
                        isame( 1 ) = uplos.EQ.uplo
                        isame( 2 ) = transs.EQ.trans
                        isame( 3 ) = ns.EQ.n
                        isame( 4 ) = ks.EQ.k
                        isame( 5 ) = als.EQ.alpha
                        isame( 6 ) = lse( as, aa, laa )
                        isame( 7 ) = ldas.EQ.lda
                        isame( 8 ) = bets.EQ.beta
                        IF( null )THEN
                           isame( 9 ) = lse( cs, cc, lcc )
                        ELSE
                           isame( 9 ) = lseres( 'SY', uplo, n, n, cs,
     $                                  cc, ldc )
                        END IF
                        isame( 10 ) = ldcs.EQ.ldc
*
*                       If data was incorrectly changed, report and
*                       return.
*
                        same = .true.
                        DO 30 i = 1, nargs
                           same = same.AND.isame( i )
                           IF( .NOT.isame( i ) )
     $                        WRITE( nout, fmt = 9998 )i+1
   30                   CONTINUE
                        IF( .NOT.same )THEN
                           fatal = .true.
                           GO TO 120
                        END IF
*
                        IF( .NOT.null )THEN
*
*                          Check the result column by column.
*
                           jc = 1
                           DO 40 j = 1, n
                              IF( upper )THEN
                                 jj = 1
                                 lj = j
                              ELSE
                                 jj = j
                                 lj = n - j + 1
                              END IF
                              IF( tran )THEN
                                 CALL smmch( 'T', 'N', lj, 1, k, alpha,
     $                                       a( 1, jj ), nmax,
     $                                       a( 1, j ), nmax, beta,
     $                                       c( jj, j ), nmax, ct, g,
     $                                       cc( jc ), ldc, eps, err,
     $                                       fatal, nout, .true. )
                              ELSE
                                 CALL smmch( 'N', 'T', lj, 1, k, alpha,
     $                                       a( jj, 1 ), nmax,
     $                                       a( j, 1 ), nmax, beta,
     $                                       c( jj, j ), nmax, ct, g,
     $                                       cc( jc ), ldc, eps, err,
     $                                       fatal, nout, .true. )
                              END IF
                              IF( upper )THEN
                                 jc = jc + ldc
                              ELSE
                                 jc = jc + ldc + 1
                              END IF
                              errmax = max( errmax, err )
*                             If got really bad answer, report and
*                             return.
                              IF( fatal )
     $                           GO TO 110
   40                      CONTINUE
                        END IF
*
   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
*
  110 CONTINUE
      IF( n.GT.1 )
     $   WRITE( nout, fmt = 9995 )j
*
  120 CONTINUE
      WRITE( nout, fmt = 9996 )sname
      CALL sprcn4( nout, nc, sname, iorder, uplo, trans, n, k, alpha,
     $   lda, 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( '      THESE ARE THE RESULTS FOR COLUMN ', 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 *',
     $      '******' )
*
*     End of SCHK4.
*

Here is the call graph for this function: