LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ cmvch()

subroutine cmvch ( character*1  TRANS,
integer  M,
integer  N,
complex  ALPHA,
complex, dimension( nmax, * )  A,
integer  NMAX,
complex, dimension( * )  X,
integer  INCX,
complex  BETA,
complex, dimension( * )  Y,
integer  INCY,
complex, dimension( * )  YT,
real, dimension( * )  G,
complex, dimension( * )  YY,
real  EPS,
real  ERR,
logical  FATAL,
integer  NOUT,
logical  MV 
)

Definition at line 2451 of file c_cblat2.f.

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