1 SUBROUTINE ZGET36( RMAX, LMAX, NINFO, KNT, NIN )
2 *
3 * -- LAPACK test routine (version 3.1) --
4 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
5 * November 2006
6 *
7 * .. Scalar Arguments ..
8 INTEGER KNT, LMAX, NIN, NINFO
9 DOUBLE PRECISION RMAX
10 * ..
11 *
12 * Purpose
13 * =======
14 *
15 * ZGET36 tests ZTREXC, a routine for reordering diagonal entries of a
16 * matrix in complex Schur form. Thus, ZLAEXC computes a unitary matrix
17 * Q such that
18 *
19 * Q' * T1 * Q = T2
20 *
21 * and where one of the diagonal blocks of T1 (the one at row IFST) has
22 * been moved to position ILST.
23 *
24 * The test code verifies that the residual Q'*T1*Q-T2 is small, that T2
25 * is in Schur form, and that the final position of the IFST block is
26 * ILST.
27 *
28 * The test matrices are read from a file with logical unit number NIN.
29 *
30 * Arguments
31 * ==========
32 *
33 * RMAX (output) DOUBLE PRECISION
34 * Value of the largest test ratio.
35 *
36 * LMAX (output) INTEGER
37 * Example number where largest test ratio achieved.
38 *
39 * NINFO (output) INTEGER
40 * Number of examples where INFO is nonzero.
41 *
42 * KNT (output) INTEGER
43 * Total number of examples tested.
44 *
45 * NIN (input) INTEGER
46 * Input logical unit number.
47 *
48 * =====================================================================
49 *
50 * .. Parameters ..
51 DOUBLE PRECISION ZERO, ONE
52 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
53 COMPLEX*16 CZERO, CONE
54 PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ),
55 $ CONE = ( 1.0D+0, 0.0D+0 ) )
56 INTEGER LDT, LWORK
57 PARAMETER ( LDT = 10, LWORK = 2*LDT*LDT )
58 * ..
59 * .. Local Scalars ..
60 INTEGER I, IFST, ILST, INFO1, INFO2, J, N
61 DOUBLE PRECISION EPS, RES
62 COMPLEX*16 CTEMP
63 * ..
64 * .. Local Arrays ..
65 DOUBLE PRECISION RESULT( 2 ), RWORK( LDT )
66 COMPLEX*16 DIAG( LDT ), Q( LDT, LDT ), T1( LDT, LDT ),
67 $ T2( LDT, LDT ), TMP( LDT, LDT ), WORK( LWORK )
68 * ..
69 * .. External Functions ..
70 DOUBLE PRECISION DLAMCH
71 EXTERNAL DLAMCH
72 * ..
73 * .. External Subroutines ..
74 EXTERNAL ZCOPY, ZHST01, ZLACPY, ZLASET, ZTREXC
75 * ..
76 * .. Executable Statements ..
77 *
78 EPS = DLAMCH( 'P' )
79 RMAX = ZERO
80 LMAX = 0
81 KNT = 0
82 NINFO = 0
83 *
84 * Read input data until N=0
85 *
86 10 CONTINUE
87 READ( NIN, FMT = * )N, IFST, ILST
88 IF( N.EQ.0 )
89 $ RETURN
90 KNT = KNT + 1
91 DO 20 I = 1, N
92 READ( NIN, FMT = * )( TMP( I, J ), J = 1, N )
93 20 CONTINUE
94 CALL ZLACPY( 'F', N, N, TMP, LDT, T1, LDT )
95 CALL ZLACPY( 'F', N, N, TMP, LDT, T2, LDT )
96 RES = ZERO
97 *
98 * Test without accumulating Q
99 *
100 CALL ZLASET( 'Full', N, N, CZERO, CONE, Q, LDT )
101 CALL ZTREXC( 'N', N, T1, LDT, Q, LDT, IFST, ILST, INFO1 )
102 DO 40 I = 1, N
103 DO 30 J = 1, N
104 IF( I.EQ.J .AND. Q( I, J ).NE.CONE )
105 $ RES = RES + ONE / EPS
106 IF( I.NE.J .AND. Q( I, J ).NE.CZERO )
107 $ RES = RES + ONE / EPS
108 30 CONTINUE
109 40 CONTINUE
110 *
111 * Test with accumulating Q
112 *
113 CALL ZLASET( 'Full', N, N, CZERO, CONE, Q, LDT )
114 CALL ZTREXC( 'V', N, T2, LDT, Q, LDT, IFST, ILST, INFO2 )
115 *
116 * Compare T1 with T2
117 *
118 DO 60 I = 1, N
119 DO 50 J = 1, N
120 IF( T1( I, J ).NE.T2( I, J ) )
121 $ RES = RES + ONE / EPS
122 50 CONTINUE
123 60 CONTINUE
124 IF( INFO1.NE.0 .OR. INFO2.NE.0 )
125 $ NINFO = NINFO + 1
126 IF( INFO1.NE.INFO2 )
127 $ RES = RES + ONE / EPS
128 *
129 * Test for successful reordering of T2
130 *
131 CALL ZCOPY( N, TMP, LDT+1, DIAG, 1 )
132 IF( IFST.LT.ILST ) THEN
133 DO 70 I = IFST + 1, ILST
134 CTEMP = DIAG( I )
135 DIAG( I ) = DIAG( I-1 )
136 DIAG( I-1 ) = CTEMP
137 70 CONTINUE
138 ELSE IF( IFST.GT.ILST ) THEN
139 DO 80 I = IFST - 1, ILST, -1
140 CTEMP = DIAG( I+1 )
141 DIAG( I+1 ) = DIAG( I )
142 DIAG( I ) = CTEMP
143 80 CONTINUE
144 END IF
145 DO 90 I = 1, N
146 IF( T2( I, I ).NE.DIAG( I ) )
147 $ RES = RES + ONE / EPS
148 90 CONTINUE
149 *
150 * Test for small residual, and orthogonality of Q
151 *
152 CALL ZHST01( N, 1, N, TMP, LDT, T2, LDT, Q, LDT, WORK, LWORK,
153 $ RWORK, RESULT )
154 RES = RES + RESULT( 1 ) + RESULT( 2 )
155 *
156 * Test for T2 being in Schur form
157 *
158 DO 110 J = 1, N - 1
159 DO 100 I = J + 1, N
160 IF( T2( I, J ).NE.CZERO )
161 $ RES = RES + ONE / EPS
162 100 CONTINUE
163 110 CONTINUE
164 IF( RES.GT.RMAX ) THEN
165 RMAX = RES
166 LMAX = KNT
167 END IF
168 GO TO 10
169 *
170 * End of ZGET36
171 *
172 END
2 *
3 * -- LAPACK test routine (version 3.1) --
4 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
5 * November 2006
6 *
7 * .. Scalar Arguments ..
8 INTEGER KNT, LMAX, NIN, NINFO
9 DOUBLE PRECISION RMAX
10 * ..
11 *
12 * Purpose
13 * =======
14 *
15 * ZGET36 tests ZTREXC, a routine for reordering diagonal entries of a
16 * matrix in complex Schur form. Thus, ZLAEXC computes a unitary matrix
17 * Q such that
18 *
19 * Q' * T1 * Q = T2
20 *
21 * and where one of the diagonal blocks of T1 (the one at row IFST) has
22 * been moved to position ILST.
23 *
24 * The test code verifies that the residual Q'*T1*Q-T2 is small, that T2
25 * is in Schur form, and that the final position of the IFST block is
26 * ILST.
27 *
28 * The test matrices are read from a file with logical unit number NIN.
29 *
30 * Arguments
31 * ==========
32 *
33 * RMAX (output) DOUBLE PRECISION
34 * Value of the largest test ratio.
35 *
36 * LMAX (output) INTEGER
37 * Example number where largest test ratio achieved.
38 *
39 * NINFO (output) INTEGER
40 * Number of examples where INFO is nonzero.
41 *
42 * KNT (output) INTEGER
43 * Total number of examples tested.
44 *
45 * NIN (input) INTEGER
46 * Input logical unit number.
47 *
48 * =====================================================================
49 *
50 * .. Parameters ..
51 DOUBLE PRECISION ZERO, ONE
52 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
53 COMPLEX*16 CZERO, CONE
54 PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ),
55 $ CONE = ( 1.0D+0, 0.0D+0 ) )
56 INTEGER LDT, LWORK
57 PARAMETER ( LDT = 10, LWORK = 2*LDT*LDT )
58 * ..
59 * .. Local Scalars ..
60 INTEGER I, IFST, ILST, INFO1, INFO2, J, N
61 DOUBLE PRECISION EPS, RES
62 COMPLEX*16 CTEMP
63 * ..
64 * .. Local Arrays ..
65 DOUBLE PRECISION RESULT( 2 ), RWORK( LDT )
66 COMPLEX*16 DIAG( LDT ), Q( LDT, LDT ), T1( LDT, LDT ),
67 $ T2( LDT, LDT ), TMP( LDT, LDT ), WORK( LWORK )
68 * ..
69 * .. External Functions ..
70 DOUBLE PRECISION DLAMCH
71 EXTERNAL DLAMCH
72 * ..
73 * .. External Subroutines ..
74 EXTERNAL ZCOPY, ZHST01, ZLACPY, ZLASET, ZTREXC
75 * ..
76 * .. Executable Statements ..
77 *
78 EPS = DLAMCH( 'P' )
79 RMAX = ZERO
80 LMAX = 0
81 KNT = 0
82 NINFO = 0
83 *
84 * Read input data until N=0
85 *
86 10 CONTINUE
87 READ( NIN, FMT = * )N, IFST, ILST
88 IF( N.EQ.0 )
89 $ RETURN
90 KNT = KNT + 1
91 DO 20 I = 1, N
92 READ( NIN, FMT = * )( TMP( I, J ), J = 1, N )
93 20 CONTINUE
94 CALL ZLACPY( 'F', N, N, TMP, LDT, T1, LDT )
95 CALL ZLACPY( 'F', N, N, TMP, LDT, T2, LDT )
96 RES = ZERO
97 *
98 * Test without accumulating Q
99 *
100 CALL ZLASET( 'Full', N, N, CZERO, CONE, Q, LDT )
101 CALL ZTREXC( 'N', N, T1, LDT, Q, LDT, IFST, ILST, INFO1 )
102 DO 40 I = 1, N
103 DO 30 J = 1, N
104 IF( I.EQ.J .AND. Q( I, J ).NE.CONE )
105 $ RES = RES + ONE / EPS
106 IF( I.NE.J .AND. Q( I, J ).NE.CZERO )
107 $ RES = RES + ONE / EPS
108 30 CONTINUE
109 40 CONTINUE
110 *
111 * Test with accumulating Q
112 *
113 CALL ZLASET( 'Full', N, N, CZERO, CONE, Q, LDT )
114 CALL ZTREXC( 'V', N, T2, LDT, Q, LDT, IFST, ILST, INFO2 )
115 *
116 * Compare T1 with T2
117 *
118 DO 60 I = 1, N
119 DO 50 J = 1, N
120 IF( T1( I, J ).NE.T2( I, J ) )
121 $ RES = RES + ONE / EPS
122 50 CONTINUE
123 60 CONTINUE
124 IF( INFO1.NE.0 .OR. INFO2.NE.0 )
125 $ NINFO = NINFO + 1
126 IF( INFO1.NE.INFO2 )
127 $ RES = RES + ONE / EPS
128 *
129 * Test for successful reordering of T2
130 *
131 CALL ZCOPY( N, TMP, LDT+1, DIAG, 1 )
132 IF( IFST.LT.ILST ) THEN
133 DO 70 I = IFST + 1, ILST
134 CTEMP = DIAG( I )
135 DIAG( I ) = DIAG( I-1 )
136 DIAG( I-1 ) = CTEMP
137 70 CONTINUE
138 ELSE IF( IFST.GT.ILST ) THEN
139 DO 80 I = IFST - 1, ILST, -1
140 CTEMP = DIAG( I+1 )
141 DIAG( I+1 ) = DIAG( I )
142 DIAG( I ) = CTEMP
143 80 CONTINUE
144 END IF
145 DO 90 I = 1, N
146 IF( T2( I, I ).NE.DIAG( I ) )
147 $ RES = RES + ONE / EPS
148 90 CONTINUE
149 *
150 * Test for small residual, and orthogonality of Q
151 *
152 CALL ZHST01( N, 1, N, TMP, LDT, T2, LDT, Q, LDT, WORK, LWORK,
153 $ RWORK, RESULT )
154 RES = RES + RESULT( 1 ) + RESULT( 2 )
155 *
156 * Test for T2 being in Schur form
157 *
158 DO 110 J = 1, N - 1
159 DO 100 I = J + 1, N
160 IF( T2( I, J ).NE.CZERO )
161 $ RES = RES + ONE / EPS
162 100 CONTINUE
163 110 CONTINUE
164 IF( RES.GT.RMAX ) THEN
165 RMAX = RES
166 LMAX = KNT
167 END IF
168 GO TO 10
169 *
170 * End of ZGET36
171 *
172 END