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

◆ cmmch()

subroutine cmmch ( character*1 transa,
character*1 transb,
integer m,
integer n,
integer kk,
complex alpha,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldb, * ) b,
integer ldb,
complex beta,
complex, dimension( ldc, * ) c,
integer ldc,
complex, dimension( * ) ct,
real, dimension( * ) g,
complex, dimension( ldcc, * ) cc,
integer ldcc,
real eps,
real err,
logical fatal,
integer nout,
logical mv )

Definition at line 3253 of file cblat3.f.

3256*
3257* Checks the results of the computational tests.
3258*
3259* Auxiliary routine for test program for Level 3 Blas.
3260*
3261* -- Written on 8-February-1989.
3262* Jack Dongarra, Argonne National Laboratory.
3263* Iain Duff, AERE Harwell.
3264* Jeremy Du Croz, Numerical Algorithms Group Ltd.
3265* Sven Hammarling, Numerical Algorithms Group Ltd.
3266*
3267* .. Parameters ..
3268 COMPLEX ZERO
3269 parameter( zero = ( 0.0, 0.0 ) )
3270 REAL RZERO, RONE
3271 parameter( rzero = 0.0, rone = 1.0 )
3272* .. Scalar Arguments ..
3273 COMPLEX ALPHA, BETA
3274 REAL EPS, ERR
3275 INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT
3276 LOGICAL FATAL, MV
3277 CHARACTER*1 TRANSA, TRANSB
3278* .. Array Arguments ..
3279 COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ),
3280 $ CC( LDCC, * ), CT( * )
3281 REAL G( * )
3282* .. Local Scalars ..
3283 COMPLEX CL
3284 REAL ERRI
3285 INTEGER I, J, K
3286 LOGICAL CTRANA, CTRANB, TRANA, TRANB
3287* .. Intrinsic Functions ..
3288 INTRINSIC abs, aimag, conjg, max, real, sqrt
3289* .. Statement Functions ..
3290 REAL ABS1
3291* .. Statement Function definitions ..
3292 abs1( cl ) = abs( real( cl ) ) + abs( aimag( cl ) )
3293* .. Executable Statements ..
3294 trana = transa.EQ.'T'.OR.transa.EQ.'C'
3295 tranb = transb.EQ.'T'.OR.transb.EQ.'C'
3296 ctrana = transa.EQ.'C'
3297 ctranb = transb.EQ.'C'
3298*
3299* Compute expected result, one column at a time, in CT using data
3300* in A, B and C.
3301* Compute gauges in G.
3302*
3303 DO 220 j = 1, n
3304*
3305 DO 10 i = 1, m
3306 ct( i ) = zero
3307 g( i ) = rzero
3308 10 CONTINUE
3309 IF( .NOT.trana.AND..NOT.tranb )THEN
3310 DO 30 k = 1, kk
3311 DO 20 i = 1, m
3312 ct( i ) = ct( i ) + a( i, k )*b( k, j )
3313 g( i ) = g( i ) + abs1( a( i, k ) )*abs1( b( k, j ) )
3314 20 CONTINUE
3315 30 CONTINUE
3316 ELSE IF( trana.AND..NOT.tranb )THEN
3317 IF( ctrana )THEN
3318 DO 50 k = 1, kk
3319 DO 40 i = 1, m
3320 ct( i ) = ct( i ) + conjg( a( k, i ) )*b( k, j )
3321 g( i ) = g( i ) + abs1( a( k, i ) )*
3322 $ abs1( b( k, j ) )
3323 40 CONTINUE
3324 50 CONTINUE
3325 ELSE
3326 DO 70 k = 1, kk
3327 DO 60 i = 1, m
3328 ct( i ) = ct( i ) + a( k, i )*b( k, j )
3329 g( i ) = g( i ) + abs1( a( k, i ) )*
3330 $ abs1( b( k, j ) )
3331 60 CONTINUE
3332 70 CONTINUE
3333 END IF
3334 ELSE IF( .NOT.trana.AND.tranb )THEN
3335 IF( ctranb )THEN
3336 DO 90 k = 1, kk
3337 DO 80 i = 1, m
3338 ct( i ) = ct( i ) + a( i, k )*conjg( b( j, k ) )
3339 g( i ) = g( i ) + abs1( a( i, k ) )*
3340 $ abs1( b( j, k ) )
3341 80 CONTINUE
3342 90 CONTINUE
3343 ELSE
3344 DO 110 k = 1, kk
3345 DO 100 i = 1, m
3346 ct( i ) = ct( i ) + a( i, k )*b( j, k )
3347 g( i ) = g( i ) + abs1( a( i, k ) )*
3348 $ abs1( b( j, k ) )
3349 100 CONTINUE
3350 110 CONTINUE
3351 END IF
3352 ELSE IF( trana.AND.tranb )THEN
3353 IF( ctrana )THEN
3354 IF( ctranb )THEN
3355 DO 130 k = 1, kk
3356 DO 120 i = 1, m
3357 ct( i ) = ct( i ) + conjg( a( k, i ) )*
3358 $ conjg( b( j, k ) )
3359 g( i ) = g( i ) + abs1( a( k, i ) )*
3360 $ abs1( b( j, k ) )
3361 120 CONTINUE
3362 130 CONTINUE
3363 ELSE
3364 DO 150 k = 1, kk
3365 DO 140 i = 1, m
3366 ct( i ) = ct( i ) + conjg( a( k, i ) )*b( j, k )
3367 g( i ) = g( i ) + abs1( a( k, i ) )*
3368 $ abs1( b( j, k ) )
3369 140 CONTINUE
3370 150 CONTINUE
3371 END IF
3372 ELSE
3373 IF( ctranb )THEN
3374 DO 170 k = 1, kk
3375 DO 160 i = 1, m
3376 ct( i ) = ct( i ) + a( k, i )*conjg( b( j, k ) )
3377 g( i ) = g( i ) + abs1( a( k, i ) )*
3378 $ abs1( b( j, k ) )
3379 160 CONTINUE
3380 170 CONTINUE
3381 ELSE
3382 DO 190 k = 1, kk
3383 DO 180 i = 1, m
3384 ct( i ) = ct( i ) + a( k, i )*b( j, k )
3385 g( i ) = g( i ) + abs1( a( k, i ) )*
3386 $ abs1( b( j, k ) )
3387 180 CONTINUE
3388 190 CONTINUE
3389 END IF
3390 END IF
3391 END IF
3392 DO 200 i = 1, m
3393 ct( i ) = alpha*ct( i ) + beta*c( i, j )
3394 g( i ) = abs1( alpha )*g( i ) +
3395 $ abs1( beta )*abs1( c( i, j ) )
3396 200 CONTINUE
3397*
3398* Compute the error ratio for this result.
3399*
3400 err = zero
3401 DO 210 i = 1, m
3402 erri = abs1( ct( i ) - cc( i, j ) )/eps
3403 IF( g( i ).NE.rzero )
3404 $ erri = erri/g( i )
3405 err = max( err, erri )
3406 IF( err*sqrt( eps ).GE.rone )
3407 $ GO TO 230
3408 210 CONTINUE
3409*
3410 220 CONTINUE
3411*
3412* If the loop completes, all results are at least half accurate.
3413 GO TO 250
3414*
3415* Report fatal error.
3416*
3417 230 fatal = .true.
3418 WRITE( nout, fmt = 9999 )
3419 DO 240 i = 1, m
3420 IF( mv )THEN
3421 WRITE( nout, fmt = 9998 )i, ct( i ), cc( i, j )
3422 ELSE
3423 WRITE( nout, fmt = 9998 )i, cc( i, j ), ct( i )
3424 END IF
3425 240 CONTINUE
3426 IF( n.GT.1 )
3427 $ WRITE( nout, fmt = 9997 )j
3428*
3429 250 CONTINUE
3430 RETURN
3431*
3432 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
3433 $ 'F ACCURATE *******', /' EXPECTED RE',
3434 $ 'SULT COMPUTED RESULT' )
3435 9998 FORMAT( 1x, i7, 2( ' (', g15.6, ',', g15.6, ')' ) )
3436 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
3437*
3438* End of CMMCH
3439*
Here is the caller graph for this function: