LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
schkgk.f
Go to the documentation of this file.
1 *> \brief \b SCHKGK
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 * Definition:
9 * ===========
10 *
11 * SUBROUTINE SCHKGK( NIN, NOUT )
12 *
13 * .. Scalar Arguments ..
14 * INTEGER NIN, NOUT
15 * ..
16 *
17 *
18 *> \par Purpose:
19 * =============
20 *>
21 *> \verbatim
22 *>
23 *> SCHKGK tests SGGBAK, a routine for backward balancing of
24 *> a matrix pair (A, B).
25 *> \endverbatim
26 *
27 * Arguments:
28 * ==========
29 *
30 *> \param[in] NIN
31 *> \verbatim
32 *> NIN is INTEGER
33 *> The logical unit number for input. NIN > 0.
34 *> \endverbatim
35 *>
36 *> \param[in] NOUT
37 *> \verbatim
38 *> NOUT is INTEGER
39 *> The logical unit number for output. NOUT > 0.
40 *> \endverbatim
41 *
42 * Authors:
43 * ========
44 *
45 *> \author Univ. of Tennessee
46 *> \author Univ. of California Berkeley
47 *> \author Univ. of Colorado Denver
48 *> \author NAG Ltd.
49 *
50 *> \date November 2011
51 *
52 *> \ingroup single_eig
53 *
54 * =====================================================================
55  SUBROUTINE schkgk( NIN, NOUT )
56 *
57 * -- LAPACK test routine (version 3.4.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 * November 2011
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 *
242  END
subroutine sggbal(JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO)
SGGBAL
Definition: sggbal.f:179
subroutine schkgk(NIN, NOUT)
SCHKGK
Definition: schkgk.f:56
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