LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
cget36.f
Go to the documentation of this file.
1 *> \brief \b CGET36
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 CGET36( RMAX, LMAX, NINFO, KNT, NIN )
12 *
13 * .. Scalar Arguments ..
14 * INTEGER KNT, LMAX, NIN, NINFO
15 * REAL RMAX
16 * ..
17 *
18 *
19 *> \par Purpose:
20 * =============
21 *>
22 *> \verbatim
23 *>
24 *> CGET36 tests CTREXC, a routine for reordering diagonal entries of a
25 *> matrix in complex Schur form. Thus, CLAEXC computes a unitary matrix
26 *> Q such that
27 *>
28 *> Q' * T1 * Q = T2
29 *>
30 *> and where one of the diagonal blocks of T1 (the one at row IFST) has
31 *> been moved to position ILST.
32 *>
33 *> The test code verifies that the residual Q'*T1*Q-T2 is small, that T2
34 *> is in Schur form, and that the final position of the IFST block is
35 *> ILST.
36 *>
37 *> The test matrices are read from a file with logical unit number NIN.
38 *> \endverbatim
39 *
40 * Arguments:
41 * ==========
42 *
43 *> \param[out] RMAX
44 *> \verbatim
45 *> RMAX is REAL
46 *> Value of the largest test ratio.
47 *> \endverbatim
48 *>
49 *> \param[out] LMAX
50 *> \verbatim
51 *> LMAX is INTEGER
52 *> Example number where largest test ratio achieved.
53 *> \endverbatim
54 *>
55 *> \param[out] NINFO
56 *> \verbatim
57 *> NINFO is INTEGER
58 *> Number of examples where INFO is 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 *> \date November 2011
82 *
83 *> \ingroup complex_eig
84 *
85 * =====================================================================
86  SUBROUTINE cget36( RMAX, LMAX, NINFO, KNT, NIN )
87 *
88 * -- LAPACK test routine (version 3.4.0) --
89 * -- LAPACK is a software package provided by Univ. of Tennessee, --
90 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
91 * November 2011
92 *
93 * .. Scalar Arguments ..
94  INTEGER knt, lmax, nin, ninfo
95  REAL rmax
96 * ..
97 *
98 * =====================================================================
99 *
100 * .. Parameters ..
101  REAL zero, one
102  parameter( zero = 0.0e+0, one = 1.0e+0 )
103  COMPLEX czero, cone
104  parameter( czero = ( 0.0e+0, 0.0e+0 ),
105  $ cone = ( 1.0e+0, 0.0e+0 ) )
106  INTEGER ldt, lwork
107  parameter( ldt = 10, lwork = 2*ldt*ldt )
108 * ..
109 * .. Local Scalars ..
110  INTEGER i, ifst, ilst, info1, info2, j, n
111  REAL eps, res
112  COMPLEX ctemp
113 * ..
114 * .. Local Arrays ..
115  REAL result( 2 ), rwork( ldt )
116  COMPLEX diag( ldt ), q( ldt, ldt ), t1( ldt, ldt ),
117  $ t2( ldt, ldt ), tmp( ldt, ldt ), work( lwork )
118 * ..
119 * .. External Functions ..
120  REAL slamch
121  EXTERNAL slamch
122 * ..
123 * .. External Subroutines ..
124  EXTERNAL ccopy, chst01, clacpy, claset, ctrexc
125 * ..
126 * .. Executable Statements ..
127 *
128  eps = slamch( 'P' )
129  rmax = zero
130  lmax = 0
131  knt = 0
132  ninfo = 0
133 *
134 * Read input data until N=0
135 *
136  10 continue
137  READ( nin, fmt = * )n, ifst, ilst
138  IF( n.EQ.0 )
139  $ return
140  knt = knt + 1
141  DO 20 i = 1, n
142  READ( nin, fmt = * )( tmp( i, j ), j = 1, n )
143  20 continue
144  CALL clacpy( 'F', n, n, tmp, ldt, t1, ldt )
145  CALL clacpy( 'F', n, n, tmp, ldt, t2, ldt )
146  res = zero
147 *
148 * Test without accumulating Q
149 *
150  CALL claset( 'Full', n, n, czero, cone, q, ldt )
151  CALL ctrexc( 'N', n, t1, ldt, q, ldt, ifst, ilst, info1 )
152  DO 40 i = 1, n
153  DO 30 j = 1, n
154  IF( i.EQ.j .AND. q( i, j ).NE.cone )
155  $ res = res + one / eps
156  IF( i.NE.j .AND. q( i, j ).NE.czero )
157  $ res = res + one / eps
158  30 continue
159  40 continue
160 *
161 * Test with accumulating Q
162 *
163  CALL claset( 'Full', n, n, czero, cone, q, ldt )
164  CALL ctrexc( 'V', n, t2, ldt, q, ldt, ifst, ilst, info2 )
165 *
166 * Compare T1 with T2
167 *
168  DO 60 i = 1, n
169  DO 50 j = 1, n
170  IF( t1( i, j ).NE.t2( i, j ) )
171  $ res = res + one / eps
172  50 continue
173  60 continue
174  IF( info1.NE.0 .OR. info2.NE.0 )
175  $ ninfo = ninfo + 1
176  IF( info1.NE.info2 )
177  $ res = res + one / eps
178 *
179 * Test for successful reordering of T2
180 *
181  CALL ccopy( n, tmp, ldt+1, diag, 1 )
182  IF( ifst.LT.ilst ) THEN
183  DO 70 i = ifst + 1, ilst
184  ctemp = diag( i )
185  diag( i ) = diag( i-1 )
186  diag( i-1 ) = ctemp
187  70 continue
188  ELSE IF( ifst.GT.ilst ) THEN
189  DO 80 i = ifst - 1, ilst, -1
190  ctemp = diag( i+1 )
191  diag( i+1 ) = diag( i )
192  diag( i ) = ctemp
193  80 continue
194  END IF
195  DO 90 i = 1, n
196  IF( t2( i, i ).NE.diag( i ) )
197  $ res = res + one / eps
198  90 continue
199 *
200 * Test for small residual, and orthogonality of Q
201 *
202  CALL chst01( n, 1, n, tmp, ldt, t2, ldt, q, ldt, work, lwork,
203  $ rwork, result )
204  res = res + result( 1 ) + result( 2 )
205 *
206 * Test for T2 being in Schur form
207 *
208  DO 110 j = 1, n - 1
209  DO 100 i = j + 1, n
210  IF( t2( i, j ).NE.czero )
211  $ res = res + one / eps
212  100 continue
213  110 continue
214  IF( res.GT.rmax ) THEN
215  rmax = res
216  lmax = knt
217  END IF
218  go to 10
219 *
220 * End of CGET36
221 *
222  END