cchk4()

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

Definition at line 1516 of file cblat2.f.

*
*  Tests CGERC and CGERU.
*
*  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 ..
      COMPLEX            ZERO, HALF, ONE
      parameter( zero = ( 0.0, 0.0 ), half = ( 0.5, 0.0 ),
     $                   one = ( 1.0, 0.0 ) )
      REAL               RZERO
      parameter( rzero = 0.0 )
*     .. Scalar Arguments ..
      REAL               EPS, THRESH
      INTEGER            INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
      LOGICAL            FATAL, REWI, TRACE
      CHARACTER*6        SNAME
*     .. Array Arguments ..
      COMPLEX            A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
     $                   AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
     $                   XX( NMAX*INCMAX ), Y( NMAX ),
     $                   YS( NMAX*INCMAX ), YT( NMAX ),
     $                   YY( NMAX*INCMAX ), Z( NMAX )
      REAL               G( NMAX )
      INTEGER            IDIM( NIDIM ), INC( NINC )
*     .. Local Scalars ..
      COMPLEX            ALPHA, ALS, TRANSL
      REAL               ERR, ERRMAX
      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            CONJ, NULL, RESET, SAME
*     .. Local Arrays ..
      COMPLEX            W( 1 )
      LOGICAL            ISAME( 13 )
*     .. External Functions ..
      LOGICAL            LCE, LCERES
      EXTERNAL           lce, lceres
*     .. External Subroutines ..
      EXTERNAL           cgerc, cgeru, cmake, cmvch
*     .. Intrinsic Functions ..
      INTRINSIC          abs, conjg, max, min
*     .. Scalars in Common ..
      INTEGER            INFOT, NOUTC
      LOGICAL            LERR, OK
*     .. Common blocks ..
      COMMON             /infoc/infot, noutc, ok, lerr
*     .. Executable Statements ..
      conj = sname( 5: 5 ).EQ.'C'
*     Define the number of arguments.
      nargs = 9
*
      nc = 0
      reset = .true.
      errmax = rzero
*
      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 cmake( '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 cmake( '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 cmake( sname( 2: 3 ), ' ', ' ', 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( conj )THEN
                        IF( rewi )
     $                     rewind ntra
                        CALL cgerc( m, n, alpha, xx, incx, yy, incy, aa,
     $                              lda )
                     ELSE
                        IF( rewi )
     $                     rewind ntra
                        CALL cgeru( m, n, alpha, xx, incx, yy, incy, aa,
     $                              lda )
                     END IF
*
*                    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 ) = lce( xs, xx, lx )
                     isame( 5 ) = incxs.EQ.incx
                     isame( 6 ) = lce( ys, yy, ly )
                     isame( 7 ) = incys.EQ.incy
                     IF( null )THEN
                        isame( 8 ) = lce( as, aa, laa )
                     ELSE
                        isame( 8 ) = lceres( '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
                           IF( conj )
     $                        w( 1 ) = conjg( w( 1 ) )
                           CALL cmvch( '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
         WRITE( nout, fmt = 9999 )sname, nc
      ELSE
         WRITE( nout, fmt = 9997 )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
*
 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, '(', 2( i3, ',' ), '(', f4.1, ',', f4.1,
     $      '), X,', i2, ', Y,', i2, ', A,', i3, ')                   ',
     $      '      .' )
 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
     $      '******' )
*
*     End of CCHK4
*

Here is the call graph for this function:

Here is the caller graph for this function: