67 SUBROUTINE derred( PATH, NUNIT )
83 DOUBLE PRECISION ONE, ZERO
84 parameter( nmax = 4, one = 1.0d0, zero = 0.0d0 )
88 INTEGER I, IHI, ILO, INFO, J, NT, SDIM
89 DOUBLE PRECISION ABNRM
94 DOUBLE PRECISION A( nmax, nmax ), R1( nmax ), R2( nmax ),
95 $ s( nmax ), u( nmax, nmax ), vl( nmax, nmax ),
96 $ vr( nmax, nmax ), vt( nmax, nmax ),
97 $ w( 4*nmax ), wi( nmax ), wr( nmax )
104 LOGICAL DSLECT, LSAMEN
105 EXTERNAL dslect, lsamen
112 DOUBLE PRECISION SELWI( 20 ), SELWR( 20 )
117 INTEGER INFOT, NOUT, SELDIM, SELOPT
120 COMMON / infoc / infot, nout, ok, lerr
121 COMMON / srnamc / srnamt
122 COMMON / sslct / selopt, seldim, selval, selwr, selwi
127 WRITE( nout, fmt = * )
143 IF( lsamen( 2, c2,
'EV' ) )
THEN
149 CALL dgeev(
'X',
'N', 0, a, 1, wr, wi, vl, 1, vr, 1, w, 1,
151 CALL chkxer(
'DGEEV ', infot, nout, lerr, ok )
153 CALL dgeev(
'N',
'X', 0, a, 1, wr, wi, vl, 1, vr, 1, w, 1,
155 CALL chkxer(
'DGEEV ', infot, nout, lerr, ok )
157 CALL dgeev(
'N',
'N', -1, a, 1, wr, wi, vl, 1, vr, 1, w, 1,
159 CALL chkxer(
'DGEEV ', infot, nout, lerr, ok )
161 CALL dgeev(
'N',
'N', 2, a, 1, wr, wi, vl, 1, vr, 1, w, 6,
163 CALL chkxer(
'DGEEV ', infot, nout, lerr, ok )
165 CALL dgeev(
'V',
'N', 2, a, 2, wr, wi, vl, 1, vr, 1, w, 8,
167 CALL chkxer(
'DGEEV ', infot, nout, lerr, ok )
169 CALL dgeev(
'N',
'V', 2, a, 2, wr, wi, vl, 1, vr, 1, w, 8,
171 CALL chkxer(
'DGEEV ', infot, nout, lerr, ok )
173 CALL dgeev(
'V',
'V', 1, a, 1, wr, wi, vl, 1, vr, 1, w, 3,
175 CALL chkxer(
'DGEEV ', infot, nout, lerr, ok )
178 ELSE IF( lsamen( 2, c2,
'ES' ) )
THEN
184 CALL dgees(
'X',
'N', dslect, 0, a, 1, sdim, wr, wi, vl, 1, w,
186 CALL chkxer(
'DGEES ', infot, nout, lerr, ok )
188 CALL dgees(
'N',
'X', dslect, 0, a, 1, sdim, wr, wi, vl, 1, w,
190 CALL chkxer(
'DGEES ', infot, nout, lerr, ok )
192 CALL dgees(
'N',
'S', dslect, -1, a, 1, sdim, wr, wi, vl, 1, w,
194 CALL chkxer(
'DGEES ', infot, nout, lerr, ok )
196 CALL dgees(
'N',
'S', dslect, 2, a, 1, sdim, wr, wi, vl, 1, w,
198 CALL chkxer(
'DGEES ', infot, nout, lerr, ok )
200 CALL dgees(
'V',
'S', dslect, 2, a, 2, sdim, wr, wi, vl, 1, w,
202 CALL chkxer(
'DGEES ', infot, nout, lerr, ok )
204 CALL dgees(
'N',
'S', dslect, 1, a, 1, sdim, wr, wi, vl, 1, w,
206 CALL chkxer(
'DGEES ', infot, nout, lerr, ok )
209 ELSE IF( lsamen( 2, c2,
'VX' ) )
THEN
215 CALL dgeevx(
'X',
'N',
'N',
'N', 0, a, 1, wr, wi, vl, 1, vr, 1,
216 $ ilo, ihi, s, abnrm, r1, r2, w, 1, iw, info )
217 CALL chkxer(
'DGEEVX', infot, nout, lerr, ok )
219 CALL dgeevx(
'N',
'X',
'N',
'N', 0, a, 1, wr, wi, vl, 1, vr, 1,
220 $ ilo, ihi, s, abnrm, r1, r2, w, 1, iw, info )
221 CALL chkxer(
'DGEEVX', infot, nout, lerr, ok )
223 CALL dgeevx(
'N',
'N',
'X',
'N', 0, a, 1, wr, wi, vl, 1, vr, 1,
224 $ ilo, ihi, s, abnrm, r1, r2, w, 1, iw, info )
225 CALL chkxer(
'DGEEVX', infot, nout, lerr, ok )
227 CALL dgeevx(
'N',
'N',
'N',
'X', 0, a, 1, wr, wi, vl, 1, vr, 1,
228 $ ilo, ihi, s, abnrm, r1, r2, w, 1, iw, info )
229 CALL chkxer(
'DGEEVX', infot, nout, lerr, ok )
231 CALL dgeevx(
'N',
'N',
'N',
'N', -1, a, 1, wr, wi, vl, 1, vr,
232 $ 1, ilo, ihi, s, abnrm, r1, r2, w, 1, iw, info )
233 CALL chkxer(
'DGEEVX', infot, nout, lerr, ok )
235 CALL dgeevx(
'N',
'N',
'N',
'N', 2, a, 1, wr, wi, vl, 1, vr, 1,
236 $ ilo, ihi, s, abnrm, r1, r2, w, 1, iw, info )
237 CALL chkxer(
'DGEEVX', infot, nout, lerr, ok )
239 CALL dgeevx(
'N',
'V',
'N',
'N', 2, a, 2, wr, wi, vl, 1, vr, 1,
240 $ ilo, ihi, s, abnrm, r1, r2, w, 6, iw, info )
241 CALL chkxer(
'DGEEVX', infot, nout, lerr, ok )
243 CALL dgeevx(
'N',
'N',
'V',
'N', 2, a, 2, wr, wi, vl, 1, vr, 1,
244 $ ilo, ihi, s, abnrm, r1, r2, w, 6, iw, info )
245 CALL chkxer(
'DGEEVX', infot, nout, lerr, ok )
247 CALL dgeevx(
'N',
'N',
'N',
'N', 1, a, 1, wr, wi, vl, 1, vr, 1,
248 $ ilo, ihi, s, abnrm, r1, r2, w, 1, iw, info )
249 CALL chkxer(
'DGEEVX', infot, nout, lerr, ok )
251 CALL dgeevx(
'N',
'V',
'N',
'N', 1, a, 1, wr, wi, vl, 1, vr, 1,
252 $ ilo, ihi, s, abnrm, r1, r2, w, 2, iw, info )
253 CALL chkxer(
'DGEEVX', infot, nout, lerr, ok )
255 CALL dgeevx(
'N',
'N',
'V',
'V', 1, a, 1, wr, wi, vl, 1, vr, 1,
256 $ ilo, ihi, s, abnrm, r1, r2, w, 3, iw, info )
257 CALL chkxer(
'DGEEVX', infot, nout, lerr, ok )
260 ELSE IF( lsamen( 2, c2,
'SX' ) )
THEN
266 CALL dgeesx(
'X',
'N', dslect,
'N', 0, a, 1, sdim, wr, wi, vl,
267 $ 1, r1( 1 ), r2( 1 ), w, 1, iw, 1, b, info )
268 CALL chkxer(
'DGEESX', infot, nout, lerr, ok )
270 CALL dgeesx(
'N',
'X', dslect,
'N', 0, a, 1, sdim, wr, wi, vl,
271 $ 1, r1( 1 ), r2( 1 ), w, 1, iw, 1, b, info )
272 CALL chkxer(
'DGEESX', infot, nout, lerr, ok )
274 CALL dgeesx(
'N',
'N', dslect,
'X', 0, a, 1, sdim, wr, wi, vl,
275 $ 1, r1( 1 ), r2( 1 ), w, 1, iw, 1, b, info )
276 CALL chkxer(
'DGEESX', infot, nout, lerr, ok )
278 CALL dgeesx(
'N',
'N', dslect,
'N', -1, a, 1, sdim, wr, wi, vl,
279 $ 1, r1( 1 ), r2( 1 ), w, 1, iw, 1, b, info )
280 CALL chkxer(
'DGEESX', infot, nout, lerr, ok )
282 CALL dgeesx(
'N',
'N', dslect,
'N', 2, a, 1, sdim, wr, wi, vl,
283 $ 1, r1( 1 ), r2( 1 ), w, 6, iw, 1, b, info )
284 CALL chkxer(
'DGEESX', infot, nout, lerr, ok )
286 CALL dgeesx(
'V',
'N', dslect,
'N', 2, a, 2, sdim, wr, wi, vl,
287 $ 1, r1( 1 ), r2( 1 ), w, 6, iw, 1, b, info )
288 CALL chkxer(
'DGEESX', infot, nout, lerr, ok )
290 CALL dgeesx(
'N',
'N', dslect,
'N', 1, a, 1, sdim, wr, wi, vl,
291 $ 1, r1( 1 ), r2( 1 ), w, 2, iw, 1, b, info )
292 CALL chkxer(
'DGEESX', infot, nout, lerr, ok )
295 ELSE IF( lsamen( 2, c2,
'BD' ) )
THEN
301 CALL dgesvd(
'X',
'N', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, info )
302 CALL chkxer(
'DGESVD', infot, nout, lerr, ok )
304 CALL dgesvd(
'N',
'X', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, info )
305 CALL chkxer(
'DGESVD', infot, nout, lerr, ok )
307 CALL dgesvd(
'O',
'O', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, info )
308 CALL chkxer(
'DGESVD', infot, nout, lerr, ok )
310 CALL dgesvd(
'N',
'N', -1, 0, a, 1, s, u, 1, vt, 1, w, 1,
312 CALL chkxer(
'DGESVD', infot, nout, lerr, ok )
314 CALL dgesvd(
'N',
'N', 0, -1, a, 1, s, u, 1, vt, 1, w, 1,
316 CALL chkxer(
'DGESVD', infot, nout, lerr, ok )
318 CALL dgesvd(
'N',
'N', 2, 1, a, 1, s, u, 1, vt, 1, w, 5, info )
319 CALL chkxer(
'DGESVD', infot, nout, lerr, ok )
321 CALL dgesvd(
'A',
'N', 2, 1, a, 2, s, u, 1, vt, 1, w, 5, info )
322 CALL chkxer(
'DGESVD', infot, nout, lerr, ok )
324 CALL dgesvd(
'N',
'A', 1, 2, a, 1, s, u, 1, vt, 1, w, 5, info )
325 CALL chkxer(
'DGESVD', infot, nout, lerr, ok )
328 WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
331 WRITE( nout, fmt = 9998 )
338 CALL dgesdd(
'X', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, iw, info )
339 CALL chkxer(
'DGESDD', infot, nout, lerr, ok )
341 CALL dgesdd(
'N', -1, 0, a, 1, s, u, 1, vt, 1, w, 1, iw, info )
342 CALL chkxer(
'DGESDD', infot, nout, lerr, ok )
344 CALL dgesdd(
'N', 0, -1, a, 1, s, u, 1, vt, 1, w, 1, iw, info )
345 CALL chkxer(
'DGESDD', infot, nout, lerr, ok )
347 CALL dgesdd(
'N', 2, 1, a, 1, s, u, 1, vt, 1, w, 5, iw, info )
348 CALL chkxer(
'DGESDD', infot, nout, lerr, ok )
350 CALL dgesdd(
'A', 2, 1, a, 2, s, u, 1, vt, 1, w, 5, iw, info )
351 CALL chkxer(
'DGESDD', infot, nout, lerr, ok )
353 CALL dgesdd(
'A', 1, 2, a, 1, s, u, 1, vt, 1, w, 5, iw, info )
354 CALL chkxer(
'DGESDD', infot, nout, lerr, ok )
357 WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
360 WRITE( nout, fmt = 9998 )
367 CALL dgejsv(
'X',
'U',
'V',
'R',
'N',
'N',
368 $ 0, 0, a, 1, s, u, 1, vt, 1,
370 CALL chkxer(
'DGEJSV', infot, nout, lerr, ok )
372 CALL dgejsv(
'G',
'X',
'V',
'R',
'N',
'N',
373 $ 0, 0, a, 1, s, u, 1, vt, 1,
375 CALL chkxer(
'DGEJSV', infot, nout, lerr, ok )
377 CALL dgejsv(
'G',
'U',
'X',
'R',
'N',
'N',
378 $ 0, 0, a, 1, s, u, 1, vt, 1,
380 CALL chkxer(
'DGEJSV', infot, nout, lerr, ok )
382 CALL dgejsv(
'G',
'U',
'V',
'X',
'N',
'N',
383 $ 0, 0, a, 1, s, u, 1, vt, 1,
385 CALL chkxer(
'DGEJSV', infot, nout, lerr, ok )
387 CALL dgejsv(
'G',
'U',
'V',
'R',
'X',
'N',
388 $ 0, 0, a, 1, s, u, 1, vt, 1,
390 CALL chkxer(
'DGEJSV', infot, nout, lerr, ok )
392 CALL dgejsv(
'G',
'U',
'V',
'R',
'N',
'X',
393 $ 0, 0, a, 1, s, u, 1, vt, 1,
395 CALL chkxer(
'DGEJSV', infot, nout, lerr, ok )
397 CALL dgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
398 $ -1, 0, a, 1, s, u, 1, vt, 1,
400 CALL chkxer(
'DGEJSV', infot, nout, lerr, ok )
402 CALL dgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
403 $ 0, -1, a, 1, s, u, 1, vt, 1,
405 CALL chkxer(
'DGEJSV', infot, nout, lerr, ok )
407 CALL dgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
408 $ 2, 1, a, 1, s, u, 1, vt, 1,
410 CALL chkxer(
'DGEJSV', infot, nout, lerr, ok )
412 CALL dgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
413 $ 2, 2, a, 2, s, u, 1, vt, 2,
415 CALL chkxer(
'DGEJSV', infot, nout, lerr, ok )
417 CALL dgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
418 $ 2, 2, a, 2, s, u, 2, vt, 1,
420 CALL chkxer(
'DGEJSV', infot, nout, lerr, ok )
423 WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
426 WRITE( nout, fmt = 9998 )
432 IF( .NOT.lsamen( 2, c2,
'BD' ) )
THEN
434 WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
437 WRITE( nout, fmt = 9998 )
441 9999
FORMAT( 1x, a,
' passed the tests of the error exits (', i3,
443 9998
FORMAT(
' *** ', a,
' failed the tests of the error exits ***' )
subroutine dgejsv(JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, M, N, A, LDA, SVA, U, LDU, V, LDV, WORK, LWORK, IWORK, INFO)
DGEJSV
subroutine derred(PATH, NUNIT)
DERRED
subroutine dgesdd(JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, IWORK, INFO)
DGESDD
subroutine chkxer(SRNAMT, INFOT, NOUT, LERR, OK)
subroutine dgeevx(BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, IWORK, INFO)
DGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices ...
subroutine dgeesx(JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, IWORK, LIWORK, BWORK, INFO)
DGEESX computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE...
subroutine dgesvd(JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, INFO)
DGESVD computes the singular value decomposition (SVD) for GE matrices
subroutine dgees(JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, VS, LDVS, WORK, LWORK, BWORK, INFO)
DGEES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE ...
subroutine dgeev(JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, WORK, LWORK, INFO)
DGEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices ...