LAPACK 3.12.1
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 2450 of file c_zblat3.f.

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