schk4()

subroutine schk4	(	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 1563 of file c_sblat2.f.

*
*  Tests SGER.
*
*  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, IM, IN, INCX, INCXS, INCY, INCYS, IX,
     $                   IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS,
     $                   NC, ND, NS
      LOGICAL            NULL, RESET, SAME
*     .. Local Arrays ..
      REAL               W( 1 )
      LOGICAL            ISAME( 13 )
*     .. External Functions ..
      LOGICAL            LSE, LSERES
      EXTERNAL           lse, lseres
*     .. External Subroutines ..
      EXTERNAL           csger, smake, smvch
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, min
*     .. Scalars in Common ..
      INTEGER            INFOT, NOUTC
      LOGICAL            OK
*     .. Common blocks ..
      COMMON             /infoc/infot, noutc, ok
*     .. Executable Statements ..
*     Define the number of arguments.
      nargs = 9
*
      nc = 0
      reset = .true.
      errmax = zero
*
      DO 120 in = 1, nidim
         n = idim( in )
         nd = n/2 + 1
*
         DO 110 im = 1, 2
            IF( im.EQ.1 )
     $         m = max( n - nd, 0 )
            IF( im.EQ.2 )
     $         m = min( n + nd, nmax )
*
*           Set LDA to 1 more than minimum value if room.
            lda = m
            IF( lda.LT.nmax )
     $         lda = lda + 1
*           Skip tests if not enough room.
            IF( lda.GT.nmax )
     $         GO TO 110
            laa = lda*n
            null = n.LE.0.OR.m.LE.0
*
            DO 100 ix = 1, ninc
               incx = inc( ix )
               lx = abs( incx )*m
*
*              Generate the vector X.
*
               transl = half
               CALL smake( 'ge', ' ', ' ', 1, m, x, 1, xx, abs( incx ),
     $                     0, m - 1, reset, transl )
               IF( m.GT.1 )THEN
                  x( m/2 ) = zero
                  xx( 1 + abs( incx )*( m/2 - 1 ) ) = zero
               END IF
*
               DO 90 iy = 1, ninc
                  incy = inc( iy )
                  ly = abs( incy )*n
*
*                 Generate the vector Y.
*
                  transl = zero
                  CALL smake( 'ge', ' ', ' ', 1, n, y, 1, yy,
     $                        abs( incy ), 0, n - 1, reset, transl )
                  IF( n.GT.1 )THEN
                     y( n/2 ) = zero
                     yy( 1 + abs( incy )*( n/2 - 1 ) ) = zero
                  END IF
*
                  DO 80 ia = 1, nalf
                     alpha = alf( ia )
*
*                    Generate the matrix A.
*
                     transl = zero
                     CALL smake( sname( 8: 9 ), ' ', ' ', m, n, a, nmax,
     $                           aa, lda, m - 1, n - 1, reset, transl )
*
                     nc = nc + 1
*
*                    Save every datum before calling the subroutine.
*
                     ms = m
                     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
                     DO 30 i = 1, ly
                        ys( i ) = yy( i )
   30                CONTINUE
                     incys = incy
*
*                    Call the subroutine.
*
                     IF( trace )
     $                  WRITE( ntra, fmt = 9994 )nc, sname, m, n,
     $                  alpha, incx, incy, lda
                     IF( rewi )
     $                  rewind ntra
                     CALL csger( iorder, m, n, alpha, xx, incx, yy,
     $                          incy, aa, lda )
*
*                    Check if error-exit was taken incorrectly.
*
                     IF( .NOT.ok )THEN
                        WRITE( nout, fmt = 9993 )
                        fatal = .true.
                        GO TO 140
                     END IF
*
*                    See what data changed inside subroutine.
*
                     isame( 1 ) = ms.EQ.m
                     isame( 2 ) = ns.EQ.n
                     isame( 3 ) = als.EQ.alpha
                     isame( 4 ) = lse( xs, xx, lx )
                     isame( 5 ) = incxs.EQ.incx
                     isame( 6 ) = lse( ys, yy, ly )
                     isame( 7 ) = incys.EQ.incy
                     IF( null )THEN
                        isame( 8 ) = lse( as, aa, laa )
                     ELSE
                        isame( 8 ) = lseres( 'ge', ' ', m, n, as, aa,
     $                               lda )
                     END IF
                     isame( 9 ) = ldas.EQ.lda
*
*                    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 140
                     END IF
*
                     IF( .NOT.null )THEN
*
*                       Check the result column by column.
*
                        IF( incx.GT.0 )THEN
                           DO 50 i = 1, m
                              z( i ) = x( i )
   50                      CONTINUE
                        ELSE
                           DO 60 i = 1, m
                              z( i ) = x( m - i + 1 )
   60                      CONTINUE
                        END IF
                        DO 70 j = 1, n
                           IF( incy.GT.0 )THEN
                              w( 1 ) = y( j )
                           ELSE
                              w( 1 ) = y( n - j + 1 )
                           END IF
                           CALL smvch( 'N', m, 1, alpha, z, nmax, w, 1,
     $                                 one, a( 1, j ), 1, yt, g,
     $                                 aa( 1 + ( j - 1 )*lda ), eps,
     $                                 err, fatal, nout, .true. )
                           errmax = max( errmax, err )
*                          If got really bad answer, report and return.
                           IF( fatal )
     $                        GO TO 130
   70                   CONTINUE
                     ELSE
*                       Avoid repeating tests with M.le.0 or N.le.0.
                        GO TO 110
                     END IF
*
   80             CONTINUE
*
   90          CONTINUE
*
  100       CONTINUE
*
  110    CONTINUE
*
  120 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 150
*
  130 CONTINUE
      WRITE( nout, fmt = 9995 )j
*
  140 CONTINUE
      WRITE( nout, fmt = 9996 )sname
      WRITE( nout, fmt = 9994 )nc, sname, m, n, alpha, incx, incy, lda
*
  150 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, '(', 2( i3, ',' ), f4.1, ', X,', i2,
     $      ', Y,', i2, ', A,', i3, ')                  .' )
 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
     $      '******' )
*
*     End of SCHK4.
*

Here is the call graph for this function: