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