LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ zmmch()

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 2435 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*