LAPACK  3.10.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 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: