schk5()

subroutine schk5	(	character*6	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	ninc,
		integer, dimension( ninc )	inc,
		integer	nmax,
		integer	incmax,
		real, dimension( nmax, nmax )	a,
		real, dimension( nmax*nmax )	aa,
		real, dimension( nmax*nmax )	as,
		real, dimension( nmax )	x,
		real, dimension( nmax*incmax )	xx,
		real, dimension( nmax*incmax )	xs,
		real, dimension( nmax )	y,
		real, dimension( nmax*incmax )	yy,
		real, dimension( nmax*incmax )	ys,
		real, dimension( nmax )	yt,
		real, dimension( nmax )	g,
		real, dimension( nmax )	z
	)

Definition at line 1757 of file sblat2.f.

*
*  Tests SSYR and SSPR.
*
*  Auxiliary routine for test program for Level 2 Blas.
*
*  -- Written on 10-August-1987.
*     Richard Hanson, Sandia National Labs.
*     Jeremy Du Croz, NAG Central Office.
*
*     .. Parameters ..
      REAL               ZERO, HALF, ONE
      parameter( zero = 0.0, half = 0.5, one = 1.0 )
*     .. Scalar Arguments ..
      REAL               EPS, THRESH
      INTEGER            INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
      LOGICAL            FATAL, REWI, TRACE
      CHARACTER*6        SNAME
*     .. Array Arguments ..
      REAL               A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
     $                   AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
     $                   XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
     $                   Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
     $                   YY( NMAX*INCMAX ), Z( NMAX )
      INTEGER            IDIM( NIDIM ), INC( NINC )
*     .. Local Scalars ..
      REAL               ALPHA, ALS, ERR, ERRMAX, TRANSL
      INTEGER            I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA,
     $                   LDA, LDAS, LJ, LX, N, NARGS, NC, NS
      LOGICAL            FULL, NULL, PACKED, RESET, SAME, UPPER
      CHARACTER*1        UPLO, UPLOS
      CHARACTER*2        ICH
*     .. Local Arrays ..
      REAL               W( 1 )
      LOGICAL            ISAME( 13 )
*     .. External Functions ..
      LOGICAL            LSE, LSERES
      EXTERNAL           lse, lseres
*     .. External Subroutines ..
      EXTERNAL           smake, smvch, sspr, ssyr
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max
*     .. Scalars in Common ..
      INTEGER            INFOT, NOUTC
      LOGICAL            LERR, OK
*     .. Common blocks ..
      COMMON             /infoc/infot, noutc, ok, lerr
*     .. Data statements ..
      DATA               ich/'UL'/
*     .. Executable Statements ..
      full = sname( 3: 3 ).EQ.'Y'
      packed = sname( 3: 3 ).EQ.'P'
*     Define the number of arguments.
      IF( full )THEN
         nargs = 7
      ELSE IF( packed )THEN
         nargs = 6
      END IF
*
      nc = 0
      reset = .true.
      errmax = zero
*
      DO 100 in = 1, nidim
         n = idim( in )
*        Set LDA to 1 more than minimum value if room.
         lda = n
         IF( lda.LT.nmax )
     $      lda = lda + 1
*        Skip tests if not enough room.
         IF( lda.GT.nmax )
     $      GO TO 100
         IF( packed )THEN
            laa = ( n*( n + 1 ) )/2
         ELSE
            laa = lda*n
         END IF
*
         DO 90 ic = 1, 2
            uplo = ich( ic: ic )
            upper = uplo.EQ.'U'
*
            DO 80 ix = 1, ninc
               incx = inc( ix )
               lx = abs( incx )*n
*
*              Generate the vector X.
*
               transl = half
               CALL smake( 'GE', ' ', ' ', 1, n, x, 1, xx, abs( incx ),
     $                     0, n - 1, reset, transl )
               IF( n.GT.1 )THEN
                  x( n/2 ) = zero
                  xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
               END IF
*
               DO 70 ia = 1, nalf
                  alpha = alf( ia )
                  null = n.LE.0.OR.alpha.EQ.zero
*
*                 Generate the matrix A.
*
                  transl = zero
                  CALL smake( sname( 2: 3 ), uplo, ' ', n, n, a, nmax,
     $                        aa, lda, n - 1, n - 1, reset, transl )
*
                  nc = nc + 1
*
*                 Save every datum before calling the subroutine.
*
                  uplos = uplo
                  ns = n
                  als = alpha
                  DO 10 i = 1, laa
                     as( i ) = aa( i )
   10             CONTINUE
                  ldas = lda
                  DO 20 i = 1, lx
                     xs( i ) = xx( i )
   20             CONTINUE
                  incxs = incx
*
*                 Call the subroutine.
*
                  IF( full )THEN
                     IF( trace )
     $                  WRITE( ntra, fmt = 9993 )nc, sname, uplo, n,
     $                  alpha, incx, lda
                     IF( rewi )
     $                  rewind ntra
                     CALL ssyr( uplo, n, alpha, xx, incx, aa, lda )
                  ELSE IF( packed )THEN
                     IF( trace )
     $                  WRITE( ntra, fmt = 9994 )nc, sname, uplo, n,
     $                  alpha, incx
                     IF( rewi )
     $                  rewind ntra
                     CALL sspr( uplo, n, alpha, xx, incx, aa )
                  END IF
*
*                 Check if error-exit was taken incorrectly.
*
                  IF( .NOT.ok )THEN
                     WRITE( nout, fmt = 9992 )
                     fatal = .true.
                     GO TO 120
                  END IF
*
*                 See what data changed inside subroutines.
*
                  isame( 1 ) = uplo.EQ.uplos
                  isame( 2 ) = ns.EQ.n
                  isame( 3 ) = als.EQ.alpha
                  isame( 4 ) = lse( xs, xx, lx )
                  isame( 5 ) = incxs.EQ.incx
                  IF( null )THEN
                     isame( 6 ) = lse( as, aa, laa )
                  ELSE
                     isame( 6 ) = lseres( sname( 2: 3 ), uplo, n, n, as,
     $                            aa, lda )
                  END IF
                  IF( .NOT.packed )THEN
                     isame( 7 ) = ldas.EQ.lda
                  END IF
*
*                 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
   30             CONTINUE
                  IF( .NOT.same )THEN
                     fatal = .true.
                     GO TO 120
                  END IF
*
                  IF( .NOT.null )THEN
*
*                    Check the result column by column.
*
                     IF( incx.GT.0 )THEN
                        DO 40 i = 1, n
                           z( i ) = x( i )
   40                   CONTINUE
                     ELSE
                        DO 50 i = 1, n
                           z( i ) = x( n - i + 1 )
   50                   CONTINUE
                     END IF
                     ja = 1
                     DO 60 j = 1, n
                        w( 1 ) = z( j )
                        IF( upper )THEN
                           jj = 1
                           lj = j
                        ELSE
                           jj = j
                           lj = n - j + 1
                        END IF
                        CALL smvch( 'N', lj, 1, alpha, z( jj ), lj, w,
     $                              1, one, a( jj, j ), 1, yt, g,
     $                              aa( ja ), eps, err, fatal, nout,
     $                              .true. )
                        IF( full )THEN
                           IF( upper )THEN
                              ja = ja + lda
                           ELSE
                              ja = ja + lda + 1
                           END IF
                        ELSE
                           ja = ja + lj
                        END IF
                        errmax = max( errmax, err )
*                       If got really bad answer, report and return.
                        IF( fatal )
     $                     GO TO 110
   60                CONTINUE
                  ELSE
*                    Avoid repeating tests if N.le.0.
                     IF( n.LE.0 )
     $                  GO TO 100
                  END IF
*
   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
*
  110 CONTINUE
      WRITE( nout, fmt = 9995 )j
*
  120 CONTINUE
      WRITE( nout, fmt = 9996 )sname
      IF( full )THEN
         WRITE( nout, fmt = 9993 )nc, sname, uplo, n, alpha, incx, lda
      ELSE IF( packed )THEN
         WRITE( nout, fmt = 9994 )nc, sname, uplo, n, alpha, incx
      END IF
*
  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( '      THESE ARE THE RESULTS FOR COLUMN ', i3 )
 9994 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', i3, ',', f4.1, ', X,',
     $      i2, ', AP)                           .' )
 9993 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', i3, ',', f4.1, ', X,',
     $      i2, ', A,', i3, ')                        .' )
 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
     $      '******' )
*
*     End of SCHK5
*

Here is the call graph for this function:

Here is the caller graph for this function: