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

## ◆ sget40()

 subroutine sget40 ( real RMAX, integer LMAX, integer, dimension( 2 ) NINFO, integer KNT, integer NIN )

SGET40

Purpose:
``` SGET40 tests STGEXC, 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, STGEXC 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 REAL 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 ) = STGEXC without accumulation returned INFO nonzero NINFO( 2 ) = STGEXC 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 sget40.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 REAL RMAX
93* ..
94* .. Array Arguments ..
95 INTEGER NINFO( 2 )
96* ..
97*
98* =====================================================================
99*
100* .. Parameters ..
101 REAL ZERO, ONE
102 parameter( zero = 0.0, one = 1.0 )
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 REAL EPS, RES
110* ..
111* .. Local Arrays ..
112 REAL 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 REAL SLAMCH
119 EXTERNAL slamch
120* ..
121* .. External Subroutines ..
122 EXTERNAL sget51, slacpy, slaset, stgexc
123* ..
124* .. Intrinsic Functions ..
125 INTRINSIC abs, sign
126* ..
127* .. Executable Statements ..
128*
129 eps = slamch( '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 slacpy( 'F', n, n, tmp, ldt, t, ldt )
147 CALL slacpy( 'F', n, n, tmp, ldt, t1, ldt )
148 CALL slacpy( '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 slacpy( 'F', n, n, tmp, ldt, s, ldt )
153 CALL slacpy( 'F', n, n, tmp, ldt, s1, ldt )
154 CALL slacpy( '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 slaset( 'Full', n, n, zero, one, q, ldt )
166 CALL slaset( 'Full', n, n, zero, one, z, ldt )
167 CALL stgexc( .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 slaset( 'Full', n, n, zero, one, q, ldt )
185 CALL slaset( 'Full', n, n, zero, one, z, ldt )
186 CALL stgexc( .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 sget51( 1, n, t, ldt, t2, ldt, q, ldt, z, ldt, work,
209 \$ result( 1 ) )
210 CALL sget51( 1, n, s, ldt, s2, ldt, q, ldt, z, ldt, work,
211 \$ result( 2 ) )
212 CALL sget51( 3, n, t, ldt, t2, ldt, q, ldt, q, ldt, work,
213 \$ result( 3 ) )
214 CALL sget51( 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 SGET40
223*
subroutine slaset(UPLO, M, N, ALPHA, BETA, A, LDA)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition: slaset.f:110
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
Definition: slacpy.f:103
subroutine stgexc(WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, IFST, ILST, WORK, LWORK, INFO)
STGEXC
Definition: stgexc.f:220
subroutine sget51(ITYPE, N, A, LDA, B, LDB, U, LDU, V, LDV, WORK, RESULT)
SGET51
Definition: sget51.f:149
real function slamch(CMACH)
SLAMCH
Definition: slamch.f:68
Here is the call graph for this function:
Here is the caller graph for this function: