LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
cget35.f
Go to the documentation of this file.
1*> \brief \b CGET35
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 CGET35( 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*> CGET35 tests CTRSYL, a routine for solving the Sylvester matrix
25*> equation
26*>
27*> op(A)*X + ISGN*X*op(B) = scale*C,
28*>
29*> A and B are assumed to be in Schur canonical form, op() represents an
30*> optional transpose, and ISGN can be -1 or +1. Scale is an output
31*> less than or equal to 1, chosen to avoid overflow in X.
32*>
33*> The test code verifies that the following residual is order 1:
34*>
35*> norm(op(A)*X + ISGN*X*op(B) - scale*C) /
36*> (EPS*max(norm(A),norm(B))*norm(X))
37*> \endverbatim
38*
39* Arguments:
40* ==========
41*
42*> \param[out] RMAX
43*> \verbatim
44*> RMAX is REAL
45*> Value of the largest test ratio.
46*> \endverbatim
47*>
48*> \param[out] LMAX
49*> \verbatim
50*> LMAX is INTEGER
51*> Example number where largest test ratio achieved.
52*> \endverbatim
53*>
54*> \param[out] NINFO
55*> \verbatim
56*> NINFO is INTEGER
57*> Number of examples where INFO is nonzero.
58*> \endverbatim
59*>
60*> \param[out] KNT
61*> \verbatim
62*> KNT is INTEGER
63*> Total number of examples tested.
64*> \endverbatim
65*>
66*> \param[in] NIN
67*> \verbatim
68*> NIN is INTEGER
69*> Input logical unit number.
70*> \endverbatim
71*
72* Authors:
73* ========
74*
75*> \author Univ. of Tennessee
76*> \author Univ. of California Berkeley
77*> \author Univ. of Colorado Denver
78*> \author NAG Ltd.
79*
80*> \ingroup complex_eig
81*
82* =====================================================================
83 SUBROUTINE cget35( RMAX, LMAX, NINFO, KNT, NIN )
84*
85* -- LAPACK test routine --
86* -- LAPACK is a software package provided by Univ. of Tennessee, --
87* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
88*
89* .. Scalar Arguments ..
90 INTEGER KNT, LMAX, NIN, NINFO
91 REAL RMAX
92* ..
93*
94* =====================================================================
95*
96* .. Parameters ..
97 INTEGER LDT
98 parameter( ldt = 10 )
99 REAL ZERO, ONE, TWO
100 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0 )
101 REAL LARGE
102 parameter( large = 1.0e6 )
103 COMPLEX CONE
104 parameter( cone = 1.0e0 )
105* ..
106* .. Local Scalars ..
107 CHARACTER TRANA, TRANB
108 INTEGER I, IMLA, IMLAD, IMLB, IMLC, INFO, ISGN, ITRANA,
109 $ ITRANB, J, M, N
110 REAL BIGNUM, EPS, RES, RES1, SCALE, SMLNUM, TNRM,
111 $ XNRM
112 COMPLEX RMUL
113* ..
114* .. Local Arrays ..
115 REAL DUM( 1 ), VM1( 3 ), VM2( 3 )
116 COMPLEX A( LDT, LDT ), ATMP( LDT, LDT ), B( LDT, LDT ),
117 $ BTMP( LDT, LDT ), C( LDT, LDT ),
118 $ CSAV( LDT, LDT ), CTMP( LDT, LDT )
119* ..
120* .. External Functions ..
121 REAL CLANGE, SLAMCH
122 EXTERNAL clange, slamch
123* ..
124* .. External Subroutines ..
125 EXTERNAL cgemm, ctrsyl
126* ..
127* .. Intrinsic Functions ..
128 INTRINSIC abs, max, real, sqrt
129* ..
130* .. Executable Statements ..
131*
132* Get machine parameters
133*
134 eps = slamch( 'P' )
135 smlnum = slamch( 'S' ) / eps
136 bignum = one / smlnum
137*
138* Set up test case parameters
139*
140 vm1( 1 ) = sqrt( smlnum )
141 vm1( 2 ) = one
142 vm1( 3 ) = large
143 vm2( 1 ) = one
144 vm2( 2 ) = one + two*eps
145 vm2( 3 ) = two
146*
147 knt = 0
148 ninfo = 0
149 lmax = 0
150 rmax = zero
151*
152* Begin test loop
153*
154 10 CONTINUE
155 READ( nin, fmt = * )m, n
156 IF( n.EQ.0 )
157 $ RETURN
158 DO 20 i = 1, m
159 READ( nin, fmt = * )( atmp( i, j ), j = 1, m )
160 20 CONTINUE
161 DO 30 i = 1, n
162 READ( nin, fmt = * )( btmp( i, j ), j = 1, n )
163 30 CONTINUE
164 DO 40 i = 1, m
165 READ( nin, fmt = * )( ctmp( i, j ), j = 1, n )
166 40 CONTINUE
167 DO 170 imla = 1, 3
168 DO 160 imlad = 1, 3
169 DO 150 imlb = 1, 3
170 DO 140 imlc = 1, 3
171 DO 130 itrana = 1, 2
172 DO 120 itranb = 1, 2
173 DO 110 isgn = -1, 1, 2
174 IF( itrana.EQ.1 )
175 $ trana = 'N'
176 IF( itrana.EQ.2 )
177 $ trana = 'C'
178 IF( itranb.EQ.1 )
179 $ tranb = 'N'
180 IF( itranb.EQ.2 )
181 $ tranb = 'C'
182 tnrm = zero
183 DO 60 i = 1, m
184 DO 50 j = 1, m
185 a( i, j ) = atmp( i, j )*vm1( imla )
186 tnrm = max( tnrm, abs( a( i, j ) ) )
187 50 CONTINUE
188 a( i, i ) = a( i, i )*vm2( imlad )
189 tnrm = max( tnrm, abs( a( i, i ) ) )
190 60 CONTINUE
191 DO 80 i = 1, n
192 DO 70 j = 1, n
193 b( i, j ) = btmp( i, j )*vm1( imlb )
194 tnrm = max( tnrm, abs( b( i, j ) ) )
195 70 CONTINUE
196 80 CONTINUE
197 IF( tnrm.EQ.zero )
198 $ tnrm = one
199 DO 100 i = 1, m
200 DO 90 j = 1, n
201 c( i, j ) = ctmp( i, j )*vm1( imlc )
202 csav( i, j ) = c( i, j )
203 90 CONTINUE
204 100 CONTINUE
205 knt = knt + 1
206 CALL ctrsyl( trana, tranb, isgn, m, n, a,
207 $ ldt, b, ldt, c, ldt, scale,
208 $ info )
209 IF( info.NE.0 )
210 $ ninfo = ninfo + 1
211 xnrm = clange( 'M', m, n, c, ldt, dum )
212 rmul = cone
213 IF( xnrm.GT.one .AND. tnrm.GT.one ) THEN
214 IF( xnrm.GT.bignum / tnrm ) THEN
215 rmul = max( xnrm, tnrm )
216 rmul = cone / rmul
217 END IF
218 END IF
219 CALL cgemm( trana, 'N', m, n, m, rmul, a,
220 $ ldt, c, ldt, -scale*rmul, csav,
221 $ ldt )
222 CALL cgemm( 'N', tranb, m, n, n,
223 $ real( isgn )*rmul, c, ldt, b,
224 $ ldt, cone, csav, ldt )
225 res1 = clange( 'M', m, n, csav, ldt, dum )
226 res = res1 / max( smlnum, smlnum*xnrm,
227 $ ( ( abs( rmul )*tnrm )*eps )*xnrm )
228 IF( res.GT.rmax ) THEN
229 lmax = knt
230 rmax = res
231 END IF
232 110 CONTINUE
233 120 CONTINUE
234 130 CONTINUE
235 140 CONTINUE
236 150 CONTINUE
237 160 CONTINUE
238 170 CONTINUE
239 GO TO 10
240*
241* End of CGET35
242*
243 END
subroutine cget35(rmax, lmax, ninfo, knt, nin)
CGET35
Definition cget35.f:84
subroutine cgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
CGEMM
Definition cgemm.f:188
subroutine ctrsyl(trana, tranb, isgn, m, n, a, lda, b, ldb, c, ldc, scale, info)
CTRSYL
Definition ctrsyl.f:157