LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ sget40()

subroutine sget40 ( real  RMAX,
integer  LMAX,
integer, dimension( 3 )  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
          Number of examples where INFO is nonzero.
[out]KNT
          KNT is INTEGER
          Total number of examples tested.
[out]NIN
          NINFO is INTEGER
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 82 of file sget40.f.

83 *
84 * -- LAPACK test routine --
85 * -- LAPACK is a software package provided by Univ. of Tennessee, --
86 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
87 *
88 * .. Scalar Arguments ..
89  INTEGER KNT, LMAX, NIN
90  REAL RMAX
91 * ..
92 * .. Array Arguments ..
93  INTEGER NINFO( 3 )
94 * ..
95 *
96 * =====================================================================
97 *
98 * .. Parameters ..
99  REAL ZERO, ONE
100  parameter( zero = 0.0, one = 1.0 )
101  INTEGER LDT, LWORK
102  parameter( ldt = 10, lwork = 100 + 4*ldt + 16 )
103 * ..
104 * .. Local Scalars ..
105  INTEGER I, IFST, IFST1, IFST2, IFSTSV, ILST, ILST1,
106  $ ILST2, ILSTSV, INFO1, INFO2, J, LOC, N
107  REAL EPS, RES
108 * ..
109 * .. Local Arrays ..
110  REAL Q( LDT, LDT ), Z( LDT, LDT ), RESULT( 4 ),
111  $ T( LDT, LDT ), T1( LDT, LDT ), T2( LDT, LDT ),
112  $ S( LDT, LDT ), S1( LDT, LDT ), S2( LDT, LDT ),
113  $ TMP( LDT, LDT ), WORK( LWORK )
114 * ..
115 * .. External Functions ..
116  REAL SLAMCH
117  EXTERNAL slamch
118 * ..
119 * .. External Subroutines ..
120  EXTERNAL sget51, slacpy, slaset, stgexc
121 * ..
122 * .. Intrinsic Functions ..
123  INTRINSIC abs, sign
124 * ..
125 * .. Executable Statements ..
126 *
127  eps = slamch( 'P' )
128  rmax = zero
129  lmax = 0
130  knt = 0
131  ninfo( 1 ) = 0
132  ninfo( 2 ) = 0
133  ninfo( 3 ) = 0
134 *
135 * Read input data until N=0
136 *
137  10 CONTINUE
138  READ( nin, fmt = * )n, ifst, ilst
139  IF( n.EQ.0 )
140  $ RETURN
141  knt = knt + 1
142  DO 20 i = 1, n
143  READ( nin, fmt = * )( tmp( i, j ), j = 1, n )
144  20 CONTINUE
145  CALL slacpy( 'F', n, n, tmp, ldt, t, ldt )
146  CALL slacpy( 'F', n, n, tmp, ldt, t1, ldt )
147  CALL slacpy( 'F', n, n, tmp, ldt, t2, ldt )
148  DO 25 i = 1, n
149  READ( nin, fmt = * )( tmp( i, j ), j = 1, n )
150  25 CONTINUE
151  CALL slacpy( 'F', n, n, tmp, ldt, s, ldt )
152  CALL slacpy( 'F', n, n, tmp, ldt, s1, ldt )
153  CALL slacpy( 'F', n, n, tmp, ldt, s2, ldt )
154  ifstsv = ifst
155  ilstsv = ilst
156  ifst1 = ifst
157  ilst1 = ilst
158  ifst2 = ifst
159  ilst2 = ilst
160  res = zero
161 *
162 * Test without accumulating Q and Z
163 *
164  CALL slaset( 'Full', n, n, zero, one, q, ldt )
165  CALL slaset( 'Full', n, n, zero, one, z, ldt )
166  CALL stgexc( .false., .false., n, t1, ldt, s1, ldt, q, ldt,
167  $ z, ldt, ifst1, ilst1, work, lwork, info1 )
168  DO 40 i = 1, n
169  DO 30 j = 1, n
170  IF( i.EQ.j .AND. q( i, j ).NE.one )
171  $ res = res + one / eps
172  IF( i.NE.j .AND. q( i, j ).NE.zero )
173  $ res = res + one / eps
174  IF( i.EQ.j .AND. z( i, j ).NE.one )
175  $ res = res + one / eps
176  IF( i.NE.j .AND. z( i, j ).NE.zero )
177  $ res = res + one / eps
178  30 CONTINUE
179  40 CONTINUE
180 *
181 * Test with accumulating Q
182 *
183  CALL slaset( 'Full', n, n, zero, one, q, ldt )
184  CALL slaset( 'Full', n, n, zero, one, z, ldt )
185  CALL stgexc( .true., .true., n, t2, ldt, s2, ldt, q, ldt,
186  $ z, ldt, ifst2, ilst2, work, lwork, info2 )
187 *
188 * Compare T1 with T2 and S1 with S2
189 *
190  DO 60 i = 1, n
191  DO 50 j = 1, n
192  IF( t1( i, j ).NE.t2( i, j ) )
193  $ res = res + one / eps
194  IF( s1( i, j ).NE.s2( i, j ) )
195  $ res = res + one / eps
196  50 CONTINUE
197  60 CONTINUE
198  IF( ifst1.NE.ifst2 )
199  $ res = res + one / eps
200  IF( ilst1.NE.ilst2 )
201  $ res = res + one / eps
202  IF( info1.NE.info2 )
203  $ res = res + one / eps
204 *
205 * Test orthogonality of Q and Z and backward error on T2 and S2
206 *
207  CALL sget51( 1, n, t, ldt, t2, ldt, q, ldt, z, ldt, work,
208  $ result( 1 ) )
209  CALL sget51( 1, n, s, ldt, s2, ldt, q, ldt, z, ldt, work,
210  $ result( 2 ) )
211  CALL sget51( 3, n, t, ldt, t2, ldt, q, ldt, q, ldt, work,
212  $ result( 3 ) )
213  CALL sget51( 3, n, t, ldt, t2, ldt, z, ldt, z, ldt, work,
214  $ result( 4 ) )
215  res = res + result( 1 ) + result( 2 ) + result( 3 ) + result( 4 )
216 *
217 * Read next matrix pair
218 *
219  GO TO 10
220 *
221 * End of SGET40
222 *
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: