55 SUBROUTINE zchkgk( NIN, NOUT )
69 INTEGER LDA, LDB, LDVL, LDVR
70 parameter ( lda = 50, ldb = 50, ldvl = 50, ldvr = 50 )
71 INTEGER LDE, LDF, LDWORK, LRWORK
72 parameter ( lde = 50, ldf = 50, ldwork = 50,
75 parameter ( zero = 0.0d+0 )
76 COMPLEX*16 CZERO, CONE
77 parameter ( czero = ( 0.0d+0, 0.0d+0 ),
78 $ cone = ( 1.0d+0, 0.0d+0 ) )
81 INTEGER I, IHI, ILO, INFO, J, KNT, M, N, NINFO
82 DOUBLE PRECISION ANORM, BNORM, EPS, RMAX, VMAX
87 DOUBLE PRECISION LSCALE( lda ), RSCALE( lda ), RWORK( lrwork )
88 COMPLEX*16 A( lda, lda ), AF( lda, lda ), B( ldb, ldb ),
89 $ bf( ldb, ldb ), e( lde, lde ), f( ldf, ldf ),
90 $ vl( ldvl, ldvl ), vlf( ldvl, ldvl ),
91 $ vr( ldvr, ldvr ), vrf( ldvr, ldvr ),
92 $ work( ldwork, ldwork )
95 DOUBLE PRECISION DLAMCH, ZLANGE
96 EXTERNAL dlamch, zlange
102 INTRINSIC abs, dble, dimag, max
105 DOUBLE PRECISION CABS1
108 cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) )
120 eps = dlamch(
'Precision' )
123 READ( nin, fmt = * )n, m
128 READ( nin, fmt = * )( a( i, j ), j = 1, n )
132 READ( nin, fmt = * )( b( i, j ), j = 1, n )
136 READ( nin, fmt = * )( vl( i, j ), j = 1, m )
140 READ( nin, fmt = * )( vr( i, j ), j = 1, m )
145 anorm = zlange(
'M', n, n, a, lda, rwork )
146 bnorm = zlange(
'M', n, n, b, ldb, rwork )
148 CALL zlacpy(
'FULL', n, n, a, lda, af, lda )
149 CALL zlacpy(
'FULL', n, n, b, ldb, bf, ldb )
151 CALL zggbal(
'B', n, a, lda, b, ldb, ilo, ihi, lscale, rscale,
158 CALL zlacpy(
'FULL', n, m, vl, ldvl, vlf, ldvl )
159 CALL zlacpy(
'FULL', n, m, vr, ldvr, vrf, ldvr )
161 CALL zggbak(
'B',
'L', n, ilo, ihi, lscale, rscale, m, vl, ldvl,
168 CALL zggbak(
'B',
'R', n, ilo, ihi, lscale, rscale, m, vr, ldvr,
180 CALL zgemm(
'N',
'N', n, m, n, cone, af, lda, vr, ldvr, czero,
182 CALL zgemm(
'C',
'N', m, m, n, cone, vl, ldvl, work, ldwork,
185 CALL zgemm(
'N',
'N', n, m, n, cone, a, lda, vrf, ldvr, czero,
187 CALL zgemm(
'C',
'N', m, m, n, cone, vlf, ldvl, work, ldwork,
193 vmax = max( vmax, cabs1( e( i, j )-f( i, j ) ) )
196 vmax = vmax / ( eps*max( anorm, bnorm ) )
197 IF( vmax.GT.rmax )
THEN
204 CALL zgemm(
'N',
'N', n, m, n, cone, bf, ldb, vr, ldvr, czero,
206 CALL zgemm(
'C',
'N', m, m, n, cone, vl, ldvl, work, ldwork,
209 CALL zgemm(
'n',
'n', n, m, n, cone, b, ldb, vrf, ldvr, czero,
211 CALL zgemm(
'C',
'N', m, m, n, cone, vlf, ldvl, work, ldwork,
217 vmax = max( vmax, cabs1( e( i, j )-f( i, j ) ) )
220 vmax = vmax / ( eps*max( anorm, bnorm ) )
221 IF( vmax.GT.rmax )
THEN
230 WRITE( nout, fmt = 9999 )
231 9999
FORMAT( 1x,
'.. test output of ZGGBAK .. ' )
233 WRITE( nout, fmt = 9998 )rmax
234 9998
FORMAT(
' value of largest test error =', d12.3 )
235 WRITE( nout, fmt = 9997 )lmax( 1 )
236 9997
FORMAT(
' example number where ZGGBAL info is not 0 =', i4 )
237 WRITE( nout, fmt = 9996 )lmax( 2 )
238 9996
FORMAT(
' example number where ZGGBAK(L) info is not 0 =', i4 )
239 WRITE( nout, fmt = 9995 )lmax( 3 )
240 9995
FORMAT(
' example number where ZGGBAK(R) info is not 0 =', i4 )
241 WRITE( nout, fmt = 9994 )lmax( 4 )
242 9994
FORMAT(
' example number having largest error =', i4 )
243 WRITE( nout, fmt = 9992 )ninfo
244 9992
FORMAT(
' number of examples where info is not 0 =', i4 )
245 WRITE( nout, fmt = 9991 )knt
246 9991
FORMAT(
' total number of examples tested =', i4 )
subroutine zchkgk(NIN, NOUT)
ZCHKGK
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine zgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
ZGEMM
subroutine zggbak(JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO)
ZGGBAK
subroutine zggbal(JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO)
ZGGBAL