LAPACK  3.8.0
LAPACK: Linear Algebra PACKage

◆ zmvch()

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

Definition at line 2919 of file zblat2.f.

2919 *
2920 * Checks the results of the computational tests.
2921 *
2922 * Auxiliary routine for test program for Level 2 Blas.
2923 *
2924 * -- Written on 10-August-1987.
2925 * Richard Hanson, Sandia National Labs.
2926 * Jeremy Du Croz, NAG Central Office.
2927 *
2928 * .. Parameters ..
2929  COMPLEX*16 zero
2930  parameter( zero = ( 0.0d0, 0.0d0 ) )
2931  DOUBLE PRECISION rzero, rone
2932  parameter( rzero = 0.0d0, rone = 1.0d0 )
2933 * .. Scalar Arguments ..
2934  COMPLEX*16 alpha, beta
2935  DOUBLE PRECISION eps, err
2936  INTEGER incx, incy, m, n, nmax, nout
2937  LOGICAL fatal, mv
2938  CHARACTER*1 trans
2939 * .. Array Arguments ..
2940  COMPLEX*16 a( nmax, * ), x( * ), y( * ), yt( * ), yy( * )
2941  DOUBLE PRECISION g( * )
2942 * .. Local Scalars ..
2943  COMPLEX*16 c
2944  DOUBLE PRECISION erri
2945  INTEGER i, incxl, incyl, iy, j, jx, kx, ky, ml, nl
2946  LOGICAL ctran, tran
2947 * .. Intrinsic Functions ..
2948  INTRINSIC abs, dble, dconjg, dimag, max, sqrt
2949 * .. Statement Functions ..
2950  DOUBLE PRECISION abs1
2951 * .. Statement Function definitions ..
2952  abs1( c ) = abs( dble( c ) ) + abs( dimag( c ) )
2953 * .. Executable Statements ..
2954  tran = trans.EQ.'T'
2955  ctran = trans.EQ.'C'
2956  IF( tran.OR.ctran )THEN
2957  ml = n
2958  nl = m
2959  ELSE
2960  ml = m
2961  nl = n
2962  END IF
2963  IF( incx.LT.0 )THEN
2964  kx = nl
2965  incxl = -1
2966  ELSE
2967  kx = 1
2968  incxl = 1
2969  END IF
2970  IF( incy.LT.0 )THEN
2971  ky = ml
2972  incyl = -1
2973  ELSE
2974  ky = 1
2975  incyl = 1
2976  END IF
2977 *
2978 * Compute expected result in YT using data in A, X and Y.
2979 * Compute gauges in G.
2980 *
2981  iy = ky
2982  DO 40 i = 1, ml
2983  yt( iy ) = zero
2984  g( iy ) = rzero
2985  jx = kx
2986  IF( tran )THEN
2987  DO 10 j = 1, nl
2988  yt( iy ) = yt( iy ) + a( j, i )*x( jx )
2989  g( iy ) = g( iy ) + abs1( a( j, i ) )*abs1( x( jx ) )
2990  jx = jx + incxl
2991  10 CONTINUE
2992  ELSE IF( ctran )THEN
2993  DO 20 j = 1, nl
2994  yt( iy ) = yt( iy ) + dconjg( a( j, i ) )*x( jx )
2995  g( iy ) = g( iy ) + abs1( a( j, i ) )*abs1( x( jx ) )
2996  jx = jx + incxl
2997  20 CONTINUE
2998  ELSE
2999  DO 30 j = 1, nl
3000  yt( iy ) = yt( iy ) + a( i, j )*x( jx )
3001  g( iy ) = g( iy ) + abs1( a( i, j ) )*abs1( x( jx ) )
3002  jx = jx + incxl
3003  30 CONTINUE
3004  END IF
3005  yt( iy ) = alpha*yt( iy ) + beta*y( iy )
3006  g( iy ) = abs1( alpha )*g( iy ) + abs1( beta )*abs1( y( iy ) )
3007  iy = iy + incyl
3008  40 CONTINUE
3009 *
3010 * Compute the error ratio for this result.
3011 *
3012  err = zero
3013  DO 50 i = 1, ml
3014  erri = abs( yt( i ) - yy( 1 + ( i - 1 )*abs( incy ) ) )/eps
3015  IF( g( i ).NE.rzero )
3016  $ erri = erri/g( i )
3017  err = max( err, erri )
3018  IF( err*sqrt( eps ).GE.rone )
3019  $ GO TO 60
3020  50 CONTINUE
3021 * If the loop completes, all results are at least half accurate.
3022  GO TO 80
3023 *
3024 * Report fatal error.
3025 *
3026  60 fatal = .true.
3027  WRITE( nout, fmt = 9999 )
3028  DO 70 i = 1, ml
3029  IF( mv )THEN
3030  WRITE( nout, fmt = 9998 )i, yt( i ),
3031  $ yy( 1 + ( i - 1 )*abs( incy ) )
3032  ELSE
3033  WRITE( nout, fmt = 9998 )i,
3034  $ yy( 1 + ( i - 1 )*abs( incy ) ), yt( i )
3035  END IF
3036  70 CONTINUE
3037 *
3038  80 CONTINUE
3039  RETURN
3040 *
3041  9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
3042  $ 'F ACCURATE *******', /' EXPECTED RE',
3043  $ 'SULT COMPUTED RESULT' )
3044  9998 FORMAT( 1x, i7, 2( ' (', g15.6, ',', g15.6, ')' ) )
3045 *
3046 * End of ZMVCH.
3047 *
Here is the caller graph for this function: