LAPACK 3.11.0 LAPACK: Linear Algebra PACKage
Searching...
No Matches
dget36.f
Go to the documentation of this file.
1*> \brief \b DGET36
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 DGET36( RMAX, LMAX, NINFO, KNT, NIN )
12*
13* .. Scalar Arguments ..
14* INTEGER KNT, LMAX, NIN
15* DOUBLE PRECISION RMAX
16* ..
17* .. Array Arguments ..
18* INTEGER NINFO( 3 )
19* ..
20*
21*
22*> \par Purpose:
23* =============
24*>
25*> \verbatim
26*>
27*> DGET36 tests DTREXC, a routine for moving blocks (either 1 by 1 or
28*> 2 by 2) on the diagonal of a matrix in real Schur form. Thus, DLAEXC
29*> computes an orthogonal matrix Q such that
30*>
31*> Q' * T1 * Q = T2
32*>
33*> and where one of the diagonal blocks of T1 (the one at row IFST) has
34*> been moved to position ILST.
35*>
36*> The test code verifies that the residual Q'*T1*Q-T2 is small, that T2
37*> is in Schur form, and that the final position of the IFST block is
38*> ILST (within +-1).
39*>
40*> The test matrices are read from a file with logical unit number NIN.
41*> \endverbatim
42*
43* Arguments:
44* ==========
45*
46*> \param[out] RMAX
47*> \verbatim
48*> RMAX is DOUBLE PRECISION
49*> Value of the largest test ratio.
50*> \endverbatim
51*>
52*> \param[out] LMAX
53*> \verbatim
54*> LMAX is INTEGER
55*> Example number where largest test ratio achieved.
56*> \endverbatim
57*>
58*> \param[out] NINFO
59*> \verbatim
60*> NINFO is INTEGER array, dimension (3)
61*> NINFO(J) is the number of examples where INFO=J.
62*> \endverbatim
63*>
64*> \param[out] KNT
65*> \verbatim
66*> KNT is INTEGER
67*> Total number of examples tested.
68*> \endverbatim
69*>
70*> \param[in] NIN
71*> \verbatim
72*> NIN is INTEGER
73*> Input logical unit number.
74*> \endverbatim
75*
76* Authors:
77* ========
78*
79*> \author Univ. of Tennessee
80*> \author Univ. of California Berkeley
81*> \author Univ. of Colorado Denver
82*> \author NAG Ltd.
83*
84*> \ingroup double_eig
85*
86* =====================================================================
87 SUBROUTINE dget36( RMAX, LMAX, NINFO, KNT, NIN )
88*
89* -- LAPACK test routine --
90* -- LAPACK is a software package provided by Univ. of Tennessee, --
91* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
92*
93* .. Scalar Arguments ..
94 INTEGER KNT, LMAX, NIN
95 DOUBLE PRECISION RMAX
96* ..
97* .. Array Arguments ..
98 INTEGER NINFO( 3 )
99* ..
100*
101* =====================================================================
102*
103* .. Parameters ..
104 DOUBLE PRECISION ZERO, ONE
105 parameter( zero = 0.0d0, one = 1.0d0 )
106 INTEGER LDT, LWORK
107 parameter( ldt = 10, lwork = 2*ldt*ldt )
108* ..
109* .. Local Scalars ..
110 INTEGER I, IFST, IFST1, IFST2, IFSTSV, ILST, ILST1,
111 \$ ILST2, ILSTSV, INFO1, INFO2, J, LOC, N
112 DOUBLE PRECISION EPS, RES
113* ..
114* .. Local Arrays ..
115 DOUBLE PRECISION Q( LDT, LDT ), RESULT( 2 ), T1( LDT, LDT ),
116 \$ T2( LDT, LDT ), TMP( LDT, LDT ), WORK( LWORK )
117* ..
118* .. External Functions ..
119 DOUBLE PRECISION DLAMCH
120 EXTERNAL dlamch
121* ..
122* .. External Subroutines ..
123 EXTERNAL dhst01, dlacpy, dlaset, dtrexc
124* ..
125* .. Intrinsic Functions ..
126 INTRINSIC abs, sign
127* ..
128* .. Executable Statements ..
129*
130 eps = dlamch( 'P' )
131 rmax = zero
132 lmax = 0
133 knt = 0
134 ninfo( 1 ) = 0
135 ninfo( 2 ) = 0
136 ninfo( 3 ) = 0
137*
138* Read input data until N=0
139*
140 10 CONTINUE
141 READ( nin, fmt = * )n, ifst, ilst
142 IF( n.EQ.0 )
143 \$ RETURN
144 knt = knt + 1
145 DO 20 i = 1, n
146 READ( nin, fmt = * )( tmp( i, j ), j = 1, n )
147 20 CONTINUE
148 CALL dlacpy( 'F', n, n, tmp, ldt, t1, ldt )
149 CALL dlacpy( 'F', n, n, tmp, ldt, t2, ldt )
150 ifstsv = ifst
151 ilstsv = ilst
152 ifst1 = ifst
153 ilst1 = ilst
154 ifst2 = ifst
155 ilst2 = ilst
156 res = zero
157*
158* Test without accumulating Q
159*
160 CALL dlaset( 'Full', n, n, zero, one, q, ldt )
161 CALL dtrexc( 'N', n, t1, ldt, q, ldt, ifst1, ilst1, work, info1 )
162 DO 40 i = 1, n
163 DO 30 j = 1, n
164 IF( i.EQ.j .AND. q( i, j ).NE.one )
165 \$ res = res + one / eps
166 IF( i.NE.j .AND. q( i, j ).NE.zero )
167 \$ res = res + one / eps
168 30 CONTINUE
169 40 CONTINUE
170*
171* Test with accumulating Q
172*
173 CALL dlaset( 'Full', n, n, zero, one, q, ldt )
174 CALL dtrexc( 'V', n, t2, ldt, q, ldt, ifst2, ilst2, work, info2 )
175*
176* Compare T1 with T2
177*
178 DO 60 i = 1, n
179 DO 50 j = 1, n
180 IF( t1( i, j ).NE.t2( i, j ) )
181 \$ res = res + one / eps
182 50 CONTINUE
183 60 CONTINUE
184 IF( ifst1.NE.ifst2 )
185 \$ res = res + one / eps
186 IF( ilst1.NE.ilst2 )
187 \$ res = res + one / eps
188 IF( info1.NE.info2 )
189 \$ res = res + one / eps
190*
191* Test for successful reordering of T2
192*
193 IF( info2.NE.0 ) THEN
194 ninfo( info2 ) = ninfo( info2 ) + 1
195 ELSE
196 IF( abs( ifst2-ifstsv ).GT.1 )
197 \$ res = res + one / eps
198 IF( abs( ilst2-ilstsv ).GT.1 )
199 \$ res = res + one / eps
200 END IF
201*
202* Test for small residual, and orthogonality of Q
203*
204 CALL dhst01( n, 1, n, tmp, ldt, t2, ldt, q, ldt, work, lwork,
205 \$ result )
206 res = res + result( 1 ) + result( 2 )
207*
208* Test for T2 being in Schur form
209*
210 loc = 1
211 70 CONTINUE
212 IF( t2( loc+1, loc ).NE.zero ) THEN
213*
214* 2 by 2 block
215*
216 IF( t2( loc, loc+1 ).EQ.zero .OR. t2( loc, loc ).NE.
217 \$ t2( loc+1, loc+1 ) .OR. sign( one, t2( loc, loc+1 ) ).EQ.
218 \$ sign( one, t2( loc+1, loc ) ) )res = res + one / eps
219 DO 80 i = loc + 2, n
220 IF( t2( i, loc ).NE.zero )
221 \$ res = res + one / res
222 IF( t2( i, loc+1 ).NE.zero )
223 \$ res = res + one / res
224 80 CONTINUE
225 loc = loc + 2
226 ELSE
227*
228* 1 by 1 block
229*
230 DO 90 i = loc + 1, n
231 IF( t2( i, loc ).NE.zero )
232 \$ res = res + one / res
233 90 CONTINUE
234 loc = loc + 1
235 END IF
236 IF( loc.LT.n )
237 \$ GO TO 70
238 IF( res.GT.rmax ) THEN
239 rmax = res
240 lmax = knt
241 END IF
242 GO TO 10
243*
244* End of DGET36
245*
246 END
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
Definition: dlacpy.f:103
subroutine dlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition: dlaset.f:110
subroutine dhst01(N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, LWORK, RESULT)
DHST01
Definition: dhst01.f:134
subroutine dget36(RMAX, LMAX, NINFO, KNT, NIN)
DGET36
Definition: dget36.f:88
subroutine dtrexc(COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, INFO)
DTREXC
Definition: dtrexc.f:148