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 )
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( 1
x,
'.. 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 zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
LOGICAL function lde(RI, RJ, LR)
DOUBLE PRECISION function zlange(NORM, M, N, A, LDA, WORK)
ZLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine zgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
ZGEMM
subroutine zchkgk(NIN, NOUT)
ZCHKGK
subroutine zggbak(JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO)
ZGGBAK
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
DOUBLE PRECISION function dlamch(CMACH)
DLAMCH
subroutine zggbal(JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO)
ZGGBAL