LAPACK  3.9.1
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 3050 of file cblat3.f.

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