LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ cget36()

subroutine cget36 ( real  RMAX,
integer  LMAX,
integer  NINFO,
integer  KNT,
integer  NIN 
)

CGET36

Purpose:
 CGET36 tests CTREXC, a routine for reordering diagonal entries of a
 matrix in complex Schur form. Thus, CLAEXC computes a unitary 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.

 The test matrices are read from a file with logical unit number NIN.
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.
[in]NIN
          NIN is INTEGER
          Input logical unit number.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 84 of file cget36.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, 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 *
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 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
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: