LAPACK 3.11.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
dget40.f
Go to the documentation of this file.
1*> \brief \b DGET40
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 DGET40( 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( 2 )
19*
20*
21*> \par Purpose:
22* =============
23*>
24*> \verbatim
25*>
26*> DGET40 tests DTGEXC, a routine for swapping adjacent blocks (either
27*> 1 by 1 or 2 by 2) on the diagonal of a pencil in real generalized Schur form.
28*> Thus, DTGEXC computes an orthogonal matrices Q and Z such that
29*>
30*> Q' * ( [ A B ], [ D E ] ) * Z = ( [ C1 B1 ], [ F1 E1 ] )
31*> ( [ 0 C ] [ F ] ) ( [ 0 A1 ] [ D1] )
32*>
33*> where (C1,F1) is similar to (C,F) and (A1,D1) is similar to (A,D).
34*> Both (A,D) and (C,F) are assumed to be in standard form
35*> and (A1,D1) and (C1,F1) are returned with the
36*> same properties.
37*> \endverbatim
38*
39* Arguments:
40* ==========
41*
42*> \param[out] RMAX
43*> \verbatim
44*> RMAX is DOUBLE PRECISION
45*> Value of the largest test ratio.
46*> \endverbatim
47*>
48*> \param[out] LMAX
49*> \verbatim
50*> LMAX is INTEGER
51*> Example number where largest test ratio achieved.
52*> \endverbatim
53*>
54*> \param[out] NINFO
55*> \verbatim
56*> NINFO is INTEGER array, dimension (2)
57*> NINFO( 1 ) = DTGEXC without accumulation returned INFO nonzero
58*> NINFO( 2 ) = DTGEXC with accumulation returned INFO nonzero
59*> \endverbatim
60*>
61*> \param[out] KNT
62*> \verbatim
63*> KNT is INTEGER
64*> Total number of examples tested.
65*> \endverbatim
66*>
67*> \param[in] NIN
68*> \verbatim
69*> NIN is INTEGER
70*> Input logical unit number.
71*> \endverbatim
72*
73* Authors:
74* ========
75*
76*> \author Univ. of Tennessee
77*> \author Univ. of California Berkeley
78*> \author Univ. of Colorado Denver
79*> \author NAG Ltd.
80*
81*> \ingroup double_eig
82*
83* =====================================================================
84 SUBROUTINE dget40( RMAX, LMAX, NINFO, KNT, NIN )
85*
86* -- LAPACK test routine --
87* -- LAPACK is a software package provided by Univ. of Tennessee, --
88* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
89*
90* .. Scalar Arguments ..
91 INTEGER KNT, LMAX, NIN
92 DOUBLE PRECISION RMAX
93* ..
94* .. Array Arguments ..
95 INTEGER NINFO( 2 )
96* ..
97*
98* =====================================================================
99*
100* .. Parameters ..
101 DOUBLE PRECISION ZERO, ONE
102 parameter( zero = 0.0d0, one = 1.0d0 )
103 INTEGER LDT, LWORK
104 parameter( ldt = 10, lwork = 100 + 4*ldt + 16 )
105* ..
106* .. Local Scalars ..
107 INTEGER I, IFST, IFST1, IFST2, IFSTSV, ILST, ILST1,
108 $ ILST2, ILSTSV, J, LOC, N
109 DOUBLE PRECISION EPS, RES
110* ..
111* .. Local Arrays ..
112 DOUBLE PRECISION Q( LDT, LDT ), Z( LDT, LDT ), RESULT( 4 ),
113 $ T( LDT, LDT ), T1( LDT, LDT ), T2( LDT, LDT ),
114 $ S( LDT, LDT ), S1( LDT, LDT ), S2( LDT, LDT ),
115 $ TMP( LDT, LDT ), WORK( LWORK )
116* ..
117* .. External Functions ..
118 DOUBLE PRECISION DLAMCH
119 EXTERNAL dlamch
120* ..
121* .. External Subroutines ..
122 EXTERNAL dhst01, dlacpy, dlaset, dtgexc
123* ..
124* .. Intrinsic Functions ..
125 INTRINSIC abs, sign
126* ..
127* .. Executable Statements ..
128*
129 eps = dlamch( 'P' )
130 rmax = zero
131 lmax = 0
132 knt = 0
133 ninfo( 1 ) = 0
134 ninfo( 2 ) = 0
135*
136* Read input data until N=0
137*
138 10 CONTINUE
139 READ( nin, fmt = * )n, ifst, ilst
140 IF( n.EQ.0 )
141 $ RETURN
142 knt = knt + 1
143 DO 20 i = 1, n
144 READ( nin, fmt = * )( tmp( i, j ), j = 1, n )
145 20 CONTINUE
146 CALL dlacpy( 'F', n, n, tmp, ldt, t, ldt )
147 CALL dlacpy( 'F', n, n, tmp, ldt, t1, ldt )
148 CALL dlacpy( 'F', n, n, tmp, ldt, t2, ldt )
149 DO 25 i = 1, n
150 READ( nin, fmt = * )( tmp( i, j ), j = 1, n )
151 25 CONTINUE
152 CALL dlacpy( 'F', n, n, tmp, ldt, s, ldt )
153 CALL dlacpy( 'F', n, n, tmp, ldt, s1, ldt )
154 CALL dlacpy( 'F', n, n, tmp, ldt, s2, ldt )
155 ifstsv = ifst
156 ilstsv = ilst
157 ifst1 = ifst
158 ilst1 = ilst
159 ifst2 = ifst
160 ilst2 = ilst
161 res = zero
162*
163* Test without accumulating Q and Z
164*
165 CALL dlaset( 'Full', n, n, zero, one, q, ldt )
166 CALL dlaset( 'Full', n, n, zero, one, z, ldt )
167 CALL dtgexc( .false., .false., n, t1, ldt, s1, ldt, q, ldt,
168 $ z, ldt, ifst1, ilst1, work, lwork, ninfo( 1 ) )
169 DO 40 i = 1, n
170 DO 30 j = 1, n
171 IF( i.EQ.j .AND. q( i, j ).NE.one )
172 $ res = res + one / eps
173 IF( i.NE.j .AND. q( i, j ).NE.zero )
174 $ res = res + one / eps
175 IF( i.EQ.j .AND. z( i, j ).NE.one )
176 $ res = res + one / eps
177 IF( i.NE.j .AND. z( i, j ).NE.zero )
178 $ res = res + one / eps
179 30 CONTINUE
180 40 CONTINUE
181*
182* Test with accumulating Q
183*
184 CALL dlaset( 'Full', n, n, zero, one, q, ldt )
185 CALL dlaset( 'Full', n, n, zero, one, z, ldt )
186 CALL dtgexc( .true., .true., n, t2, ldt, s2, ldt, q, ldt,
187 $ z, ldt, ifst2, ilst2, work, lwork, ninfo( 2 ) )
188*
189* Compare T1 with T2 and S1 with S2
190*
191 DO 60 i = 1, n
192 DO 50 j = 1, n
193 IF( t1( i, j ).NE.t2( i, j ) )
194 $ res = res + one / eps
195 IF( s1( i, j ).NE.s2( i, j ) )
196 $ res = res + one / eps
197 50 CONTINUE
198 60 CONTINUE
199 IF( ifst1.NE.ifst2 )
200 $ res = res + one / eps
201 IF( ilst1.NE.ilst2 )
202 $ res = res + one / eps
203 IF( ninfo( 1 ).NE.ninfo( 2 ) )
204 $ res = res + one / eps
205*
206* Test orthogonality of Q and Z and backward error on T2 and S2
207*
208 CALL dget51( 1, n, t, ldt, t2, ldt, q, ldt, z, ldt, work,
209 $ result( 1 ) )
210 CALL dget51( 1, n, s, ldt, s2, ldt, q, ldt, z, ldt, work,
211 $ result( 2 ) )
212 CALL dget51( 3, n, t, ldt, t2, ldt, q, ldt, q, ldt, work,
213 $ result( 3 ) )
214 CALL dget51( 3, n, t, ldt, t2, ldt, z, ldt, z, ldt, work,
215 $ result( 4 ) )
216 res = res + result( 1 ) + result( 2 ) + result( 3 ) + result( 4 )
217*
218* Read next matrix pair
219*
220 GO TO 10
221*
222* End of DGET40
223*
224 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 dget40(RMAX, LMAX, NINFO, KNT, NIN)
DGET40
Definition: dget40.f:85
subroutine dget51(ITYPE, N, A, LDA, B, LDB, U, LDU, V, LDV, WORK, RESULT)
DGET51
Definition: dget51.f:149
subroutine dtgexc(WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, IFST, ILST, WORK, LWORK, INFO)
DTGEXC
Definition: dtgexc.f:220