LAPACK  3.8.0 LAPACK: Linear Algebra PACKage

## ◆ schkgk()

 subroutine schkgk ( integer NIN, integer NOUT )

SCHKGK

Purpose:
``` SCHKGK tests SGGBAK, a routine for backward balancing  of
a matrix pair (A, B).```
Parameters
 [in] NIN ``` NIN is INTEGER The logical unit number for input. NIN > 0.``` [in] NOUT ``` NOUT is INTEGER The logical unit number for output. NOUT > 0.```
Date
December 2016

Definition at line 56 of file schkgk.f.

56 *
57 * -- LAPACK test routine (version 3.7.0) --
58 * -- LAPACK is a software package provided by Univ. of Tennessee, --
59 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
60 * December 2016
61 *
62 * .. Scalar Arguments ..
63  INTEGER nin, nout
64 * ..
65 *
66 * =====================================================================
67 *
68 * .. Parameters ..
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 )
73  REAL zero, one
74  parameter( zero = 0.0e+0, one = 1.0e+0 )
75 * ..
76 * .. Local Scalars ..
77  INTEGER i, ihi, ilo, info, j, knt, m, n, ninfo
78  REAL anorm, bnorm, eps, rmax, vmax
79 * ..
80 * .. Local Arrays ..
81  INTEGER lmax( 4 )
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 )
87 * ..
88 * .. External Functions ..
89  REAL slamch, slange
90  EXTERNAL slamch, slange
91 * ..
92 * .. External Subroutines ..
93  EXTERNAL sgemm, sggbak, sggbal, slacpy
94 * ..
95 * .. Intrinsic Functions ..
96  INTRINSIC abs, max
97 * ..
98 * .. Executable Statements ..
99 *
100 * Initialization
101 *
102  lmax( 1 ) = 0
103  lmax( 2 ) = 0
104  lmax( 3 ) = 0
105  lmax( 4 ) = 0
106  ninfo = 0
107  knt = 0
108  rmax = zero
109 *
110  eps = slamch( 'Precision' )
111 *
112  10 CONTINUE
113  READ( nin, fmt = * )n, m
114  IF( n.EQ.0 )
115  \$ GO TO 100
116 *
117  DO 20 i = 1, n
118  READ( nin, fmt = * )( a( i, j ), j = 1, n )
119  20 CONTINUE
120 *
121  DO 30 i = 1, n
122  READ( nin, fmt = * )( b( i, j ), j = 1, n )
123  30 CONTINUE
124 *
125  DO 40 i = 1, n
126  READ( nin, fmt = * )( vl( i, j ), j = 1, m )
127  40 CONTINUE
128 *
129  DO 50 i = 1, n
130  READ( nin, fmt = * )( vr( i, j ), j = 1, m )
131  50 CONTINUE
132 *
133  knt = knt + 1
134 *
135  anorm = slange( 'M', n, n, a, lda, work )
136  bnorm = slange( 'M', n, n, b, ldb, work )
137 *
138  CALL slacpy( 'FULL', n, n, a, lda, af, lda )
139  CALL slacpy( 'FULL', n, n, b, ldb, bf, ldb )
140 *
141  CALL sggbal( 'B', n, a, lda, b, ldb, ilo, ihi, lscale, rscale,
142  \$ work, info )
143  IF( info.NE.0 ) THEN
144  ninfo = ninfo + 1
145  lmax( 1 ) = knt
146  END IF
147 *
148  CALL slacpy( 'FULL', n, m, vl, ldvl, vlf, ldvl )
149  CALL slacpy( 'FULL', n, m, vr, ldvr, vrf, ldvr )
150 *
151  CALL sggbak( 'B', 'L', n, ilo, ihi, lscale, rscale, m, vl, ldvl,
152  \$ info )
153  IF( info.NE.0 ) THEN
154  ninfo = ninfo + 1
155  lmax( 2 ) = knt
156  END IF
157 *
158  CALL sggbak( 'B', 'R', n, ilo, ihi, lscale, rscale, m, vr, ldvr,
159  \$ info )
160  IF( info.NE.0 ) THEN
161  ninfo = ninfo + 1
162  lmax( 3 ) = knt
163  END IF
164 *
165 * Test of SGGBAK
166 *
167 * Check tilde(VL)'*A*tilde(VR) - VL'*tilde(A)*VR
168 * where tilde(A) denotes the transformed matrix.
169 *
170  CALL sgemm( 'N', 'N', n, m, n, one, af, lda, vr, ldvr, zero, work,
171  \$ ldwork )
172  CALL sgemm( 'T', 'N', m, m, n, one, vl, ldvl, work, ldwork, zero,
173  \$ e, lde )
174 *
175  CALL sgemm( 'N', 'N', n, m, n, one, a, lda, vrf, ldvr, zero, work,
176  \$ ldwork )
177  CALL sgemm( 'T', 'N', m, m, n, one, vlf, ldvl, work, ldwork, zero,
178  \$ f, ldf )
179 *
180  vmax = zero
181  DO 70 j = 1, m
182  DO 60 i = 1, m
183  vmax = max( vmax, abs( e( i, j )-f( i, j ) ) )
184  60 CONTINUE
185  70 CONTINUE
186  vmax = vmax / ( eps*max( anorm, bnorm ) )
187  IF( vmax.GT.rmax ) THEN
188  lmax( 4 ) = knt
189  rmax = vmax
190  END IF
191 *
192 * Check tilde(VL)'*B*tilde(VR) - VL'*tilde(B)*VR
193 *
194  CALL sgemm( 'N', 'N', n, m, n, one, bf, ldb, vr, ldvr, zero, work,
195  \$ ldwork )
196  CALL sgemm( 'T', 'N', m, m, n, one, vl, ldvl, work, ldwork, zero,
197  \$ e, lde )
198 *
199  CALL sgemm( 'N', 'N', n, m, n, one, b, ldb, vrf, ldvr, zero, work,
200  \$ ldwork )
201  CALL sgemm( 'T', 'N', m, m, n, one, vlf, ldvl, work, ldwork, zero,
202  \$ f, ldf )
203 *
204  vmax = zero
205  DO 90 j = 1, m
206  DO 80 i = 1, m
207  vmax = max( vmax, abs( e( i, j )-f( i, j ) ) )
208  80 CONTINUE
209  90 CONTINUE
210  vmax = vmax / ( eps*max( anorm, bnorm ) )
211  IF( vmax.GT.rmax ) THEN
212  lmax( 4 ) = knt
213  rmax = vmax
214  END IF
215 *
216  GO TO 10
217 *
218  100 CONTINUE
219 *
220  WRITE( nout, fmt = 9999 )
221  9999 FORMAT( 1x, '.. test output of SGGBAK .. ' )
222 *
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 )
237 *
238  RETURN
239 *
240 * End of SCHKGK
241 *
subroutine sggbal(JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO)
SGGBAL
Definition: sggbal.f:179
real function slamch(CMACH)
SLAMCH
Definition: slamch.f:69
logical function lde(RI, RJ, LR)
Definition: dblat2.f:2945
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 ...
Definition: slange.f:116
subroutine sgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SGEMM
Definition: sgemm.f:189
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
Definition: slacpy.f:105
subroutine sggbak(JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO)
SGGBAK
Definition: sggbak.f:149
Here is the call graph for this function:
Here is the caller graph for this function: