LAPACK  3.5.0
LAPACK: Linear Algebra PACKage
 All Classes Files Functions Variables Typedefs Macros
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 *> \date November 2011
81 *
82 *> \ingroup complex_eig
83 *
84 * =====================================================================
85  SUBROUTINE cget35( RMAX, LMAX, NINFO, KNT, NIN )
86 *
87 * -- LAPACK test routine (version 3.4.0) --
88 * -- LAPACK is a software package provided by Univ. of Tennessee, --
89 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
90 * November 2011
91 *
92 * .. Scalar Arguments ..
93  INTEGER knt, lmax, nin, ninfo
94  REAL rmax
95 * ..
96 *
97 * =====================================================================
98 *
99 * .. Parameters ..
100  INTEGER ldt
101  parameter( ldt = 10 )
102  REAL zero, one, two
103  parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0 )
104  REAL large
105  parameter( large = 1.0e6 )
106  COMPLEX cone
107  parameter( cone = 1.0e0 )
108 * ..
109 * .. Local Scalars ..
110  CHARACTER trana, tranb
111  INTEGER i, imla, imlad, imlb, imlc, info, isgn, itrana,
112  $ itranb, j, m, n
113  REAL bignum, eps, res, res1, scale, smlnum, tnrm,
114  $ xnrm
115  COMPLEX rmul
116 * ..
117 * .. Local Arrays ..
118  REAL dum( 1 ), vm1( 3 ), vm2( 3 )
119  COMPLEX a( ldt, ldt ), atmp( ldt, ldt ), b( ldt, ldt ),
120  $ btmp( ldt, ldt ), c( ldt, ldt ),
121  $ csav( ldt, ldt ), ctmp( ldt, ldt )
122 * ..
123 * .. External Functions ..
124  REAL clange, slamch
125  EXTERNAL clange, slamch
126 * ..
127 * .. External Subroutines ..
128  EXTERNAL cgemm, ctrsyl
129 * ..
130 * .. Intrinsic Functions ..
131  INTRINSIC abs, max, REAL, sqrt
132 * ..
133 * .. Executable Statements ..
134 *
135 * Get machine parameters
136 *
137  eps = slamch( 'P' )
138  smlnum = slamch( 'S' ) / eps
139  bignum = one / smlnum
140  CALL slabad( smlnum, bignum )
141 *
142 * Set up test case parameters
143 *
144  vm1( 1 ) = sqrt( smlnum )
145  vm1( 2 ) = one
146  vm1( 3 ) = large
147  vm2( 1 ) = one
148  vm2( 2 ) = one + two*eps
149  vm2( 3 ) = two
150 *
151  knt = 0
152  ninfo = 0
153  lmax = 0
154  rmax = zero
155 *
156 * Begin test loop
157 *
158  10 CONTINUE
159  READ( nin, fmt = * )m, n
160  IF( n.EQ.0 )
161  $ RETURN
162  DO 20 i = 1, m
163  READ( nin, fmt = * )( atmp( i, j ), j = 1, m )
164  20 CONTINUE
165  DO 30 i = 1, n
166  READ( nin, fmt = * )( btmp( i, j ), j = 1, n )
167  30 CONTINUE
168  DO 40 i = 1, m
169  READ( nin, fmt = * )( ctmp( i, j ), j = 1, n )
170  40 CONTINUE
171  DO 170 imla = 1, 3
172  DO 160 imlad = 1, 3
173  DO 150 imlb = 1, 3
174  DO 140 imlc = 1, 3
175  DO 130 itrana = 1, 2
176  DO 120 itranb = 1, 2
177  DO 110 isgn = -1, 1, 2
178  IF( itrana.EQ.1 )
179  $ trana = 'N'
180  IF( itrana.EQ.2 )
181  $ trana = 'C'
182  IF( itranb.EQ.1 )
183  $ tranb = 'N'
184  IF( itranb.EQ.2 )
185  $ tranb = 'C'
186  tnrm = zero
187  DO 60 i = 1, m
188  DO 50 j = 1, m
189  a( i, j ) = atmp( i, j )*vm1( imla )
190  tnrm = max( tnrm, abs( a( i, j ) ) )
191  50 CONTINUE
192  a( i, i ) = a( i, i )*vm2( imlad )
193  tnrm = max( tnrm, abs( a( i, i ) ) )
194  60 CONTINUE
195  DO 80 i = 1, n
196  DO 70 j = 1, n
197  b( i, j ) = btmp( i, j )*vm1( imlb )
198  tnrm = max( tnrm, abs( b( i, j ) ) )
199  70 CONTINUE
200  80 CONTINUE
201  IF( tnrm.EQ.zero )
202  $ tnrm = one
203  DO 100 i = 1, m
204  DO 90 j = 1, n
205  c( i, j ) = ctmp( i, j )*vm1( imlc )
206  csav( i, j ) = c( i, j )
207  90 CONTINUE
208  100 CONTINUE
209  knt = knt + 1
210  CALL ctrsyl( trana, tranb, isgn, m, n, a,
211  $ ldt, b, ldt, c, ldt, scale,
212  $ info )
213  IF( info.NE.0 )
214  $ ninfo = ninfo + 1
215  xnrm = clange( 'M', m, n, c, ldt, dum )
216  rmul = cone
217  IF( xnrm.GT.one .AND. tnrm.GT.one ) THEN
218  IF( xnrm.GT.bignum / tnrm ) THEN
219  rmul = max( xnrm, tnrm )
220  rmul = cone / rmul
221  END IF
222  END IF
223  CALL cgemm( trana, 'N', m, n, m, rmul, a,
224  $ ldt, c, ldt, -scale*rmul, csav,
225  $ ldt )
226  CALL cgemm( 'N', tranb, m, n, n,
227  $ REAL( isgn )*rmul, c, ldt, b,
228  $ ldt, cone, csav, ldt )
229  res1 = clange( 'M', m, n, csav, ldt, dum )
230  res = res1 / max( smlnum, smlnum*xnrm,
231  $ ( ( abs( rmul )*tnrm )*eps )*xnrm )
232  IF( res.GT.rmax ) THEN
233  lmax = knt
234  rmax = res
235  END IF
236  110 CONTINUE
237  120 CONTINUE
238  130 CONTINUE
239  140 CONTINUE
240  150 CONTINUE
241  160 CONTINUE
242  170 CONTINUE
243  go to 10
244 *
245 * End of CGET35
246 *
247  END