LAPACK  3.8.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.
Date
December 2016

Definition at line 87 of file cget36.f.

87 *
88 * -- LAPACK test routine (version 3.7.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 * December 2016
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 *
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:108
real function slamch(CMACH)
SLAMCH
Definition: slamch.f:69
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
Definition: clacpy.f:105
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
Definition: ccopy.f:83
subroutine ctrexc(COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO)
CTREXC
Definition: ctrexc.f:128
subroutine chst01(N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, LWORK, RWORK, RESULT)
CHST01
Definition: chst01.f:142
Here is the call graph for this function:
Here is the caller graph for this function: