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 3058 of file zblat3.f.

3061*
3062* Checks the results of the computational tests.
3063*
3064* Auxiliary routine for test program for Level 3 Blas.
3065*
3066* -- Written on 8-February-1989.
3067* Jack Dongarra, Argonne National Laboratory.
3068* Iain Duff, AERE Harwell.
3069* Jeremy Du Croz, Numerical Algorithms Group Ltd.
3070* Sven Hammarling, Numerical Algorithms Group Ltd.
3071*
3072* .. Parameters ..
3073 COMPLEX*16 ZERO
3074 parameter( zero = ( 0.0d0, 0.0d0 ) )
3075 DOUBLE PRECISION RZERO, RONE
3076 parameter( rzero = 0.0d0, rone = 1.0d0 )
3077* .. Scalar Arguments ..
3078 COMPLEX*16 ALPHA, BETA
3079 DOUBLE PRECISION EPS, ERR
3080 INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT
3081 LOGICAL FATAL, MV
3082 CHARACTER*1 TRANSA, TRANSB
3083* .. Array Arguments ..
3084 COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ),
3085 $ CC( LDCC, * ), CT( * )
3086 DOUBLE PRECISION G( * )
3087* .. Local Scalars ..
3088 COMPLEX*16 CL
3089 DOUBLE PRECISION ERRI
3090 INTEGER I, J, K
3091 LOGICAL CTRANA, CTRANB, TRANA, TRANB
3092* .. Intrinsic Functions ..
3093 INTRINSIC abs, dimag, dconjg, max, dble, sqrt
3094* .. Statement Functions ..
3095 DOUBLE PRECISION ABS1
3096* .. Statement Function definitions ..
3097 abs1( cl ) = abs( dble( cl ) ) + abs( dimag( cl ) )
3098* .. Executable Statements ..
3099 trana = transa.EQ.'T'.OR.transa.EQ.'C'
3100 tranb = transb.EQ.'T'.OR.transb.EQ.'C'
3101 ctrana = transa.EQ.'C'
3102 ctranb = transb.EQ.'C'
3103*
3104* Compute expected result, one column at a time, in CT using data
3105* in A, B and C.
3106* Compute gauges in G.
3107*
3108 DO 220 j = 1, n
3109*
3110 DO 10 i = 1, m
3111 ct( i ) = zero
3112 g( i ) = rzero
3113 10 CONTINUE
3114 IF( .NOT.trana.AND..NOT.tranb )THEN
3115 DO 30 k = 1, kk
3116 DO 20 i = 1, m
3117 ct( i ) = ct( i ) + a( i, k )*b( k, j )
3118 g( i ) = g( i ) + abs1( a( i, k ) )*abs1( b( k, j ) )
3119 20 CONTINUE
3120 30 CONTINUE
3121 ELSE IF( trana.AND..NOT.tranb )THEN
3122 IF( ctrana )THEN
3123 DO 50 k = 1, kk
3124 DO 40 i = 1, m
3125 ct( i ) = ct( i ) + dconjg( a( k, i ) )*b( k, j )
3126 g( i ) = g( i ) + abs1( a( k, i ) )*
3127 $ abs1( b( k, j ) )
3128 40 CONTINUE
3129 50 CONTINUE
3130 ELSE
3131 DO 70 k = 1, kk
3132 DO 60 i = 1, m
3133 ct( i ) = ct( i ) + a( k, i )*b( k, j )
3134 g( i ) = g( i ) + abs1( a( k, i ) )*
3135 $ abs1( b( k, j ) )
3136 60 CONTINUE
3137 70 CONTINUE
3138 END IF
3139 ELSE IF( .NOT.trana.AND.tranb )THEN
3140 IF( ctranb )THEN
3141 DO 90 k = 1, kk
3142 DO 80 i = 1, m
3143 ct( i ) = ct( i ) + a( i, k )*dconjg( b( j, k ) )
3144 g( i ) = g( i ) + abs1( a( i, k ) )*
3145 $ abs1( b( j, k ) )
3146 80 CONTINUE
3147 90 CONTINUE
3148 ELSE
3149 DO 110 k = 1, kk
3150 DO 100 i = 1, m
3151 ct( i ) = ct( i ) + a( i, k )*b( j, k )
3152 g( i ) = g( i ) + abs1( a( i, k ) )*
3153 $ abs1( b( j, k ) )
3154 100 CONTINUE
3155 110 CONTINUE
3156 END IF
3157 ELSE IF( trana.AND.tranb )THEN
3158 IF( ctrana )THEN
3159 IF( ctranb )THEN
3160 DO 130 k = 1, kk
3161 DO 120 i = 1, m
3162 ct( i ) = ct( i ) + dconjg( a( k, i ) )*
3163 $ dconjg( b( j, k ) )
3164 g( i ) = g( i ) + abs1( a( k, i ) )*
3165 $ abs1( b( j, k ) )
3166 120 CONTINUE
3167 130 CONTINUE
3168 ELSE
3169 DO 150 k = 1, kk
3170 DO 140 i = 1, m
3171 ct( i ) = ct( i ) + dconjg( a( k, i ) )*
3172 $ b( j, k )
3173 g( i ) = g( i ) + abs1( a( k, i ) )*
3174 $ abs1( b( j, k ) )
3175 140 CONTINUE
3176 150 CONTINUE
3177 END IF
3178 ELSE
3179 IF( ctranb )THEN
3180 DO 170 k = 1, kk
3181 DO 160 i = 1, m
3182 ct( i ) = ct( i ) + a( k, i )*
3183 $ dconjg( b( j, k ) )
3184 g( i ) = g( i ) + abs1( a( k, i ) )*
3185 $ abs1( b( j, k ) )
3186 160 CONTINUE
3187 170 CONTINUE
3188 ELSE
3189 DO 190 k = 1, kk
3190 DO 180 i = 1, m
3191 ct( i ) = ct( i ) + a( k, i )*b( j, k )
3192 g( i ) = g( i ) + abs1( a( k, i ) )*
3193 $ abs1( b( j, k ) )
3194 180 CONTINUE
3195 190 CONTINUE
3196 END IF
3197 END IF
3198 END IF
3199 DO 200 i = 1, m
3200 ct( i ) = alpha*ct( i ) + beta*c( i, j )
3201 g( i ) = abs1( alpha )*g( i ) +
3202 $ abs1( beta )*abs1( c( i, j ) )
3203 200 CONTINUE
3204*
3205* Compute the error ratio for this result.
3206*
3207 err = zero
3208 DO 210 i = 1, m
3209 erri = abs1( ct( i ) - cc( i, j ) )/eps
3210 IF( g( i ).NE.rzero )
3211 $ erri = erri/g( i )
3212 err = max( err, erri )
3213 IF( err*sqrt( eps ).GE.rone )
3214 $ GO TO 230
3215 210 CONTINUE
3216*
3217 220 CONTINUE
3218*
3219* If the loop completes, all results are at least half accurate.
3220 GO TO 250
3221*
3222* Report fatal error.
3223*
3224 230 fatal = .true.
3225 WRITE( nout, fmt = 9999 )
3226 DO 240 i = 1, m
3227 IF( mv )THEN
3228 WRITE( nout, fmt = 9998 )i, ct( i ), cc( i, j )
3229 ELSE
3230 WRITE( nout, fmt = 9998 )i, cc( i, j ), ct( i )
3231 END IF
3232 240 CONTINUE
3233 IF( n.GT.1 )
3234 $ WRITE( nout, fmt = 9997 )j
3235*
3236 250 CONTINUE
3237 RETURN
3238*
3239 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
3240 $ 'F ACCURATE *******', /' EXPECTED RE',
3241 $ 'SULT COMPUTED RESULT' )
3242 9998 FORMAT( 1x, i7, 2( ' (', g15.6, ',', g15.6, ')' ) )
3243 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
3244*
3245* End of ZMMCH
3246*
Here is the caller graph for this function: