LAPACK  3.8.0
LAPACK: Linear Algebra PACKage

◆ smvch()

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

Definition at line 2829 of file sblat2.f.

2829 *
2830 * Checks the results of the computational tests.
2831 *
2832 * Auxiliary routine for test program for Level 2 Blas.
2833 *
2834 * -- Written on 10-August-1987.
2835 * Richard Hanson, Sandia National Labs.
2836 * Jeremy Du Croz, NAG Central Office.
2837 *
2838 * .. Parameters ..
2839  REAL zero, one
2840  parameter( zero = 0.0, one = 1.0 )
2841 * .. Scalar Arguments ..
2842  REAL alpha, beta, eps, err
2843  INTEGER incx, incy, m, n, nmax, nout
2844  LOGICAL fatal, mv
2845  CHARACTER*1 trans
2846 * .. Array Arguments ..
2847  REAL a( nmax, * ), g( * ), x( * ), y( * ), yt( * ),
2848  $ yy( * )
2849 * .. Local Scalars ..
2850  REAL erri
2851  INTEGER i, incxl, incyl, iy, j, jx, kx, ky, ml, nl
2852  LOGICAL tran
2853 * .. Intrinsic Functions ..
2854  INTRINSIC abs, max, sqrt
2855 * .. Executable Statements ..
2856  tran = trans.EQ.'T'.OR.trans.EQ.'C'
2857  IF( tran )THEN
2858  ml = n
2859  nl = m
2860  ELSE
2861  ml = m
2862  nl = n
2863  END IF
2864  IF( incx.LT.0 )THEN
2865  kx = nl
2866  incxl = -1
2867  ELSE
2868  kx = 1
2869  incxl = 1
2870  END IF
2871  IF( incy.LT.0 )THEN
2872  ky = ml
2873  incyl = -1
2874  ELSE
2875  ky = 1
2876  incyl = 1
2877  END IF
2878 *
2879 * Compute expected result in YT using data in A, X and Y.
2880 * Compute gauges in G.
2881 *
2882  iy = ky
2883  DO 30 i = 1, ml
2884  yt( iy ) = zero
2885  g( iy ) = zero
2886  jx = kx
2887  IF( tran )THEN
2888  DO 10 j = 1, nl
2889  yt( iy ) = yt( iy ) + a( j, i )*x( jx )
2890  g( iy ) = g( iy ) + abs( a( j, i )*x( jx ) )
2891  jx = jx + incxl
2892  10 CONTINUE
2893  ELSE
2894  DO 20 j = 1, nl
2895  yt( iy ) = yt( iy ) + a( i, j )*x( jx )
2896  g( iy ) = g( iy ) + abs( a( i, j )*x( jx ) )
2897  jx = jx + incxl
2898  20 CONTINUE
2899  END IF
2900  yt( iy ) = alpha*yt( iy ) + beta*y( iy )
2901  g( iy ) = abs( alpha )*g( iy ) + abs( beta*y( iy ) )
2902  iy = iy + incyl
2903  30 CONTINUE
2904 *
2905 * Compute the error ratio for this result.
2906 *
2907  err = zero
2908  DO 40 i = 1, ml
2909  erri = abs( yt( i ) - yy( 1 + ( i - 1 )*abs( incy ) ) )/eps
2910  IF( g( i ).NE.zero )
2911  $ erri = erri/g( i )
2912  err = max( err, erri )
2913  IF( err*sqrt( eps ).GE.one )
2914  $ GO TO 50
2915  40 CONTINUE
2916 * If the loop completes, all results are at least half accurate.
2917  GO TO 70
2918 *
2919 * Report fatal error.
2920 *
2921  50 fatal = .true.
2922  WRITE( nout, fmt = 9999 )
2923  DO 60 i = 1, ml
2924  IF( mv )THEN
2925  WRITE( nout, fmt = 9998 )i, yt( i ),
2926  $ yy( 1 + ( i - 1 )*abs( incy ) )
2927  ELSE
2928  WRITE( nout, fmt = 9998 )i,
2929  $ yy( 1 + ( i - 1 )*abs( incy ) ), yt(i)
2930  END IF
2931  60 CONTINUE
2932 *
2933  70 CONTINUE
2934  RETURN
2935 *
2936  9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
2937  $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU',
2938  $ 'TED RESULT' )
2939  9998 FORMAT( 1x, i7, 2g18.6 )
2940 *
2941 * End of SMVCH.
2942 *
Here is the caller graph for this function: