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

◆ dmvch()

subroutine dmvch ( character*1  trans,
integer  m,
integer  n,
double precision  alpha,
double precision, dimension( nmax, * )  a,
integer  nmax,
double precision, dimension( * )  x,
integer  incx,
double precision  beta,
double precision, dimension( * )  y,
integer  incy,
double precision, dimension( * )  yt,
double precision, dimension( * )  g,
double precision, dimension( * )  yy,
double precision  eps,
double precision  err,
logical  fatal,
integer  nout,
logical  mv 
)

Definition at line 2639 of file c_dblat2.f.

2641*
2642* Checks the results of the computational tests.
2643*
2644* Auxiliary routine for test program for Level 2 Blas.
2645*
2646* -- Written on 10-August-1987.
2647* Richard Hanson, Sandia National Labs.
2648* Jeremy Du Croz, NAG Central Office.
2649*
2650* .. Parameters ..
2651 DOUBLE PRECISION ZERO, ONE
2652 parameter( zero = 0.0d0, one = 1.0d0 )
2653* .. Scalar Arguments ..
2654 DOUBLE PRECISION ALPHA, BETA, EPS, ERR
2655 INTEGER INCX, INCY, M, N, NMAX, NOUT
2656 LOGICAL FATAL, MV
2657 CHARACTER*1 TRANS
2658* .. Array Arguments ..
2659 DOUBLE PRECISION A( NMAX, * ), G( * ), X( * ), Y( * ), YT( * ),
2660 $ YY( * )
2661* .. Local Scalars ..
2662 DOUBLE PRECISION ERRI
2663 INTEGER I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL
2664 LOGICAL TRAN
2665* .. Intrinsic Functions ..
2666 INTRINSIC abs, max, sqrt
2667* .. Executable Statements ..
2668 tran = trans.EQ.'T'.OR.trans.EQ.'C'
2669 IF( tran )THEN
2670 ml = n
2671 nl = m
2672 ELSE
2673 ml = m
2674 nl = n
2675 END IF
2676 IF( incx.LT.0 )THEN
2677 kx = nl
2678 incxl = -1
2679 ELSE
2680 kx = 1
2681 incxl = 1
2682 END IF
2683 IF( incy.LT.0 )THEN
2684 ky = ml
2685 incyl = -1
2686 ELSE
2687 ky = 1
2688 incyl = 1
2689 END IF
2690*
2691* Compute expected result in YT using data in A, X and Y.
2692* Compute gauges in G.
2693*
2694 iy = ky
2695 DO 30 i = 1, ml
2696 yt( iy ) = zero
2697 g( iy ) = zero
2698 jx = kx
2699 IF( tran )THEN
2700 DO 10 j = 1, nl
2701 yt( iy ) = yt( iy ) + a( j, i )*x( jx )
2702 g( iy ) = g( iy ) + abs( a( j, i )*x( jx ) )
2703 jx = jx + incxl
2704 10 CONTINUE
2705 ELSE
2706 DO 20 j = 1, nl
2707 yt( iy ) = yt( iy ) + a( i, j )*x( jx )
2708 g( iy ) = g( iy ) + abs( a( i, j )*x( jx ) )
2709 jx = jx + incxl
2710 20 CONTINUE
2711 END IF
2712 yt( iy ) = alpha*yt( iy ) + beta*y( iy )
2713 g( iy ) = abs( alpha )*g( iy ) + abs( beta*y( iy ) )
2714 iy = iy + incyl
2715 30 CONTINUE
2716*
2717* Compute the error ratio for this result.
2718*
2719 err = zero
2720 DO 40 i = 1, ml
2721 erri = abs( yt( i ) - yy( 1 + ( i - 1 )*abs( incy ) ) )/eps
2722 IF( g( i ).NE.zero )
2723 $ erri = erri/g( i )
2724 err = max( err, erri )
2725 IF( err*sqrt( eps ).GE.one )
2726 $ GO TO 50
2727 40 CONTINUE
2728* If the loop completes, all results are at least half accurate.
2729 GO TO 70
2730*
2731* Report fatal error.
2732*
2733 50 fatal = .true.
2734 WRITE( nout, fmt = 9999 )
2735 DO 60 i = 1, ml
2736 IF( mv )THEN
2737 WRITE( nout, fmt = 9998 )i, yt( i ),
2738 $ yy( 1 + ( i - 1 )*abs( incy ) )
2739 ELSE
2740 WRITE( nout, fmt = 9998 )i,
2741 $ yy( 1 + ( i - 1 )*abs( incy ) ), yt(i)
2742 END IF
2743 60 CONTINUE
2744*
2745 70 CONTINUE
2746 RETURN
2747*
2748 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
2749 $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU',
2750 $ 'TED RESULT' )
2751 9998 FORMAT( 1x, i7, 2g18.6 )
2752*
2753* End of DMVCH.
2754*