LAPACK 3.11.0 LAPACK: Linear Algebra PACKage
Searching...
No Matches

◆ dget40()

 subroutine dget40 ( double precision RMAX, integer LMAX, integer, dimension( 2 ) NINFO, integer KNT, integer NIN )

DGET40

Purpose:
``` DGET40 tests DTGEXC, a routine for swapping adjacent blocks (either
1 by 1 or 2 by 2) on the diagonal of a pencil in real generalized Schur form.
Thus, DTGEXC computes an orthogonal matrices Q and Z such that

Q' * ( [ A B ], [ D E ] ) * Z  = ( [ C1 B1 ], [ F1 E1 ] )
( [ 0 C ]  [   F ] )        ( [ 0  A1 ]  [    D1]  )

where (C1,F1) is similar to (C,F) and (A1,D1) is similar to (A,D).
Both (A,D) and (C,F) are assumed to be in standard form
and (A1,D1) and (C1,F1) are returned with the
same properties.```
Parameters
 [out] RMAX ``` RMAX is DOUBLE PRECISION Value of the largest test ratio.``` [out] LMAX ``` LMAX is INTEGER Example number where largest test ratio achieved.``` [out] NINFO ``` NINFO is INTEGER array, dimension (2) NINFO( 1 ) = DTGEXC without accumulation returned INFO nonzero NINFO( 2 ) = DTGEXC with accumulation returned INFO nonzero``` [out] KNT ``` KNT is INTEGER Total number of examples tested.``` [in] NIN ``` NIN is INTEGER Input logical unit number.```

Definition at line 84 of file dget40.f.

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*
219*
220 GO TO 10
221*
222* End of DGET40
223*
double precision function dlamch(CMACH)
DLAMCH
Definition: dlamch.f:69
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 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
Here is the call graph for this function:
Here is the caller graph for this function: