LAPACK  3.8.0
LAPACK: Linear Algebra PACKage

◆ 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 3056 of file cblat3.f.

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