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

◆ zmmtch()

subroutine zmmtch ( character*1 uplo,
character*1 transa,
character*1 transb,
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 3997 of file zblat3.f.

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