LAPACK  3.8.0
LAPACK: Linear Algebra PACKage

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

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