LAPACK 3.12.1
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ cmmtch()

subroutine cmmtch ( character*1 uplo,
character*1 transa,
character*1 transb,
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 3983 of file cblat3.f.

3986 IMPLICIT NONE
3987*
3988* Checks the results of the computational tests.
3989*
3990* Auxiliary routine for test program for Level 3 Blas.
3991*
3992* -- Written on 8-February-1989.
3993* Jack Dongarra, Argonne National Laboratory.
3994* Iain Duff, AERE Harwell.
3995* Jeremy Du Croz, Numerical Algorithms Group Ltd.
3996* Sven Hammarling, Numerical Algorithms Group Ltd.
3997*
3998* .. Parameters ..
3999 COMPLEX ZERO
4000 parameter( zero = ( 0.0, 0.0 ) )
4001 REAL RZERO, RONE
4002 parameter( rzero = 0.0, rone = 1.0 )
4003* .. Scalar Arguments ..
4004 COMPLEX ALPHA, BETA
4005 REAL EPS, ERR
4006 INTEGER KK, LDA, LDB, LDC, LDCC, N, NOUT
4007 LOGICAL FATAL, MV
4008 CHARACTER*1 TRANSA, TRANSB, UPLO
4009* .. Array Arguments ..
4010 COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ),
4011 $ CC( LDCC, * ), CT( * )
4012 REAL G( * )
4013* .. Local Scalars ..
4014 COMPLEX CL
4015 REAL ERRI
4016 INTEGER I, J, K, ISTART, ISTOP
4017 LOGICAL CTRANA, CTRANB, TRANA, TRANB, UPPER
4018* .. Intrinsic Functions ..
4019 INTRINSIC abs, aimag, conjg, max, real, sqrt
4020* .. Statement Functions ..
4021 REAL ABS1
4022* .. Statement Function definitions ..
4023 abs1( cl ) = abs( real( cl ) ) + abs( aimag( cl ) )
4024* .. Executable Statements ..
4025 upper = uplo.EQ.'U'
4026 trana = transa.EQ.'T'.OR.transa.EQ.'C'
4027 tranb = transb.EQ.'T'.OR.transb.EQ.'C'
4028 ctrana = transa.EQ.'C'
4029 ctranb = transb.EQ.'C'
4030*
4031* Compute expected result, one column at a time, in CT using data
4032* in A, B and C.
4033* Compute gauges in G.
4034*
4035 istart = 1
4036 istop = 1
4037
4038 DO 220 j = 1, n
4039*
4040 IF ( upper ) THEN
4041 istart = 1
4042 istop = j
4043 ELSE
4044 istart = j
4045 istop = n
4046 END IF
4047
4048 DO 10 i = istart, istop
4049 ct( i ) = zero
4050 g( i ) = rzero
4051 10 CONTINUE
4052 IF( .NOT.trana.AND..NOT.tranb )THEN
4053 DO 30 k = 1, kk
4054 DO 20 i = istart, istop
4055 ct( i ) = ct( i ) + a( i, k )*b( k, j )
4056 g( i ) = g( i ) + abs1( a( i, k ) )*abs1( b( k, j ) )
4057 20 CONTINUE
4058 30 CONTINUE
4059 ELSE IF( trana.AND..NOT.tranb )THEN
4060 IF( ctrana )THEN
4061 DO 50 k = 1, kk
4062 DO 40 i = istart, istop
4063 ct( i ) = ct( i ) + conjg( a( k, i ) )*b( k, j )
4064 g( i ) = g( i ) + abs1( a( k, i ) )*
4065 $ abs1( b( k, j ) )
4066 40 CONTINUE
4067 50 CONTINUE
4068 ELSE
4069 DO 70 k = 1, kk
4070 DO 60 i = istart, istop
4071 ct( i ) = ct( i ) + a( k, i )*b( k, j )
4072 g( i ) = g( i ) + abs1( a( k, i ) )*
4073 $ abs1( b( k, j ) )
4074 60 CONTINUE
4075 70 CONTINUE
4076 END IF
4077 ELSE IF( .NOT.trana.AND.tranb )THEN
4078 IF( ctranb )THEN
4079 DO 90 k = 1, kk
4080 DO 80 i = istart, istop
4081 ct( i ) = ct( i ) + a( i, k )*conjg( b( j, k ) )
4082 g( i ) = g( i ) + abs1( a( i, k ) )*
4083 $ abs1( b( j, k ) )
4084 80 CONTINUE
4085 90 CONTINUE
4086 ELSE
4087 DO 110 k = 1, kk
4088 DO 100 i = istart, istop
4089 ct( i ) = ct( i ) + a( i, k )*b( j, k )
4090 g( i ) = g( i ) + abs1( a( i, k ) )*
4091 $ abs1( b( j, k ) )
4092 100 CONTINUE
4093 110 CONTINUE
4094 END IF
4095 ELSE IF( trana.AND.tranb )THEN
4096 IF( ctrana )THEN
4097 IF( ctranb )THEN
4098 DO 130 k = 1, kk
4099 DO 120 i = istart, istop
4100 ct( i ) = ct( i ) + conjg( a( k, i ) )*
4101 $ conjg( b( j, k ) )
4102 g( i ) = g( i ) + abs1( a( k, i ) )*
4103 $ abs1( b( j, k ) )
4104 120 CONTINUE
4105 130 CONTINUE
4106 ELSE
4107 DO 150 k = 1, kk
4108 DO 140 i = istart, istop
4109 ct( i ) = ct( i ) + conjg( a( k, i ) )*b( j, k )
4110 g( i ) = g( i ) + abs1( a( k, i ) )*
4111 $ abs1( b( j, k ) )
4112 140 CONTINUE
4113 150 CONTINUE
4114 END IF
4115 ELSE
4116 IF( ctranb )THEN
4117 DO 170 k = 1, kk
4118 DO 160 i = istart, istop
4119 ct( i ) = ct( i ) + a( k, i )*conjg( b( j, k ) )
4120 g( i ) = g( i ) + abs1( a( k, i ) )*
4121 $ abs1( b( j, k ) )
4122 160 CONTINUE
4123 170 CONTINUE
4124 ELSE
4125 DO 190 k = 1, kk
4126 DO 180 i = istart, istop
4127 ct( i ) = ct( i ) + a( k, i )*b( j, k )
4128 g( i ) = g( i ) + abs1( a( k, i ) )*
4129 $ abs1( b( j, k ) )
4130 180 CONTINUE
4131 190 CONTINUE
4132 END IF
4133 END IF
4134 END IF
4135 DO 200 i = istart, istop
4136 ct( i ) = alpha*ct( i ) + beta*c( i, j )
4137 g( i ) = abs1( alpha )*g( i ) +
4138 $ abs1( beta )*abs1( c( i, j ) )
4139 200 CONTINUE
4140*
4141* Compute the error ratio for this result.
4142*
4143 err = zero
4144 DO 210 i = istart, istop
4145 erri = abs1( ct( i ) - cc( i, j ) )/eps
4146 IF( g( i ).NE.rzero )
4147 $ erri = erri/g( i )
4148 err = max( err, erri )
4149 IF( err*sqrt( eps ).GE.rone )
4150 $ GO TO 230
4151 210 CONTINUE
4152*
4153 220 CONTINUE
4154*
4155* If the loop completes, all results are at least half accurate.
4156 GO TO 250
4157*
4158* Report fatal error.
4159*
4160 230 fatal = .true.
4161 WRITE( nout, fmt = 9999 )
4162 DO 240 i = istart, istop
4163 IF( mv )THEN
4164 WRITE( nout, fmt = 9998 )i, ct( i ), cc( i, j )
4165 ELSE
4166 WRITE( nout, fmt = 9998 )i, cc( i, j ), ct( i )
4167 END IF
4168 240 CONTINUE
4169 IF( n.GT.1 )
4170 $ WRITE( nout, fmt = 9997 )j
4171*
4172 250 CONTINUE
4173 RETURN
4174*
4175 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
4176 $ 'F ACCURATE *******', /' EXPECTED RE',
4177 $ 'SULT COMPUTED RESULT' )
4178 9998 FORMAT( 1x, i7, 2( ' (', g15.6, ',', g15.6, ')' ) )
4179 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
4180*
4181* End of CMMTCH
4182*
Here is the caller graph for this function: