schk5()

subroutine schk5	(	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,
		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,
		integer	iorder
	)

Definition at line 1835 of file c_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,
     $                   IORDER
      LOGICAL            FATAL, REWI, TRACE
      CHARACTER*12       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*14       CUPLO
      CHARACTER*2        ICH
*     .. Local Arrays ..
      REAL               W( 1 )
      LOGICAL            ISAME( 13 )
*     .. External Functions ..
      LOGICAL            LSE, LSERES
      EXTERNAL           lse, lseres
*     .. External Subroutines ..
      EXTERNAL           smake, smvch, csspr, cssyr
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max
*     .. Scalars in Common ..
      INTEGER            INFOT, NOUTC
      LOGICAL            OK
*     .. Common blocks ..
      COMMON             /infoc/infot, noutc, ok
*     .. Data statements ..
      DATA               ich/'UL'/
*     .. Executable Statements ..
      full = sname( 9: 9 ).EQ.'y'
      packed = sname( 9: 9 ).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 )
            IF (uplo.EQ.'U')THEN
               cuplo = '    CblasUpper'
            ELSE
               cuplo = '    CblasLower'
            END IF
            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( 8: 9 ), 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, cuplo, n,
     $                  alpha, incx, lda
                     IF( rewi )
     $                  rewind ntra
                     CALL cssyr( iorder, uplo, n, alpha, xx, incx,
     $                            aa, lda )
                  ELSE IF( packed )THEN
                     IF( trace )
     $                  WRITE( ntra, fmt = 9994 )nc, sname, cuplo, n,
     $                  alpha, incx
                     IF( rewi )
     $                  rewind ntra
                     CALL csspr( iorder, 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( 8: 9 ), 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
         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
      WRITE( nout, fmt = 9995 )j
*
  120 CONTINUE
      WRITE( nout, fmt = 9996 )sname
      IF( full )THEN
         WRITE( nout, fmt = 9993 )nc, sname, cuplo, n, alpha, incx, lda
      ELSE IF( packed )THEN
         WRITE( nout, fmt = 9994 )nc, sname, cuplo, n, alpha, incx
      END IF
*
  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 *******' )
 9997 FORMAT( ' ',a12, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
     $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
     $      ' - SUSPECT *******' )
 9996 FORMAT( ' ******* ',a12, ' FAILED ON CALL NUMBER:' )
 9995 FORMAT( '      THESE ARE THE RESULTS FOR COLUMN ', i3 )
 9994 FORMAT( 1x, i6, ': ',a12, '(', a14, ',', i3, ',', f4.1, ', X,',
     $      i2, ', AP) .' )
 9993 FORMAT( 1x, i6, ': ',a12, '(', a14, ',', 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: