69 INTEGER lda, ldb, ldvl, ldvr
70 parameter ( lda = 50, ldb = 50, ldvl = 50, ldvr = 50 )
71 INTEGER lde, ldf, ldwork
72 parameter (
lde = 50, ldf = 50, ldwork = 50 )
74 parameter ( zero = 0.0e+0, one = 1.0e+0 )
77 INTEGER i, ihi, ilo, info, j, knt, m, n, ninfo
78 REAL anorm, bnorm, eps, rmax, vmax
82 REAL a( lda, lda ), af( lda, lda ), b( ldb, ldb ),
83 $ bf( ldb, ldb ), e(
lde,
lde ), f( ldf, ldf ),
84 $ lscale( lda ), rscale( lda ), vl( ldvl, ldvl ),
85 $ vlf( ldvl, ldvl ), vr( ldvr, ldvr ),
86 $ vrf( ldvr, ldvr ), work( ldwork, ldwork )
110 eps =
slamch(
'Precision' )
113 READ( nin, fmt = * )n, m
118 READ( nin, fmt = * )( a( i, j ), j = 1, n )
122 READ( nin, fmt = * )( b( i, j ), j = 1, n )
126 READ( nin, fmt = * )( vl( i, j ), j = 1, m )
130 READ( nin, fmt = * )( vr( i, j ), j = 1, m )
135 anorm =
slange(
'M', n, n, a, lda, work )
136 bnorm =
slange(
'M', n, n, b, ldb, work )
138 CALL slacpy(
'FULL', n, n, a, lda, af, lda )
139 CALL slacpy(
'FULL', n, n, b, ldb, bf, ldb )
141 CALL sggbal(
'B', n, a, lda, b, ldb, ilo, ihi, lscale, rscale,
148 CALL slacpy(
'FULL', n, m, vl, ldvl, vlf, ldvl )
149 CALL slacpy(
'FULL', n, m, vr, ldvr, vrf, ldvr )
151 CALL sggbak(
'B',
'L', n, ilo, ihi, lscale, rscale, m, vl, ldvl,
158 CALL sggbak(
'B',
'R', n, ilo, ihi, lscale, rscale, m, vr, ldvr,
170 CALL sgemm(
'N',
'N', n, m, n, one, af, lda, vr, ldvr, zero, work,
172 CALL sgemm(
'T',
'N', m, m, n, one, vl, ldvl, work, ldwork, zero,
175 CALL sgemm(
'N',
'N', n, m, n, one, a, lda, vrf, ldvr, zero, work,
177 CALL sgemm(
'T',
'N', m, m, n, one, vlf, ldvl, work, ldwork, zero,
183 vmax = max( vmax, abs( e( i, j )-f( i, j ) ) )
186 vmax = vmax / ( eps*max( anorm, bnorm ) )
187 IF( vmax.GT.rmax )
THEN
194 CALL sgemm(
'N',
'N', n, m, n, one, bf, ldb, vr, ldvr, zero, work,
196 CALL sgemm(
'T',
'N', m, m, n, one, vl, ldvl, work, ldwork, zero,
199 CALL sgemm(
'N',
'N', n, m, n, one, b, ldb, vrf, ldvr, zero, work,
201 CALL sgemm(
'T',
'N', m, m, n, one, vlf, ldvl, work, ldwork, zero,
207 vmax = max( vmax, abs( e( i, j )-f( i, j ) ) )
210 vmax = vmax / ( eps*max( anorm, bnorm ) )
211 IF( vmax.GT.rmax )
THEN
220 WRITE( nout, fmt = 9999 )
221 9999
FORMAT( 1x,
'.. test output of SGGBAK .. ' )
223 WRITE( nout, fmt = 9998 )rmax
224 9998
FORMAT(
' value of largest test error =', e12.3 )
225 WRITE( nout, fmt = 9997 )lmax( 1 )
226 9997
FORMAT(
' example number where SGGBAL info is not 0 =', i4 )
227 WRITE( nout, fmt = 9996 )lmax( 2 )
228 9996
FORMAT(
' example number where SGGBAK(L) info is not 0 =', i4 )
229 WRITE( nout, fmt = 9995 )lmax( 3 )
230 9995
FORMAT(
' example number where SGGBAK(R) info is not 0 =', i4 )
231 WRITE( nout, fmt = 9994 )lmax( 4 )
232 9994
FORMAT(
' example number having largest error =', i4 )
233 WRITE( nout, fmt = 9992 )ninfo
234 9992
FORMAT(
' number of examples where info is not 0 =', i4 )
235 WRITE( nout, fmt = 9991 )knt
236 9991
FORMAT(
' total number of examples tested =', i4 )
subroutine sggbal(JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO)
SGGBAL
logical function lde(RI, RJ, LR)
subroutine sgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SGEMM
real function slange(NORM, M, N, A, LDA, WORK)
SLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine sggbak(JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO)
SGGBAK
real function slamch(CMACH)
SLAMCH
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.