LAPACK  3.8.0
LAPACK: Linear Algebra PACKage

◆ dget36()

subroutine dget36 ( double precision  RMAX,
integer  LMAX,
integer, dimension( 3 )  NINFO,
integer  KNT,
integer  NIN 
)

DGET36

Purpose:
 DGET36 tests DTREXC, a routine for moving blocks (either 1 by 1 or
 2 by 2) on the diagonal of a matrix in real Schur form.  Thus, DLAEXC
 computes an orthogonal matrix Q such that

    Q' * T1 * Q  = T2

 and where one of the diagonal blocks of T1 (the one at row IFST) has
 been moved to position ILST.

 The test code verifies that the residual Q'*T1*Q-T2 is small, that T2
 is in Schur form, and that the final position of the IFST block is
 ILST (within +-1).

 The test matrices are read from a file with logical unit number NIN.
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 (3)
          NINFO(J) is the number of examples where INFO=J.
[out]KNT
          KNT is INTEGER
          Total number of examples tested.
[in]NIN
          NIN is INTEGER
          Input logical unit number.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Date
December 2016

Definition at line 90 of file dget36.f.

90 *
91 * -- LAPACK test routine (version 3.7.0) --
92 * -- LAPACK is a software package provided by Univ. of Tennessee, --
93 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
94 * December 2016
95 *
96 * .. Scalar Arguments ..
97  INTEGER knt, lmax, nin
98  DOUBLE PRECISION rmax
99 * ..
100 * .. Array Arguments ..
101  INTEGER ninfo( 3 )
102 * ..
103 *
104 * =====================================================================
105 *
106 * .. Parameters ..
107  DOUBLE PRECISION zero, one
108  parameter( zero = 0.0d0, one = 1.0d0 )
109  INTEGER ldt, lwork
110  parameter( ldt = 10, lwork = 2*ldt*ldt )
111 * ..
112 * .. Local Scalars ..
113  INTEGER i, ifst, ifst1, ifst2, ifstsv, ilst, ilst1,
114  $ ilst2, ilstsv, info1, info2, j, loc, n
115  DOUBLE PRECISION eps, res
116 * ..
117 * .. Local Arrays ..
118  DOUBLE PRECISION q( ldt, ldt ), result( 2 ), t1( ldt, ldt ),
119  $ t2( ldt, ldt ), tmp( ldt, ldt ), work( lwork )
120 * ..
121 * .. External Functions ..
122  DOUBLE PRECISION dlamch
123  EXTERNAL dlamch
124 * ..
125 * .. External Subroutines ..
126  EXTERNAL dhst01, dlacpy, dlaset, dtrexc
127 * ..
128 * .. Intrinsic Functions ..
129  INTRINSIC abs, sign
130 * ..
131 * .. Executable Statements ..
132 *
133  eps = dlamch( 'P' )
134  rmax = zero
135  lmax = 0
136  knt = 0
137  ninfo( 1 ) = 0
138  ninfo( 2 ) = 0
139  ninfo( 3 ) = 0
140 *
141 * Read input data until N=0
142 *
143  10 CONTINUE
144  READ( nin, fmt = * )n, ifst, ilst
145  IF( n.EQ.0 )
146  $ RETURN
147  knt = knt + 1
148  DO 20 i = 1, n
149  READ( nin, fmt = * )( tmp( i, j ), j = 1, n )
150  20 CONTINUE
151  CALL dlacpy( 'F', n, n, tmp, ldt, t1, ldt )
152  CALL dlacpy( 'F', n, n, tmp, ldt, t2, ldt )
153  ifstsv = ifst
154  ilstsv = ilst
155  ifst1 = ifst
156  ilst1 = ilst
157  ifst2 = ifst
158  ilst2 = ilst
159  res = zero
160 *
161 * Test without accumulating Q
162 *
163  CALL dlaset( 'Full', n, n, zero, one, q, ldt )
164  CALL dtrexc( 'N', n, t1, ldt, q, ldt, ifst1, ilst1, work, info1 )
165  DO 40 i = 1, n
166  DO 30 j = 1, n
167  IF( i.EQ.j .AND. q( i, j ).NE.one )
168  $ res = res + one / eps
169  IF( i.NE.j .AND. q( i, j ).NE.zero )
170  $ res = res + one / eps
171  30 CONTINUE
172  40 CONTINUE
173 *
174 * Test with accumulating Q
175 *
176  CALL dlaset( 'Full', n, n, zero, one, q, ldt )
177  CALL dtrexc( 'V', n, t2, ldt, q, ldt, ifst2, ilst2, work, info2 )
178 *
179 * Compare T1 with T2
180 *
181  DO 60 i = 1, n
182  DO 50 j = 1, n
183  IF( t1( i, j ).NE.t2( i, j ) )
184  $ res = res + one / eps
185  50 CONTINUE
186  60 CONTINUE
187  IF( ifst1.NE.ifst2 )
188  $ res = res + one / eps
189  IF( ilst1.NE.ilst2 )
190  $ res = res + one / eps
191  IF( info1.NE.info2 )
192  $ res = res + one / eps
193 *
194 * Test for successful reordering of T2
195 *
196  IF( info2.NE.0 ) THEN
197  ninfo( info2 ) = ninfo( info2 ) + 1
198  ELSE
199  IF( abs( ifst2-ifstsv ).GT.1 )
200  $ res = res + one / eps
201  IF( abs( ilst2-ilstsv ).GT.1 )
202  $ res = res + one / eps
203  END IF
204 *
205 * Test for small residual, and orthogonality of Q
206 *
207  CALL dhst01( n, 1, n, tmp, ldt, t2, ldt, q, ldt, work, lwork,
208  $ result )
209  res = res + result( 1 ) + result( 2 )
210 *
211 * Test for T2 being in Schur form
212 *
213  loc = 1
214  70 CONTINUE
215  IF( t2( loc+1, loc ).NE.zero ) THEN
216 *
217 * 2 by 2 block
218 *
219  IF( t2( loc, loc+1 ).EQ.zero .OR. t2( loc, loc ).NE.
220  $ t2( loc+1, loc+1 ) .OR. sign( one, t2( loc, loc+1 ) ).EQ.
221  $ sign( one, t2( loc+1, loc ) ) )res = res + one / eps
222  DO 80 i = loc + 2, n
223  IF( t2( i, loc ).NE.zero )
224  $ res = res + one / res
225  IF( t2( i, loc+1 ).NE.zero )
226  $ res = res + one / res
227  80 CONTINUE
228  loc = loc + 2
229  ELSE
230 *
231 * 1 by 1 block
232 *
233  DO 90 i = loc + 1, n
234  IF( t2( i, loc ).NE.zero )
235  $ res = res + one / res
236  90 CONTINUE
237  loc = loc + 1
238  END IF
239  IF( loc.LT.n )
240  $ GO TO 70
241  IF( res.GT.rmax ) THEN
242  rmax = res
243  lmax = knt
244  END IF
245  GO TO 10
246 *
247 * End of DGET36
248 *
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
Definition: dlacpy.f:105
double precision function dlamch(CMACH)
DLAMCH
Definition: dlamch.f:65
subroutine dtrexc(COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, INFO)
DTREXC
Definition: dtrexc.f:150
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:112
subroutine dhst01(N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, LWORK, RESULT)
DHST01
Definition: dhst01.f:136
Here is the call graph for this function:
Here is the caller graph for this function: