LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ derrec()

subroutine derrec ( character*3  PATH,
integer  NUNIT 
)

DERREC

Purpose:
 DERREC tests the error exits for the routines for eigen- condition
 estimation for DOUBLE PRECISION matrices:
    DTRSYL, DTREXC, DTRSNA and DTRSEN.
Parameters
[in]PATH
          PATH is CHARACTER*3
          The LAPACK path name for the routines to be tested.
[in]NUNIT
          NUNIT is INTEGER
          The unit number for output.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 55 of file derrec.f.

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