LAPACK  3.8.0
LAPACK: Linear Algebra PACKage

◆ zget36()

subroutine zget36 ( double precision  RMAX,
integer  LMAX,
integer  NINFO,
integer  KNT,
integer  NIN 
)

ZGET36

Purpose:
 ZGET36 tests ZTREXC, a routine for reordering diagonal entries of a
 matrix in complex Schur form. Thus, ZLAEXC 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 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
          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 zget36.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  DOUBLE PRECISION rmax
96 * ..
97 *
98 * =====================================================================
99 *
100 * .. Parameters ..
101  DOUBLE PRECISION zero, one
102  parameter( zero = 0.0d+0, one = 1.0d+0 )
103  COMPLEX*16 czero, cone
104  parameter( czero = ( 0.0d+0, 0.0d+0 ),
105  $ cone = ( 1.0d+0, 0.0d+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  DOUBLE PRECISION eps, res
112  COMPLEX*16 ctemp
113 * ..
114 * .. Local Arrays ..
115  DOUBLE PRECISION result( 2 ), rwork( ldt )
116  COMPLEX*16 diag( ldt ), q( ldt, ldt ), t1( ldt, ldt ),
117  $ t2( ldt, ldt ), tmp( ldt, ldt ), work( lwork )
118 * ..
119 * .. External Functions ..
120  DOUBLE PRECISION dlamch
121  EXTERNAL dlamch
122 * ..
123 * .. External Subroutines ..
124  EXTERNAL zcopy, zhst01, zlacpy, zlaset, ztrexc
125 * ..
126 * .. Executable Statements ..
127 *
128  eps = dlamch( '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 zlacpy( 'F', n, n, tmp, ldt, t1, ldt )
145  CALL zlacpy( 'F', n, n, tmp, ldt, t2, ldt )
146  res = zero
147 *
148 * Test without accumulating Q
149 *
150  CALL zlaset( 'Full', n, n, czero, cone, q, ldt )
151  CALL ztrexc( '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 zlaset( 'Full', n, n, czero, cone, q, ldt )
164  CALL ztrexc( '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 zcopy( 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 zhst01( 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 ZGET36
221 *
double precision function dlamch(CMACH)
DLAMCH
Definition: dlamch.f:65
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
Definition: zcopy.f:83
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
Definition: zlacpy.f:105
subroutine zlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
Definition: zlaset.f:108
subroutine zhst01(N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, LWORK, RWORK, RESULT)
ZHST01
Definition: zhst01.f:142
subroutine ztrexc(COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO)
ZTREXC
Definition: ztrexc.f:128
Here is the call graph for this function:
Here is the caller graph for this function: