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

◆ zmmtch()

subroutine zmmtch ( character*1 uplo,
character*1 transa,
character*1 transb,
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 3145 of file c_zblat3.f.

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