LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ 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 2824 of file dblat2.f.

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