LAPACK  3.5.0
LAPACK: Linear Algebra PACKage
 All Classes Files Functions Variables Typedefs Macros
sget35.f
Go to the documentation of this file.
1 *> \brief \b SGET35
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 SGET35( RMAX, LMAX, NINFO, KNT )
12 *
13 * .. Scalar Arguments ..
14 * INTEGER KNT, LMAX, NINFO
15 * REAL RMAX
16 * ..
17 *
18 *
19 *> \par Purpose:
20 * =============
21 *>
22 *> \verbatim
23 *>
24 *> SGET35 tests STRSYL, 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 * Authors:
67 * ========
68 *
69 *> \author Univ. of Tennessee
70 *> \author Univ. of California Berkeley
71 *> \author Univ. of Colorado Denver
72 *> \author NAG Ltd.
73 *
74 *> \date November 2011
75 *
76 *> \ingroup single_eig
77 *
78 * =====================================================================
79  SUBROUTINE sget35( RMAX, LMAX, NINFO, KNT )
80 *
81 * -- LAPACK test routine (version 3.4.0) --
82 * -- LAPACK is a software package provided by Univ. of Tennessee, --
83 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
84 * November 2011
85 *
86 * .. Scalar Arguments ..
87  INTEGER knt, lmax, ninfo
88  REAL rmax
89 * ..
90 *
91 * =====================================================================
92 *
93 * .. Parameters ..
94  REAL zero, one
95  parameter( zero = 0.0e0, one = 1.0e0 )
96  REAL two, four
97  parameter( two = 2.0e0, four = 4.0e0 )
98 * ..
99 * .. Local Scalars ..
100  CHARACTER trana, tranb
101  INTEGER i, ima, imb, imlda1, imlda2, imldb1, imloff,
102  $ info, isgn, itrana, itranb, j, m, n
103  REAL bignum, cnrm, eps, res, res1, rmul, scale,
104  $ smlnum, tnrm, xnrm
105 * ..
106 * .. Local Arrays ..
107  INTEGER idim( 8 ), ival( 6, 6, 8 )
108  REAL a( 6, 6 ), b( 6, 6 ), c( 6, 6 ), cc( 6, 6 ),
109  $ dum( 1 ), vm1( 3 ), vm2( 3 )
110 * ..
111 * .. External Functions ..
112  REAL slamch, slange
113  EXTERNAL slamch, slange
114 * ..
115 * .. External Subroutines ..
116  EXTERNAL sgemm, strsyl
117 * ..
118 * .. Intrinsic Functions ..
119  INTRINSIC abs, max, REAL, sin, sqrt
120 * ..
121 * .. Data statements ..
122  DATA idim / 1, 2, 3, 4, 3, 3, 6, 4 /
123  DATA ival / 1, 35*0, 1, 2, 4*0, -2, 0, 28*0, 1, 5*0,
124  $ 5, 1, 2, 3*0, -8, -2, 1, 21*0, 3, 4, 4*0, -5,
125  $ 3, 4*0, 1, 2, 1, 4, 2*0, -3, -9, -1, 1, 14*0,
126  $ 1, 5*0, 2, 3, 4*0, 5, 6, 7, 21*0, 1, 5*0, 1, 3,
127  $ -4, 3*0, 2, 5, 2, 21*0, 1, 2, 4*0, -2, 0, 4*0,
128  $ 5, 6, 3, 4, 2*0, -1, -9, -5, 2, 2*0, 4*8, 5, 6,
129  $ 4*9, -7, 5, 1, 5*0, 1, 5, 2, 3*0, 2, -21, 5,
130  $ 3*0, 1, 2, 3, 4, 14*0 /
131 * ..
132 * .. Executable Statements ..
133 *
134 * Get machine parameters
135 *
136  eps = slamch( 'P' )
137  smlnum = slamch( 'S' )*four / eps
138  bignum = one / smlnum
139  CALL slabad( smlnum, bignum )
140 *
141 * Set up test case parameters
142 *
143  vm1( 1 ) = sqrt( smlnum )
144  vm1( 2 ) = one
145  vm1( 3 ) = sqrt( bignum )
146  vm2( 1 ) = one
147  vm2( 2 ) = one + two*eps
148  vm2( 3 ) = two
149 *
150  knt = 0
151  ninfo = 0
152  lmax = 0
153  rmax = zero
154 *
155 * Begin test loop
156 *
157  DO 150 itrana = 1, 2
158  DO 140 itranb = 1, 2
159  DO 130 isgn = -1, 1, 2
160  DO 120 ima = 1, 8
161  DO 110 imlda1 = 1, 3
162  DO 100 imlda2 = 1, 3
163  DO 90 imloff = 1, 2
164  DO 80 imb = 1, 8
165  DO 70 imldb1 = 1, 3
166  IF( itrana.EQ.1 )
167  $ trana = 'N'
168  IF( itrana.EQ.2 )
169  $ trana = 'T'
170  IF( itranb.EQ.1 )
171  $ tranb = 'N'
172  IF( itranb.EQ.2 )
173  $ tranb = 'T'
174  m = idim( ima )
175  n = idim( imb )
176  tnrm = zero
177  DO 20 i = 1, m
178  DO 10 j = 1, m
179  a( i, j ) = ival( i, j, ima )
180  IF( abs( i-j ).LE.1 ) THEN
181  a( i, j ) = a( i, j )*
182  $ vm1( imlda1 )
183  a( i, j ) = a( i, j )*
184  $ vm2( imlda2 )
185  ELSE
186  a( i, j ) = a( i, j )*
187  $ vm1( imloff )
188  END IF
189  tnrm = max( tnrm,
190  $ abs( a( i, j ) ) )
191  10 CONTINUE
192  20 CONTINUE
193  DO 40 i = 1, n
194  DO 30 j = 1, n
195  b( i, j ) = ival( i, j, imb )
196  IF( abs( i-j ).LE.1 ) THEN
197  b( i, j ) = b( i, j )*
198  $ vm1( imldb1 )
199  ELSE
200  b( i, j ) = b( i, j )*
201  $ vm1( imloff )
202  END IF
203  tnrm = max( tnrm,
204  $ abs( b( i, j ) ) )
205  30 CONTINUE
206  40 CONTINUE
207  cnrm = zero
208  DO 60 i = 1, m
209  DO 50 j = 1, n
210  c( i, j ) = sin( REAL( I*J ) )
211  cnrm = max( cnrm, c( i, j ) )
212  cc( i, j ) = c( i, j )
213  50 CONTINUE
214  60 CONTINUE
215  knt = knt + 1
216  CALL strsyl( trana, tranb, isgn, m, n,
217  $ a, 6, b, 6, c, 6, scale,
218  $ info )
219  IF( info.NE.0 )
220  $ ninfo = ninfo + 1
221  xnrm = slange( 'M', m, n, c, 6, dum )
222  rmul = one
223  IF( xnrm.GT.one .AND. tnrm.GT.one )
224  $ THEN
225  IF( xnrm.GT.bignum / tnrm ) THEN
226  rmul = one / max( xnrm, tnrm )
227  END IF
228  END IF
229  CALL sgemm( trana, 'N', m, n, m, rmul,
230  $ a, 6, c, 6, -scale*rmul,
231  $ cc, 6 )
232  CALL sgemm( 'N', tranb, m, n, n,
233  $ REAL( isgn )*rmul, c, 6, b,
234  $ 6, one, cc, 6 )
235  res1 = slange( 'M', m, n, cc, 6, dum )
236  res = res1 / max( smlnum, smlnum*xnrm,
237  $ ( ( rmul*tnrm )*eps )*xnrm )
238  IF( res.GT.rmax ) THEN
239  lmax = knt
240  rmax = res
241  END IF
242  70 CONTINUE
243  80 CONTINUE
244  90 CONTINUE
245  100 CONTINUE
246  110 CONTINUE
247  120 CONTINUE
248  130 CONTINUE
249  140 CONTINUE
250  150 CONTINUE
251 *
252  RETURN
253 *
254 * End of SGET35
255 *
256  END