OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
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, DTREXC, DTRSNA and DTRSEN.
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*> \ingroup double_eig
53*
54* =====================================================================
55 SUBROUTINE derrec( PATH, NUNIT )
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*
285 END
chkxer
subroutine chkxer(srnamt, infot, nout, lerr, ok)
Definition cblat2.f:3196
the
end diagonal values have been computed in the(sparse) matrix id.SOL
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:265
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:313
dtrsyl
subroutine dtrsyl(trana, tranb, isgn, m, n, a, lda, b, ldb, c, ldc, scale, info)
DTRSYL
Definition dtrsyl.f:164
derrec
subroutine derrec(path, nunit)
DERREC
Definition derrec.f:56