LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine zmmch ( character*1  TRANSA,
character*1  TRANSB,
integer  M,
integer  N,
integer  KK,
complex*16  ALPHA,
complex*16, dimension( lda, * )  A,
integer  LDA,
complex*16, dimension( ldb, * )  B,
integer  LDB,
complex*16  BETA,
complex*16, dimension( ldc, * )  C,
integer  LDC,
complex*16, dimension( * )  CT,
double precision, dimension( * )  G,
complex*16, dimension( ldcc, * )  CC,
integer  LDCC,
double precision  EPS,
double precision  ERR,
logical  FATAL,
integer  NOUT,
logical  MV 
)

Definition at line 2438 of file c_zblat3.f.

2438 *
2439 * Checks the results of the computational tests.
2440 *
2441 * Auxiliary routine for test program for Level 3 Blas.
2442 *
2443 * -- Written on 8-February-1989.
2444 * Jack Dongarra, Argonne National Laboratory.
2445 * Iain Duff, AERE Harwell.
2446 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2447 * Sven Hammarling, Numerical Algorithms Group Ltd.
2448 *
2449 * .. Parameters ..
2450  COMPLEX*16 zero
2451  parameter ( zero = ( 0.0d0, 0.0d0 ) )
2452  DOUBLE PRECISION rzero, rone
2453  parameter ( rzero = 0.0d0, rone = 1.0d0 )
2454 * .. Scalar Arguments ..
2455  COMPLEX*16 alpha, beta
2456  DOUBLE PRECISION eps, err
2457  INTEGER kk, lda, ldb, ldc, ldcc, m, n, nout
2458  LOGICAL fatal, mv
2459  CHARACTER*1 transa, transb
2460 * .. Array Arguments ..
2461  COMPLEX*16 a( lda, * ), b( ldb, * ), c( ldc, * ),
2462  $ cc( ldcc, * ), ct( * )
2463  DOUBLE PRECISION g( * )
2464 * .. Local Scalars ..
2465  COMPLEX*16 cl
2466  DOUBLE PRECISION erri
2467  INTEGER i, j, k
2468  LOGICAL ctrana, ctranb, trana, tranb
2469 * .. Intrinsic Functions ..
2470  INTRINSIC abs, dimag, dconjg, max, dble, sqrt
2471 * .. Statement Functions ..
2472  DOUBLE PRECISION abs1
2473 * .. Statement Function definitions ..
2474  abs1( cl ) = abs( dble( cl ) ) + abs( dimag( cl ) )
2475 * .. Executable Statements ..
2476  trana = transa.EQ.'T'.OR.transa.EQ.'C'
2477  tranb = transb.EQ.'T'.OR.transb.EQ.'C'
2478  ctrana = transa.EQ.'C'
2479  ctranb = transb.EQ.'C'
2480 *
2481 * Compute expected result, one column at a time, in CT using data
2482 * in A, B and C.
2483 * Compute gauges in G.
2484 *
2485  DO 220 j = 1, n
2486 *
2487  DO 10 i = 1, m
2488  ct( i ) = zero
2489  g( i ) = rzero
2490  10 CONTINUE
2491  IF( .NOT.trana.AND..NOT.tranb )THEN
2492  DO 30 k = 1, kk
2493  DO 20 i = 1, m
2494  ct( i ) = ct( i ) + a( i, k )*b( k, j )
2495  g( i ) = g( i ) + abs1( a( i, k ) )*abs1( b( k, j ) )
2496  20 CONTINUE
2497  30 CONTINUE
2498  ELSE IF( trana.AND..NOT.tranb )THEN
2499  IF( ctrana )THEN
2500  DO 50 k = 1, kk
2501  DO 40 i = 1, m
2502  ct( i ) = ct( i ) + dconjg( a( k, i ) )*b( k, j )
2503  g( i ) = g( i ) + abs1( a( k, i ) )*
2504  $ abs1( b( k, j ) )
2505  40 CONTINUE
2506  50 CONTINUE
2507  ELSE
2508  DO 70 k = 1, kk
2509  DO 60 i = 1, m
2510  ct( i ) = ct( i ) + a( k, i )*b( k, j )
2511  g( i ) = g( i ) + abs1( a( k, i ) )*
2512  $ abs1( b( k, j ) )
2513  60 CONTINUE
2514  70 CONTINUE
2515  END IF
2516  ELSE IF( .NOT.trana.AND.tranb )THEN
2517  IF( ctranb )THEN
2518  DO 90 k = 1, kk
2519  DO 80 i = 1, m
2520  ct( i ) = ct( i ) + a( i, k )*dconjg( b( j, k ) )
2521  g( i ) = g( i ) + abs1( a( i, k ) )*
2522  $ abs1( b( j, k ) )
2523  80 CONTINUE
2524  90 CONTINUE
2525  ELSE
2526  DO 110 k = 1, kk
2527  DO 100 i = 1, m
2528  ct( i ) = ct( i ) + a( i, k )*b( j, k )
2529  g( i ) = g( i ) + abs1( a( i, k ) )*
2530  $ abs1( b( j, k ) )
2531  100 CONTINUE
2532  110 CONTINUE
2533  END IF
2534  ELSE IF( trana.AND.tranb )THEN
2535  IF( ctrana )THEN
2536  IF( ctranb )THEN
2537  DO 130 k = 1, kk
2538  DO 120 i = 1, m
2539  ct( i ) = ct( i ) + dconjg( a( k, i ) )*
2540  $ dconjg( b( j, k ) )
2541  g( i ) = g( i ) + abs1( a( k, i ) )*
2542  $ abs1( b( j, k ) )
2543  120 CONTINUE
2544  130 CONTINUE
2545  ELSE
2546  DO 150 k = 1, kk
2547  DO 140 i = 1, m
2548  ct( i ) = ct( i ) + dconjg( a( k, i ) )*
2549  $ b( j, k )
2550  g( i ) = g( i ) + abs1( a( k, i ) )*
2551  $ abs1( b( j, k ) )
2552  140 CONTINUE
2553  150 CONTINUE
2554  END IF
2555  ELSE
2556  IF( ctranb )THEN
2557  DO 170 k = 1, kk
2558  DO 160 i = 1, m
2559  ct( i ) = ct( i ) + a( k, i )*
2560  $ dconjg( b( j, k ) )
2561  g( i ) = g( i ) + abs1( a( k, i ) )*
2562  $ abs1( b( j, k ) )
2563  160 CONTINUE
2564  170 CONTINUE
2565  ELSE
2566  DO 190 k = 1, kk
2567  DO 180 i = 1, m
2568  ct( i ) = ct( i ) + a( k, i )*b( j, k )
2569  g( i ) = g( i ) + abs1( a( k, i ) )*
2570  $ abs1( b( j, k ) )
2571  180 CONTINUE
2572  190 CONTINUE
2573  END IF
2574  END IF
2575  END IF
2576  DO 200 i = 1, m
2577  ct( i ) = alpha*ct( i ) + beta*c( i, j )
2578  g( i ) = abs1( alpha )*g( i ) +
2579  $ abs1( beta )*abs1( c( i, j ) )
2580  200 CONTINUE
2581 *
2582 * Compute the error ratio for this result.
2583 *
2584  err = zero
2585  DO 210 i = 1, m
2586  erri = abs1( ct( i ) - cc( i, j ) )/eps
2587  IF( g( i ).NE.rzero )
2588  $ erri = erri/g( i )
2589  err = max( err, erri )
2590  IF( err*sqrt( eps ).GE.rone )
2591  $ GO TO 230
2592  210 CONTINUE
2593 *
2594  220 CONTINUE
2595 *
2596 * If the loop completes, all results are at least half accurate.
2597  GO TO 250
2598 *
2599 * Report fatal error.
2600 *
2601  230 fatal = .true.
2602  WRITE( nout, fmt = 9999 )
2603  DO 240 i = 1, m
2604  IF( mv )THEN
2605  WRITE( nout, fmt = 9998 )i, ct( i ), cc( i, j )
2606  ELSE
2607  WRITE( nout, fmt = 9998 )i, cc( i, j ), ct( i )
2608  END IF
2609  240 CONTINUE
2610  IF( n.GT.1 )
2611  $ WRITE( nout, fmt = 9997 )j
2612 *
2613  250 CONTINUE
2614  RETURN
2615 *
2616  9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
2617  $ 'F ACCURATE *******', /' EXPECTED RE',
2618  $ 'SULT COMPUTED RESULT' )
2619  9998 FORMAT( 1x, i7, 2( ' (', g15.6, ',', g15.6, ')' ) )
2620  9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2621 *
2622 * End of ZMMCH.
2623 *