LAPACK 3.11.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
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*> \ingroup complex_eig
82*
83* =====================================================================
84 SUBROUTINE cget36( RMAX, LMAX, NINFO, KNT, NIN )
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, NINFO
92 REAL RMAX
93* ..
94*
95* =====================================================================
96*
97* .. Parameters ..
98 REAL ZERO, ONE
99 parameter( zero = 0.0e+0, one = 1.0e+0 )
100 COMPLEX CZERO, CONE
101 parameter( czero = ( 0.0e+0, 0.0e+0 ),
102 $ cone = ( 1.0e+0, 0.0e+0 ) )
103 INTEGER LDT, LWORK
104 parameter( ldt = 10, lwork = 2*ldt*ldt )
105* ..
106* .. Local Scalars ..
107 INTEGER I, IFST, ILST, INFO1, INFO2, J, N
108 REAL EPS, RES
109 COMPLEX CTEMP
110* ..
111* .. Local Arrays ..
112 REAL RESULT( 2 ), RWORK( LDT )
113 COMPLEX DIAG( LDT ), Q( LDT, LDT ), T1( LDT, LDT ),
114 $ T2( LDT, LDT ), TMP( LDT, LDT ), WORK( LWORK )
115* ..
116* .. External Functions ..
117 REAL SLAMCH
118 EXTERNAL slamch
119* ..
120* .. External Subroutines ..
121 EXTERNAL ccopy, chst01, clacpy, claset, ctrexc
122* ..
123* .. Executable Statements ..
124*
125 eps = slamch( 'P' )
126 rmax = zero
127 lmax = 0
128 knt = 0
129 ninfo = 0
130*
131* Read input data until N=0
132*
133 10 CONTINUE
134 READ( nin, fmt = * )n, ifst, ilst
135 IF( n.EQ.0 )
136 $ RETURN
137 knt = knt + 1
138 DO 20 i = 1, n
139 READ( nin, fmt = * )( tmp( i, j ), j = 1, n )
140 20 CONTINUE
141 CALL clacpy( 'F', n, n, tmp, ldt, t1, ldt )
142 CALL clacpy( 'F', n, n, tmp, ldt, t2, ldt )
143 res = zero
144*
145* Test without accumulating Q
146*
147 CALL claset( 'Full', n, n, czero, cone, q, ldt )
148 CALL ctrexc( 'N', n, t1, ldt, q, ldt, ifst, ilst, info1 )
149 DO 40 i = 1, n
150 DO 30 j = 1, n
151 IF( i.EQ.j .AND. q( i, j ).NE.cone )
152 $ res = res + one / eps
153 IF( i.NE.j .AND. q( i, j ).NE.czero )
154 $ res = res + one / eps
155 30 CONTINUE
156 40 CONTINUE
157*
158* Test with accumulating Q
159*
160 CALL claset( 'Full', n, n, czero, cone, q, ldt )
161 CALL ctrexc( 'V', n, t2, ldt, q, ldt, ifst, ilst, info2 )
162*
163* Compare T1 with T2
164*
165 DO 60 i = 1, n
166 DO 50 j = 1, n
167 IF( t1( i, j ).NE.t2( i, j ) )
168 $ res = res + one / eps
169 50 CONTINUE
170 60 CONTINUE
171 IF( info1.NE.0 .OR. info2.NE.0 )
172 $ ninfo = ninfo + 1
173 IF( info1.NE.info2 )
174 $ res = res + one / eps
175*
176* Test for successful reordering of T2
177*
178 CALL ccopy( n, tmp, ldt+1, diag, 1 )
179 IF( ifst.LT.ilst ) THEN
180 DO 70 i = ifst + 1, ilst
181 ctemp = diag( i )
182 diag( i ) = diag( i-1 )
183 diag( i-1 ) = ctemp
184 70 CONTINUE
185 ELSE IF( ifst.GT.ilst ) THEN
186 DO 80 i = ifst - 1, ilst, -1
187 ctemp = diag( i+1 )
188 diag( i+1 ) = diag( i )
189 diag( i ) = ctemp
190 80 CONTINUE
191 END IF
192 DO 90 i = 1, n
193 IF( t2( i, i ).NE.diag( i ) )
194 $ res = res + one / eps
195 90 CONTINUE
196*
197* Test for small residual, and orthogonality of Q
198*
199 CALL chst01( n, 1, n, tmp, ldt, t2, ldt, q, ldt, work, lwork,
200 $ rwork, result )
201 res = res + result( 1 ) + result( 2 )
202*
203* Test for T2 being in Schur form
204*
205 DO 110 j = 1, n - 1
206 DO 100 i = j + 1, n
207 IF( t2( i, j ).NE.czero )
208 $ res = res + one / eps
209 100 CONTINUE
210 110 CONTINUE
211 IF( res.GT.rmax ) THEN
212 rmax = res
213 lmax = knt
214 END IF
215 GO TO 10
216*
217* End of CGET36
218*
219 END
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
Definition: ccopy.f:81
subroutine chst01(N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, LWORK, RWORK, RESULT)
CHST01
Definition: chst01.f:140
subroutine cget36(RMAX, LMAX, NINFO, KNT, NIN)
CGET36
Definition: cget36.f:85
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition: claset.f:106
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
Definition: clacpy.f:103
subroutine ctrexc(COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO)
CTREXC
Definition: ctrexc.f:126