LAPACK 3.11.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ 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*