LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
derrec.f
Go to the documentation of this file.
1 *> \brief \b DERREC
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 DERREC( PATH, NUNIT )
12 *
13 * .. Scalar Arguments ..
14 * CHARACTER*3 PATH
15 * INTEGER NUNIT
16 * ..
17 *
18 *
19 *> \par Purpose:
20 * =============
21 *>
22 *> \verbatim
23 *>
24 *> DERREC tests the error exits for the routines for eigen- condition
25 *> estimation for DOUBLE PRECISION matrices:
26 *> DTRSYL, STREXC, STRSNA and STRSEN.
27 *> \endverbatim
28 *
29 * Arguments:
30 * ==========
31 *
32 *> \param[in] PATH
33 *> \verbatim
34 *> PATH is CHARACTER*3
35 *> The LAPACK path name for the routines to be tested.
36 *> \endverbatim
37 *>
38 *> \param[in] NUNIT
39 *> \verbatim
40 *> NUNIT is INTEGER
41 *> The unit number for output.
42 *> \endverbatim
43 *
44 * Authors:
45 * ========
46 *
47 *> \author Univ. of Tennessee
48 *> \author Univ. of California Berkeley
49 *> \author Univ. of Colorado Denver
50 *> \author NAG Ltd.
51 *
52 *> \date November 2011
53 *
54 *> \ingroup double_eig
55 *
56 * =====================================================================
57  SUBROUTINE derrec( PATH, NUNIT )
58 *
59 * -- LAPACK test routine (version 3.4.0) --
60 * -- LAPACK is a software package provided by Univ. of Tennessee, --
61 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
62 * November 2011
63 *
64 * .. Scalar Arguments ..
65  CHARACTER*3 PATH
66  INTEGER NUNIT
67 * ..
68 *
69 * =====================================================================
70 *
71 * .. Parameters ..
72  INTEGER NMAX
73  DOUBLE PRECISION ONE, ZERO
74  parameter ( nmax = 4, one = 1.0d0, zero = 0.0d0 )
75 * ..
76 * .. Local Scalars ..
77  INTEGER I, IFST, ILST, INFO, J, M, NT
78  DOUBLE PRECISION SCALE
79 * ..
80 * .. Local Arrays ..
81  LOGICAL SEL( nmax )
82  INTEGER IWORK( nmax )
83  DOUBLE PRECISION A( nmax, nmax ), B( nmax, nmax ),
84  $ c( nmax, nmax ), s( nmax ), sep( nmax ),
85  $ wi( nmax ), work( nmax ), wr( nmax )
86 * ..
87 * .. External Subroutines ..
88  EXTERNAL chkxer, dtrexc, dtrsen, dtrsna, dtrsyl
89 * ..
90 * .. Scalars in Common ..
91  LOGICAL LERR, OK
92  CHARACTER*32 SRNAMT
93  INTEGER INFOT, NOUT
94 * ..
95 * .. Common blocks ..
96  COMMON / infoc / infot, nout, ok, lerr
97  COMMON / srnamc / srnamt
98 * ..
99 * .. Executable Statements ..
100 *
101  nout = nunit
102  ok = .true.
103  nt = 0
104 *
105 * Initialize A, B and SEL
106 *
107  DO 20 j = 1, nmax
108  DO 10 i = 1, nmax
109  a( i, j ) = zero
110  b( i, j ) = zero
111  10 CONTINUE
112  20 CONTINUE
113  DO 30 i = 1, nmax
114  a( i, i ) = one
115  sel( i ) = .true.
116  30 CONTINUE
117 *
118 * Test DTRSYL
119 *
120  srnamt = 'DTRSYL'
121  infot = 1
122  CALL dtrsyl( 'X', 'N', 1, 0, 0, a, 1, b, 1, c, 1, scale, info )
123  CALL chkxer( 'DTRSYL', infot, nout, lerr, ok )
124  infot = 2
125  CALL dtrsyl( 'N', 'X', 1, 0, 0, a, 1, b, 1, c, 1, scale, info )
126  CALL chkxer( 'DTRSYL', infot, nout, lerr, ok )
127  infot = 3
128  CALL dtrsyl( 'N', 'N', 0, 0, 0, a, 1, b, 1, c, 1, scale, info )
129  CALL chkxer( 'DTRSYL', infot, nout, lerr, ok )
130  infot = 4
131  CALL dtrsyl( 'N', 'N', 1, -1, 0, a, 1, b, 1, c, 1, scale, info )
132  CALL chkxer( 'DTRSYL', infot, nout, lerr, ok )
133  infot = 5
134  CALL dtrsyl( 'N', 'N', 1, 0, -1, a, 1, b, 1, c, 1, scale, info )
135  CALL chkxer( 'DTRSYL', infot, nout, lerr, ok )
136  infot = 7
137  CALL dtrsyl( 'N', 'N', 1, 2, 0, a, 1, b, 1, c, 2, scale, info )
138  CALL chkxer( 'DTRSYL', infot, nout, lerr, ok )
139  infot = 9
140  CALL dtrsyl( 'N', 'N', 1, 0, 2, a, 1, b, 1, c, 1, scale, info )
141  CALL chkxer( 'DTRSYL', infot, nout, lerr, ok )
142  infot = 11
143  CALL dtrsyl( 'N', 'N', 1, 2, 0, a, 2, b, 1, c, 1, scale, info )
144  CALL chkxer( 'DTRSYL', infot, nout, lerr, ok )
145  nt = nt + 8
146 *
147 * Test DTREXC
148 *
149  srnamt = 'DTREXC'
150  ifst = 1
151  ilst = 1
152  infot = 1
153  CALL dtrexc( 'X', 1, a, 1, b, 1, ifst, ilst, work, info )
154  CALL chkxer( 'DTREXC', infot, nout, lerr, ok )
155  infot = 7
156  CALL dtrexc( 'N', 0, a, 1, b, 1, ifst, ilst, work, info )
157  CALL chkxer( 'DTREXC', infot, nout, lerr, ok )
158  infot = 4
159  ilst = 2
160  CALL dtrexc( 'N', 2, a, 1, b, 1, ifst, ilst, work, info )
161  CALL chkxer( 'DTREXC', infot, nout, lerr, ok )
162  infot = 6
163  CALL dtrexc( 'V', 2, a, 2, b, 1, ifst, ilst, work, info )
164  CALL chkxer( 'DTREXC', infot, nout, lerr, ok )
165  infot = 7
166  ifst = 0
167  ilst = 1
168  CALL dtrexc( 'V', 1, a, 1, b, 1, ifst, ilst, work, info )
169  CALL chkxer( 'DTREXC', infot, nout, lerr, ok )
170  infot = 7
171  ifst = 2
172  CALL dtrexc( 'V', 1, a, 1, b, 1, ifst, ilst, work, info )
173  CALL chkxer( 'DTREXC', infot, nout, lerr, ok )
174  infot = 8
175  ifst = 1
176  ilst = 0
177  CALL dtrexc( 'V', 1, a, 1, b, 1, ifst, ilst, work, info )
178  CALL chkxer( 'DTREXC', infot, nout, lerr, ok )
179  infot = 8
180  ilst = 2
181  CALL dtrexc( 'V', 1, a, 1, b, 1, ifst, ilst, work, info )
182  CALL chkxer( 'DTREXC', infot, nout, lerr, ok )
183  nt = nt + 8
184 *
185 * Test DTRSNA
186 *
187  srnamt = 'DTRSNA'
188  infot = 1
189  CALL dtrsna( 'X', 'A', sel, 0, a, 1, b, 1, c, 1, s, sep, 1, m,
190  $ work, 1, iwork, info )
191  CALL chkxer( 'DTRSNA', infot, nout, lerr, ok )
192  infot = 2
193  CALL dtrsna( 'B', 'X', sel, 0, a, 1, b, 1, c, 1, s, sep, 1, m,
194  $ work, 1, iwork, info )
195  CALL chkxer( 'DTRSNA', infot, nout, lerr, ok )
196  infot = 4
197  CALL dtrsna( 'B', 'A', sel, -1, a, 1, b, 1, c, 1, s, sep, 1, m,
198  $ work, 1, iwork, info )
199  CALL chkxer( 'DTRSNA', infot, nout, lerr, ok )
200  infot = 6
201  CALL dtrsna( 'V', 'A', sel, 2, a, 1, b, 1, c, 1, s, sep, 2, m,
202  $ work, 2, iwork, info )
203  CALL chkxer( 'DTRSNA', infot, nout, lerr, ok )
204  infot = 8
205  CALL dtrsna( 'B', 'A', sel, 2, a, 2, b, 1, c, 2, s, sep, 2, m,
206  $ work, 2, iwork, info )
207  CALL chkxer( 'DTRSNA', infot, nout, lerr, ok )
208  infot = 10
209  CALL dtrsna( 'B', 'A', sel, 2, a, 2, b, 2, c, 1, s, sep, 2, m,
210  $ work, 2, iwork, info )
211  CALL chkxer( 'DTRSNA', infot, nout, lerr, ok )
212  infot = 13
213  CALL dtrsna( 'B', 'A', sel, 1, a, 1, b, 1, c, 1, s, sep, 0, m,
214  $ work, 1, iwork, info )
215  CALL chkxer( 'DTRSNA', infot, nout, lerr, ok )
216  infot = 13
217  CALL dtrsna( 'B', 'S', sel, 2, a, 2, b, 2, c, 2, s, sep, 1, m,
218  $ work, 2, iwork, info )
219  CALL chkxer( 'DTRSNA', infot, nout, lerr, ok )
220  infot = 16
221  CALL dtrsna( 'B', 'A', sel, 2, a, 2, b, 2, c, 2, s, sep, 2, m,
222  $ work, 1, iwork, info )
223  CALL chkxer( 'DTRSNA', infot, nout, lerr, ok )
224  nt = nt + 9
225 *
226 * Test DTRSEN
227 *
228  sel( 1 ) = .false.
229  srnamt = 'DTRSEN'
230  infot = 1
231  CALL dtrsen( 'X', 'N', sel, 0, a, 1, b, 1, wr, wi, m, s( 1 ),
232  $ sep( 1 ), work, 1, iwork, 1, info )
233  CALL chkxer( 'DTRSEN', infot, nout, lerr, ok )
234  infot = 2
235  CALL dtrsen( 'N', 'X', sel, 0, a, 1, b, 1, wr, wi, m, s( 1 ),
236  $ sep( 1 ), work, 1, iwork, 1, info )
237  CALL chkxer( 'DTRSEN', infot, nout, lerr, ok )
238  infot = 4
239  CALL dtrsen( 'N', 'N', sel, -1, a, 1, b, 1, wr, wi, m, s( 1 ),
240  $ sep( 1 ), work, 1, iwork, 1, info )
241  CALL chkxer( 'DTRSEN', infot, nout, lerr, ok )
242  infot = 6
243  CALL dtrsen( 'N', 'N', sel, 2, a, 1, b, 1, wr, wi, m, s( 1 ),
244  $ sep( 1 ), work, 2, iwork, 1, info )
245  CALL chkxer( 'DTRSEN', infot, nout, lerr, ok )
246  infot = 8
247  CALL dtrsen( 'N', 'V', sel, 2, a, 2, b, 1, wr, wi, m, s( 1 ),
248  $ sep( 1 ), work, 1, iwork, 1, info )
249  CALL chkxer( 'DTRSEN', infot, nout, lerr, ok )
250  infot = 15
251  CALL dtrsen( 'N', 'V', sel, 2, a, 2, b, 2, wr, wi, m, s( 1 ),
252  $ sep( 1 ), work, 0, iwork, 1, info )
253  CALL chkxer( 'DTRSEN', infot, nout, lerr, ok )
254  infot = 15
255  CALL dtrsen( 'E', 'V', sel, 3, a, 3, b, 3, wr, wi, m, s( 1 ),
256  $ sep( 1 ), work, 1, iwork, 1, info )
257  CALL chkxer( 'DTRSEN', infot, nout, lerr, ok )
258  infot = 15
259  CALL dtrsen( 'V', 'V', sel, 3, a, 3, b, 3, wr, wi, m, s( 1 ),
260  $ sep( 1 ), work, 3, iwork, 2, info )
261  CALL chkxer( 'DTRSEN', infot, nout, lerr, ok )
262  infot = 17
263  CALL dtrsen( 'E', 'V', sel, 2, a, 2, b, 2, wr, wi, m, s( 1 ),
264  $ sep( 1 ), work, 1, iwork, 0, info )
265  CALL chkxer( 'DTRSEN', infot, nout, lerr, ok )
266  infot = 17
267  CALL dtrsen( 'V', 'V', sel, 3, a, 3, b, 3, wr, wi, m, s( 1 ),
268  $ sep( 1 ), work, 4, iwork, 1, info )
269  CALL chkxer( 'DTRSEN', infot, nout, lerr, ok )
270  nt = nt + 10
271 *
272 * Print a summary line.
273 *
274  IF( ok ) THEN
275  WRITE( nout, fmt = 9999 )path, nt
276  ELSE
277  WRITE( nout, fmt = 9998 )path
278  END IF
279 *
280  RETURN
281  9999 FORMAT( 1x, a3, ' routines passed the tests of the error exits (',
282  $ i3, ' tests done)' )
283  9998 FORMAT( ' *** ', a3, ' routines failed the tests of the error ex',
284  $ 'its ***' )
285 *
286 * End of DERREC
287 *
288  END
dtrexc
subroutine dtrexc(COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, INFO)
DTREXC
Definition: dtrexc.f:148
dtrsna
subroutine dtrsna(JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, INFO)
DTRSNA
Definition: dtrsna.f:267
chkxer
subroutine chkxer(SRNAMT, INFOT, NOUT, LERR, OK)
Definition: cblat2.f:3199
dtrsen
subroutine dtrsen(JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO)
DTRSEN
Definition: dtrsen.f:315
dtrsyl
subroutine dtrsyl(TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, SCALE, INFO)
DTRSYL
Definition: dtrsyl.f:166
derrec
subroutine derrec(PATH, NUNIT)
DERREC
Definition: derrec.f:58