LAPACK 3.12.1
LAPACK: Linear Algebra PACKage
•All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Macros Modules Pages

◆ cmmtch()

subroutine cmmtch ( character*1 uplo,
character*1 transa,
character*1 transb,
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 3142 of file c_cblat3.f.

3146 IMPLICIT NONE
3147*
3148* Checks the results of the computational tests for GEMMTR.
3149*
3150* Auxiliary routine for test program for Level 3 Blas.
3151*
3152* -- Written on 24-June-2024.
3153* Martin Koehler, Max Planck Institute, Magdeburg
3154*
3155* .. Parameters ..
3156 COMPLEX ZERO
3157 parameter( zero = ( 0.0, 0.0 ) )
3158 REAL RZERO, RONE
3159 parameter( rzero = 0.0, rone = 1.0 )
3160* .. Scalar Arguments ..
3161 COMPLEX ALPHA, BETA
3162 REAL EPS, ERR
3163 INTEGER KK, LDA, LDB, LDC, LDCC, N, NOUT
3164 LOGICAL FATAL, MV
3165 CHARACTER*1 TRANSA, TRANSB, UPLO
3166* .. Array Arguments ..
3167 COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ),
3168 $ CC( LDCC, * ), CT( * )
3169 REAL G( * )
3170* .. Local Scalars ..
3171 COMPLEX CL
3172 REAL ERRI
3173 INTEGER I, J, K, ISTART, ISTOP
3174 LOGICAL CTRANA, CTRANB, TRANA, TRANB, UPPER
3175* .. Intrinsic Functions ..
3176 INTRINSIC abs, aimag, conjg, max, real, sqrt
3177* .. Statement Functions ..
3178 REAL ABS1
3179* .. Statement Function definitions ..
3180 abs1( cl ) = abs( real( cl ) ) + abs( aimag( cl ) )
3181* .. Executable Statements ..
3182
3183 upper = uplo.EQ.'U'
3184 trana = transa.EQ.'T'.OR.transa.EQ.'C'
3185 tranb = transb.EQ.'T'.OR.transb.EQ.'C'
3186 ctrana = transa.EQ.'C'
3187 ctranb = transb.EQ.'C'
3188
3189 istart = 1
3190 istop = n
3191*
3192* Compute expected result, one column at a time, in CT using data
3193* in A, B and C.
3194* Compute gauges in G.
3195*
3196 DO 220 j = 1, n
3197*
3198 IF (upper) THEN
3199 istart = 1
3200 istop = j
3201 ELSE
3202 istart = j
3203 istop = n
3204 END IF
3205 DO 10 i = istart, istop
3206 ct( i ) = zero
3207 g( i ) = rzero
3208 10 CONTINUE
3209 IF( .NOT.trana.AND..NOT.tranb )THEN
3210 DO 30 k = 1, kk
3211 DO 20 i = istart, istop
3212 ct( i ) = ct( i ) + a( i, k )*b( k, j )
3213 g( i ) = g( i ) + abs1( a( i, k ) )*abs1( b( k, j ) )
3214 20 CONTINUE
3215 30 CONTINUE
3216 ELSE IF( trana.AND..NOT.tranb )THEN
3217 IF( ctrana )THEN
3218 DO 50 k = 1, kk
3219 DO 40 i = istart, istop
3220 ct( i ) = ct( i ) + conjg( a( k, i ) )*b( k, j )
3221 g( i ) = g( i ) + abs1( a( k, i ) )*
3222 $ abs1( b( k, j ) )
3223 40 CONTINUE
3224 50 CONTINUE
3225 ELSE
3226 DO 70 k = 1, kk
3227 DO 60 i = istart, istop
3228 ct( i ) = ct( i ) + a( k, i )*b( k, j )
3229 g( i ) = g( i ) + abs1( a( k, i ) )*
3230 $ abs1( b( k, j ) )
3231 60 CONTINUE
3232 70 CONTINUE
3233 END IF
3234 ELSE IF( .NOT.trana.AND.tranb )THEN
3235 IF( ctranb )THEN
3236 DO 90 k = 1, kk
3237 DO 80 i = istart, istop
3238 ct( i ) = ct( i ) + a( i, k )*conjg( b( j, k ) )
3239 g( i ) = g( i ) + abs1( a( i, k ) )*
3240 $ abs1( b( j, k ) )
3241 80 CONTINUE
3242 90 CONTINUE
3243 ELSE
3244 DO 110 k = 1, kk
3245 DO 100 i = istart, istop
3246 ct( i ) = ct( i ) + a( i, k )*b( j, k )
3247 g( i ) = g( i ) + abs1( a( i, k ) )*
3248 $ abs1( b( j, k ) )
3249 100 CONTINUE
3250 110 CONTINUE
3251 END IF
3252 ELSE IF( trana.AND.tranb )THEN
3253 IF( ctrana )THEN
3254 IF( ctranb )THEN
3255 DO 130 k = 1, kk
3256 DO 120 i = istart, istop
3257 ct( i ) = ct( i ) + conjg( a( k, i ) )*
3258 $ conjg( b( j, k ) )
3259 g( i ) = g( i ) + abs1( a( k, i ) )*
3260 $ abs1( b( j, k ) )
3261 120 CONTINUE
3262 130 CONTINUE
3263 ELSE
3264 DO 150 k = 1, kk
3265 DO 140 i = istart, istop
3266 ct( i ) = ct( i ) + conjg( a( k, i ) )*b( j, k )
3267 g( i ) = g( i ) + abs1( a( k, i ) )*
3268 $ abs1( b( j, k ) )
3269 140 CONTINUE
3270 150 CONTINUE
3271 END IF
3272 ELSE
3273 IF( ctranb )THEN
3274 DO 170 k = 1, kk
3275 DO 160 i = istart, istop
3276 ct( i ) = ct( i ) + a( k, i )*conjg( b( j, k ) )
3277 g( i ) = g( i ) + abs1( a( k, i ) )*
3278 $ abs1( b( j, k ) )
3279 160 CONTINUE
3280 170 CONTINUE
3281 ELSE
3282 DO 190 k = 1, kk
3283 DO 180 i = istart, istop
3284 ct( i ) = ct( i ) + a( k, i )*b( j, k )
3285 g( i ) = g( i ) + abs1( a( k, i ) )*
3286 $ abs1( b( j, k ) )
3287 180 CONTINUE
3288 190 CONTINUE
3289 END IF
3290 END IF
3291 END IF
3292 DO 200 i = istart, istop
3293 ct( i ) = alpha*ct( i ) + beta*c( i, j )
3294 g( i ) = abs1( alpha )*g( i ) +
3295 $ abs1( beta )*abs1( c( i, j ) )
3296 200 CONTINUE
3297*
3298* Compute the error ratio for this result.
3299*
3300 err = zero
3301 DO 210 i = istart, istop
3302 erri = abs1( ct( i ) - cc( i, j ) )/eps
3303 IF( g( i ).NE.rzero )
3304 $ erri = erri/g( i )
3305 err = max( err, erri )
3306 IF( err*sqrt( eps ).GE.rone )
3307 $ GO TO 230
3308 210 CONTINUE
3309*
3310 220 CONTINUE
3311*
3312* If the loop completes, all results are at least half accurate.
3313 GO TO 250
3314*
3315* Report fatal error.
3316*
3317 230 fatal = .true.
3318 WRITE( nout, fmt = 9999 )
3319 DO 240 i = istart, istop
3320 IF( mv )THEN
3321 WRITE( nout, fmt = 9998 )i, ct( i ), cc( i, j )
3322 ELSE
3323 WRITE( nout, fmt = 9998 )i, cc( i, j ), ct( i )
3324 END IF
3325 240 CONTINUE
3326 IF( n.GT.1 )
3327 $ WRITE( nout, fmt = 9997 )j
3328*
3329 250 CONTINUE
3330 RETURN
3331*
3332 9999 FORMAT(' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
3333 $ 'F ACCURATE *******', /' EXPECTED RE',
3334 $ 'SULT COMPUTED RESULT' )
3335 9998 FORMAT( 1x, i7, 2( ' (', g15.6, ',', g15.6, ')' ) )
3336 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
3337*
3338* End of CMMTCH.
3339*