LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine zmvch ( character*1  TRANS,
integer  M,
integer  N,
complex*16  ALPHA,
complex*16, dimension( nmax, * )  A,
integer  NMAX,
complex*16, dimension( * )  X,
integer  INCX,
complex*16  BETA,
complex*16, dimension( * )  Y,
integer  INCY,
complex*16, dimension( * )  YT,
double precision, dimension( * )  G,
complex*16, dimension( * )  YY,
double precision  EPS,
double precision  ERR,
logical  FATAL,
integer  NOUT,
logical  MV 
)

Definition at line 2459 of file c_zblat2.f.

2459 *
2460 * Checks the results of the computational tests.
2461 *
2462 * Auxiliary routine for test program for Level 2 Blas.
2463 *
2464 * -- Written on 10-August-1987.
2465 * Richard Hanson, Sandia National Labs.
2466 * Jeremy Du Croz, NAG Central Office.
2467 *
2468 * .. Parameters ..
2469  COMPLEX*16 zero
2470  parameter ( zero = ( 0.0d0, 0.0d0 ) )
2471  DOUBLE PRECISION rzero, rone
2472  parameter ( rzero = 0.0d0, rone = 1.0d0 )
2473 * .. Scalar Arguments ..
2474  COMPLEX*16 alpha, beta
2475  DOUBLE PRECISION eps, err
2476  INTEGER incx, incy, m, n, nmax, nout
2477  LOGICAL fatal, mv
2478  CHARACTER*1 trans
2479 * .. Array Arguments ..
2480  COMPLEX*16 a( nmax, * ), x( * ), y( * ), yt( * ), yy( * )
2481  DOUBLE PRECISION g( * )
2482 * .. Local Scalars ..
2483  COMPLEX*16 c
2484  DOUBLE PRECISION erri
2485  INTEGER i, incxl, incyl, iy, j, jx, kx, ky, ml, nl
2486  LOGICAL ctran, tran
2487 * .. Intrinsic Functions ..
2488  INTRINSIC abs, dimag, dconjg, max, dble, sqrt
2489 * .. Statement Functions ..
2490  DOUBLE PRECISION abs1
2491 * .. Statement Function definitions ..
2492  abs1( c ) = abs( dble( c ) ) + abs( dimag( c ) )
2493 * .. Executable Statements ..
2494  tran = trans.EQ.'T'
2495  ctran = trans.EQ.'C'
2496  IF( tran.OR.ctran )THEN
2497  ml = n
2498  nl = m
2499  ELSE
2500  ml = m
2501  nl = n
2502  END IF
2503  IF( incx.LT.0 )THEN
2504  kx = nl
2505  incxl = -1
2506  ELSE
2507  kx = 1
2508  incxl = 1
2509  END IF
2510  IF( incy.LT.0 )THEN
2511  ky = ml
2512  incyl = -1
2513  ELSE
2514  ky = 1
2515  incyl = 1
2516  END IF
2517 *
2518 * Compute expected result in YT using data in A, X and Y.
2519 * Compute gauges in G.
2520 *
2521  iy = ky
2522  DO 40 i = 1, ml
2523  yt( iy ) = zero
2524  g( iy ) = rzero
2525  jx = kx
2526  IF( tran )THEN
2527  DO 10 j = 1, nl
2528  yt( iy ) = yt( iy ) + a( j, i )*x( jx )
2529  g( iy ) = g( iy ) + abs1( a( j, i ) )*abs1( x( jx ) )
2530  jx = jx + incxl
2531  10 CONTINUE
2532  ELSE IF( ctran )THEN
2533  DO 20 j = 1, nl
2534  yt( iy ) = yt( iy ) + dconjg( a( j, i ) )*x( jx )
2535  g( iy ) = g( iy ) + abs1( a( j, i ) )*abs1( x( jx ) )
2536  jx = jx + incxl
2537  20 CONTINUE
2538  ELSE
2539  DO 30 j = 1, nl
2540  yt( iy ) = yt( iy ) + a( i, j )*x( jx )
2541  g( iy ) = g( iy ) + abs1( a( i, j ) )*abs1( x( jx ) )
2542  jx = jx + incxl
2543  30 CONTINUE
2544  END IF
2545  yt( iy ) = alpha*yt( iy ) + beta*y( iy )
2546  g( iy ) = abs1( alpha )*g( iy ) + abs1( beta )*abs1( y( iy ) )
2547  iy = iy + incyl
2548  40 CONTINUE
2549 *
2550 * Compute the error ratio for this result.
2551 *
2552  err = zero
2553  DO 50 i = 1, ml
2554  erri = abs( yt( i ) - yy( 1 + ( i - 1 )*abs( incy ) ) )/eps
2555  IF( g( i ).NE.rzero )
2556  $ erri = erri/g( i )
2557  err = max( err, erri )
2558  IF( err*sqrt( eps ).GE.rone )
2559  $ GO TO 60
2560  50 CONTINUE
2561 * If the loop completes, all results are at least half accurate.
2562  GO TO 80
2563 *
2564 * Report fatal error.
2565 *
2566  60 fatal = .true.
2567  WRITE( nout, fmt = 9999 )
2568  DO 70 i = 1, ml
2569  IF( mv )THEN
2570  WRITE( nout, fmt = 9998 )i, yt( i ),
2571  $ yy( 1 + ( i - 1 )*abs( incy ) )
2572  ELSE
2573  WRITE( nout, fmt = 9998 )i,
2574  $ yy( 1 + ( i - 1 )*abs( incy ) ), yt( i )
2575  END IF
2576  70 CONTINUE
2577 *
2578  80 CONTINUE
2579  RETURN
2580 *
2581  9999 FORMAT(' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
2582  $ 'F ACCURATE *******', /' EXPECTED RE',
2583  $ 'SULT COMPUTED RESULT' )
2584  9998 FORMAT( 1x, i7, 2( ' (', g15.6, ',', g15.6, ')' ) )
2585 *
2586 * End of ZMVCH.
2587 *