LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ dmmch()

subroutine dmmch ( character*1  TRANSA,
character*1  TRANSB,
integer  M,
integer  N,
integer  KK,
double precision  ALPHA,
double precision, dimension( lda, * )  A,
integer  LDA,
double precision, dimension( ldb, * )  B,
integer  LDB,
double precision  BETA,
double precision, dimension( ldc, * )  C,
integer  LDC,
double precision, dimension( * )  CT,
double precision, dimension( * )  G,
double precision, dimension( ldcc, * )  CC,
integer  LDCC,
double precision  EPS,
double precision  ERR,
logical  FATAL,
integer  NOUT,
logical  MV 
)

Definition at line 2196 of file c_dblat3.f.

2199 *
2200 * Checks the results of the computational tests.
2201 *
2202 * Auxiliary routine for test program for Level 3 Blas.
2203 *
2204 * -- Written on 8-February-1989.
2205 * Jack Dongarra, Argonne National Laboratory.
2206 * Iain Duff, AERE Harwell.
2207 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2208 * Sven Hammarling, Numerical Algorithms Group Ltd.
2209 *
2210 * .. Parameters ..
2211  DOUBLE PRECISION ZERO, ONE
2212  parameter( zero = 0.0d0, one = 1.0d0 )
2213 * .. Scalar Arguments ..
2214  DOUBLE PRECISION ALPHA, BETA, EPS, ERR
2215  INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT
2216  LOGICAL FATAL, MV
2217  CHARACTER*1 TRANSA, TRANSB
2218 * .. Array Arguments ..
2219  DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ),
2220  $ CC( LDCC, * ), CT( * ), G( * )
2221 * .. Local Scalars ..
2222  DOUBLE PRECISION ERRI
2223  INTEGER I, J, K
2224  LOGICAL TRANA, TRANB
2225 * .. Intrinsic Functions ..
2226  INTRINSIC abs, max, sqrt
2227 * .. Executable Statements ..
2228  trana = transa.EQ.'T'.OR.transa.EQ.'C'
2229  tranb = transb.EQ.'T'.OR.transb.EQ.'C'
2230 *
2231 * Compute expected result, one column at a time, in CT using data
2232 * in A, B and C.
2233 * Compute gauges in G.
2234 *
2235  DO 120 j = 1, n
2236 *
2237  DO 10 i = 1, m
2238  ct( i ) = zero
2239  g( i ) = zero
2240  10 CONTINUE
2241  IF( .NOT.trana.AND..NOT.tranb )THEN
2242  DO 30 k = 1, kk
2243  DO 20 i = 1, m
2244  ct( i ) = ct( i ) + a( i, k )*b( k, j )
2245  g( i ) = g( i ) + abs( a( i, k ) )*abs( b( k, j ) )
2246  20 CONTINUE
2247  30 CONTINUE
2248  ELSE IF( trana.AND..NOT.tranb )THEN
2249  DO 50 k = 1, kk
2250  DO 40 i = 1, m
2251  ct( i ) = ct( i ) + a( k, i )*b( k, j )
2252  g( i ) = g( i ) + abs( a( k, i ) )*abs( b( k, j ) )
2253  40 CONTINUE
2254  50 CONTINUE
2255  ELSE IF( .NOT.trana.AND.tranb )THEN
2256  DO 70 k = 1, kk
2257  DO 60 i = 1, m
2258  ct( i ) = ct( i ) + a( i, k )*b( j, k )
2259  g( i ) = g( i ) + abs( a( i, k ) )*abs( b( j, k ) )
2260  60 CONTINUE
2261  70 CONTINUE
2262  ELSE IF( trana.AND.tranb )THEN
2263  DO 90 k = 1, kk
2264  DO 80 i = 1, m
2265  ct( i ) = ct( i ) + a( k, i )*b( j, k )
2266  g( i ) = g( i ) + abs( a( k, i ) )*abs( b( j, k ) )
2267  80 CONTINUE
2268  90 CONTINUE
2269  END IF
2270  DO 100 i = 1, m
2271  ct( i ) = alpha*ct( i ) + beta*c( i, j )
2272  g( i ) = abs( alpha )*g( i ) + abs( beta )*abs( c( i, j ) )
2273  100 CONTINUE
2274 *
2275 * Compute the error ratio for this result.
2276 *
2277  err = zero
2278  DO 110 i = 1, m
2279  erri = abs( ct( i ) - cc( i, j ) )/eps
2280  IF( g( i ).NE.zero )
2281  $ erri = erri/g( i )
2282  err = max( err, erri )
2283  IF( err*sqrt( eps ).GE.one )
2284  $ GO TO 130
2285  110 CONTINUE
2286 *
2287  120 CONTINUE
2288 *
2289 * If the loop completes, all results are at least half accurate.
2290  GO TO 150
2291 *
2292 * Report fatal error.
2293 *
2294  130 fatal = .true.
2295  WRITE( nout, fmt = 9999 )
2296  DO 140 i = 1, m
2297  IF( mv )THEN
2298  WRITE( nout, fmt = 9998 )i, ct( i ), cc( i, j )
2299  ELSE
2300  WRITE( nout, fmt = 9998 )i, cc( i, j ), ct( i )
2301  END IF
2302  140 CONTINUE
2303  IF( n.GT.1 )
2304  $ WRITE( nout, fmt = 9997 )j
2305 *
2306  150 CONTINUE
2307  RETURN
2308 *
2309  9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
2310  $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU',
2311  $ 'TED RESULT' )
2312  9998 FORMAT( 1x, i7, 2g18.6 )
2313  9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2314 *
2315 * End of DMMCH.
2316 *