85 DOUBLE PRECISION one, zero
86 parameter ( nmax = 4, one = 1.0d0, zero = 0.0d0 )
90 INTEGER i, ihi, ilo, info, j, ns, nt, sdim
91 DOUBLE PRECISION abnrm
96 DOUBLE PRECISION a( nmax, nmax ), r1( nmax ), r2( nmax ),
97 $ s( nmax ), u( nmax, nmax ), vl( nmax, nmax ),
98 $ vr( nmax, nmax ), vt( nmax, nmax ),
99 $ w( 10*nmax ), wi( nmax ), wr( nmax )
114 DOUBLE PRECISION selwi( 20 ), selwr( 20 )
119 INTEGER infot, nout, seldim, selopt
122 COMMON / infoc / infot, nout, ok, lerr
123 COMMON / srnamc / srnamt
124 COMMON / sslct / selopt, seldim, selval, selwr, selwi
129 WRITE( nout, fmt = * )
145 IF(
lsamen( 2, c2,
'EV' ) )
THEN
151 CALL dgeev(
'X',
'N', 0, a, 1, wr, wi, vl, 1, vr, 1, w, 1,
153 CALL chkxer(
'DGEEV ', infot, nout, lerr, ok )
155 CALL dgeev(
'N',
'X', 0, a, 1, wr, wi, vl, 1, vr, 1, w, 1,
157 CALL chkxer(
'DGEEV ', infot, nout, lerr, ok )
159 CALL dgeev(
'N',
'N', -1, a, 1, wr, wi, vl, 1, vr, 1, w, 1,
161 CALL chkxer(
'DGEEV ', infot, nout, lerr, ok )
163 CALL dgeev(
'N',
'N', 2, a, 1, wr, wi, vl, 1, vr, 1, w, 6,
165 CALL chkxer(
'DGEEV ', infot, nout, lerr, ok )
167 CALL dgeev(
'V',
'N', 2, a, 2, wr, wi, vl, 1, vr, 1, w, 8,
169 CALL chkxer(
'DGEEV ', infot, nout, lerr, ok )
171 CALL dgeev(
'N',
'V', 2, a, 2, wr, wi, vl, 1, vr, 1, w, 8,
173 CALL chkxer(
'DGEEV ', infot, nout, lerr, ok )
175 CALL dgeev(
'V',
'V', 1, a, 1, wr, wi, vl, 1, vr, 1, w, 3,
177 CALL chkxer(
'DGEEV ', infot, nout, lerr, ok )
180 ELSE IF(
lsamen( 2, c2,
'ES' ) )
THEN
186 CALL dgees(
'X',
'N',
dslect, 0, a, 1, sdim, wr, wi, vl, 1, w,
188 CALL chkxer(
'DGEES ', infot, nout, lerr, ok )
190 CALL dgees(
'N',
'X',
dslect, 0, a, 1, sdim, wr, wi, vl, 1, w,
192 CALL chkxer(
'DGEES ', infot, nout, lerr, ok )
194 CALL dgees(
'N',
'S',
dslect, -1, a, 1, sdim, wr, wi, vl, 1, w,
196 CALL chkxer(
'DGEES ', infot, nout, lerr, ok )
198 CALL dgees(
'N',
'S',
dslect, 2, a, 1, sdim, wr, wi, vl, 1, w,
200 CALL chkxer(
'DGEES ', infot, nout, lerr, ok )
202 CALL dgees(
'V',
'S',
dslect, 2, a, 2, sdim, wr, wi, vl, 1, w,
204 CALL chkxer(
'DGEES ', infot, nout, lerr, ok )
206 CALL dgees(
'N',
'S',
dslect, 1, a, 1, sdim, wr, wi, vl, 1, w,
208 CALL chkxer(
'DGEES ', infot, nout, lerr, ok )
211 ELSE IF(
lsamen( 2, c2,
'VX' ) )
THEN
217 CALL dgeevx(
'X',
'N',
'N',
'N', 0, a, 1, wr, wi, vl, 1, vr, 1,
218 $ ilo, ihi, s, abnrm, r1, r2, w, 1, iw, info )
219 CALL chkxer(
'DGEEVX', infot, nout, lerr, ok )
221 CALL dgeevx(
'N',
'X',
'N',
'N', 0, a, 1, wr, wi, vl, 1, vr, 1,
222 $ ilo, ihi, s, abnrm, r1, r2, w, 1, iw, info )
223 CALL chkxer(
'DGEEVX', infot, nout, lerr, ok )
225 CALL dgeevx(
'N',
'N',
'X',
'N', 0, a, 1, wr, wi, vl, 1, vr, 1,
226 $ ilo, ihi, s, abnrm, r1, r2, w, 1, iw, info )
227 CALL chkxer(
'DGEEVX', infot, nout, lerr, ok )
229 CALL dgeevx(
'N',
'N',
'N',
'X', 0, a, 1, wr, wi, vl, 1, vr, 1,
230 $ ilo, ihi, s, abnrm, r1, r2, w, 1, iw, info )
231 CALL chkxer(
'DGEEVX', infot, nout, lerr, ok )
233 CALL dgeevx(
'N',
'N',
'N',
'N', -1, a, 1, wr, wi, vl, 1, vr,
234 $ 1, ilo, ihi, s, abnrm, r1, r2, w, 1, iw, info )
235 CALL chkxer(
'DGEEVX', infot, nout, lerr, ok )
237 CALL dgeevx(
'N',
'N',
'N',
'N', 2, a, 1, wr, wi, vl, 1, vr, 1,
238 $ ilo, ihi, s, abnrm, r1, r2, w, 1, iw, info )
239 CALL chkxer(
'DGEEVX', infot, nout, lerr, ok )
241 CALL dgeevx(
'N',
'V',
'N',
'N', 2, a, 2, wr, wi, vl, 1, vr, 1,
242 $ ilo, ihi, s, abnrm, r1, r2, w, 6, iw, info )
243 CALL chkxer(
'DGEEVX', infot, nout, lerr, ok )
245 CALL dgeevx(
'N',
'N',
'V',
'N', 2, a, 2, wr, wi, vl, 1, vr, 1,
246 $ ilo, ihi, s, abnrm, r1, r2, w, 6, iw, info )
247 CALL chkxer(
'DGEEVX', infot, nout, lerr, ok )
249 CALL dgeevx(
'N',
'N',
'N',
'N', 1, a, 1, wr, wi, vl, 1, vr, 1,
250 $ ilo, ihi, s, abnrm, r1, r2, w, 1, iw, info )
251 CALL chkxer(
'DGEEVX', infot, nout, lerr, ok )
253 CALL dgeevx(
'N',
'V',
'N',
'N', 1, a, 1, wr, wi, vl, 1, vr, 1,
254 $ ilo, ihi, s, abnrm, r1, r2, w, 2, iw, info )
255 CALL chkxer(
'DGEEVX', infot, nout, lerr, ok )
257 CALL dgeevx(
'N',
'N',
'V',
'V', 1, a, 1, wr, wi, vl, 1, vr, 1,
258 $ ilo, ihi, s, abnrm, r1, r2, w, 3, iw, info )
259 CALL chkxer(
'DGEEVX', infot, nout, lerr, ok )
262 ELSE IF(
lsamen( 2, c2,
'SX' ) )
THEN
268 CALL dgeesx(
'X',
'N',
dslect,
'N', 0, a, 1, sdim, wr, wi, vl,
269 $ 1, r1( 1 ), r2( 1 ), w, 1, iw, 1, b, info )
270 CALL chkxer(
'DGEESX', infot, nout, lerr, ok )
272 CALL dgeesx(
'N',
'X',
dslect,
'N', 0, a, 1, sdim, wr, wi, vl,
273 $ 1, r1( 1 ), r2( 1 ), w, 1, iw, 1, b, info )
274 CALL chkxer(
'DGEESX', infot, nout, lerr, ok )
276 CALL dgeesx(
'N',
'N',
dslect,
'X', 0, a, 1, sdim, wr, wi, vl,
277 $ 1, r1( 1 ), r2( 1 ), w, 1, iw, 1, b, info )
278 CALL chkxer(
'DGEESX', infot, nout, lerr, ok )
280 CALL dgeesx(
'N',
'N',
dslect,
'N', -1, a, 1, sdim, wr, wi, vl,
281 $ 1, r1( 1 ), r2( 1 ), w, 1, iw, 1, b, info )
282 CALL chkxer(
'DGEESX', infot, nout, lerr, ok )
284 CALL dgeesx(
'N',
'N',
dslect,
'N', 2, a, 1, sdim, wr, wi, vl,
285 $ 1, r1( 1 ), r2( 1 ), w, 6, iw, 1, b, info )
286 CALL chkxer(
'DGEESX', infot, nout, lerr, ok )
288 CALL dgeesx(
'V',
'N',
dslect,
'N', 2, a, 2, sdim, wr, wi, vl,
289 $ 1, r1( 1 ), r2( 1 ), w, 6, iw, 1, b, info )
290 CALL chkxer(
'DGEESX', infot, nout, lerr, ok )
292 CALL dgeesx(
'N',
'N',
dslect,
'N', 1, a, 1, sdim, wr, wi, vl,
293 $ 1, r1( 1 ), r2( 1 ), w, 2, iw, 1, b, info )
294 CALL chkxer(
'DGEESX', infot, nout, lerr, ok )
297 ELSE IF(
lsamen( 2, c2,
'BD' ) )
THEN
303 CALL dgesvd(
'X',
'N', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, info )
304 CALL chkxer(
'DGESVD', infot, nout, lerr, ok )
306 CALL dgesvd(
'N',
'X', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, info )
307 CALL chkxer(
'DGESVD', infot, nout, lerr, ok )
309 CALL dgesvd(
'O',
'O', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, info )
310 CALL chkxer(
'DGESVD', infot, nout, lerr, ok )
312 CALL dgesvd(
'N',
'N', -1, 0, a, 1, s, u, 1, vt, 1, w, 1,
314 CALL chkxer(
'DGESVD', infot, nout, lerr, ok )
316 CALL dgesvd(
'N',
'N', 0, -1, a, 1, s, u, 1, vt, 1, w, 1,
318 CALL chkxer(
'DGESVD', infot, nout, lerr, ok )
320 CALL dgesvd(
'N',
'N', 2, 1, a, 1, s, u, 1, vt, 1, w, 5, info )
321 CALL chkxer(
'DGESVD', infot, nout, lerr, ok )
323 CALL dgesvd(
'A',
'N', 2, 1, a, 2, s, u, 1, vt, 1, w, 5, info )
324 CALL chkxer(
'DGESVD', infot, nout, lerr, ok )
326 CALL dgesvd(
'N',
'A', 1, 2, a, 1, s, u, 1, vt, 1, w, 5, info )
327 CALL chkxer(
'DGESVD', infot, nout, lerr, ok )
330 WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
333 WRITE( nout, fmt = 9998 )
340 CALL dgesdd(
'X', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, iw, info )
341 CALL chkxer(
'DGESDD', infot, nout, lerr, ok )
343 CALL dgesdd(
'N', -1, 0, a, 1, s, u, 1, vt, 1, w, 1, iw, info )
344 CALL chkxer(
'DGESDD', infot, nout, lerr, ok )
346 CALL dgesdd(
'N', 0, -1, a, 1, s, u, 1, vt, 1, w, 1, iw, info )
347 CALL chkxer(
'DGESDD', infot, nout, lerr, ok )
349 CALL dgesdd(
'N', 2, 1, a, 1, s, u, 1, vt, 1, w, 5, iw, info )
350 CALL chkxer(
'DGESDD', infot, nout, lerr, ok )
352 CALL dgesdd(
'A', 2, 1, a, 2, s, u, 1, vt, 1, w, 5, iw, info )
353 CALL chkxer(
'DGESDD', infot, nout, lerr, ok )
355 CALL dgesdd(
'A', 1, 2, a, 1, s, u, 1, vt, 1, w, 5, iw, info )
356 CALL chkxer(
'DGESDD', infot, nout, lerr, ok )
359 WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
362 WRITE( nout, fmt = 9998 )
369 CALL dgejsv(
'X',
'U',
'V',
'R',
'N',
'N',
370 $ 0, 0, a, 1, s, u, 1, vt, 1,
372 CALL chkxer(
'DGEJSV', infot, nout, lerr, ok )
374 CALL dgejsv(
'G',
'X',
'V',
'R',
'N',
'N',
375 $ 0, 0, a, 1, s, u, 1, vt, 1,
377 CALL chkxer(
'DGEJSV', infot, nout, lerr, ok )
379 CALL dgejsv(
'G',
'U',
'X',
'R',
'N',
'N',
380 $ 0, 0, a, 1, s, u, 1, vt, 1,
382 CALL chkxer(
'DGEJSV', infot, nout, lerr, ok )
384 CALL dgejsv(
'G',
'U',
'V',
'X',
'N',
'N',
385 $ 0, 0, a, 1, s, u, 1, vt, 1,
387 CALL chkxer(
'DGEJSV', infot, nout, lerr, ok )
389 CALL dgejsv(
'G',
'U',
'V',
'R',
'X',
'N',
390 $ 0, 0, a, 1, s, u, 1, vt, 1,
392 CALL chkxer(
'DGEJSV', infot, nout, lerr, ok )
394 CALL dgejsv(
'G',
'U',
'V',
'R',
'N',
'X',
395 $ 0, 0, a, 1, s, u, 1, vt, 1,
397 CALL chkxer(
'DGEJSV', infot, nout, lerr, ok )
399 CALL dgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
400 $ -1, 0, a, 1, s, u, 1, vt, 1,
402 CALL chkxer(
'DGEJSV', infot, nout, lerr, ok )
404 CALL dgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
405 $ 0, -1, a, 1, s, u, 1, vt, 1,
407 CALL chkxer(
'DGEJSV', infot, nout, lerr, ok )
409 CALL dgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
410 $ 2, 1, a, 1, s, u, 1, vt, 1,
412 CALL chkxer(
'DGEJSV', infot, nout, lerr, ok )
414 CALL dgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
415 $ 2, 2, a, 2, s, u, 1, vt, 2,
417 CALL chkxer(
'DGEJSV', infot, nout, lerr, ok )
419 CALL dgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
420 $ 2, 2, a, 2, s, u, 2, vt, 1,
422 CALL chkxer(
'DGEJSV', infot, nout, lerr, ok )
425 WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
428 WRITE( nout, fmt = 9998 )
435 CALL dgesvdx(
'X',
'N',
'A', 0, 0, a, 1, zero, zero,
436 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, iw, info )
437 CALL chkxer(
'DGESVDX', infot, nout, lerr, ok )
439 CALL dgesvdx(
'N',
'X',
'A', 0, 0, a, 1, zero, zero,
440 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, iw, info )
441 CALL chkxer(
'DGESVDX', infot, nout, lerr, ok )
443 CALL dgesvdx(
'N',
'N',
'X', 0, 0, a, 1, zero, zero,
444 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, iw, info )
445 CALL chkxer(
'DGESVDX', infot, nout, lerr, ok )
447 CALL dgesvdx(
'N',
'N',
'A', -1, 0, a, 1, zero, zero,
448 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, iw, info )
449 CALL chkxer(
'DGESVDX', infot, nout, lerr, ok )
451 CALL dgesvdx(
'N',
'N',
'A', 0, -1, a, 1, zero, zero,
452 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, iw, info )
453 CALL chkxer(
'DGESVDX', infot, nout, lerr, ok )
455 CALL dgesvdx(
'N',
'N',
'A', 2, 1, a, 1, zero, zero,
456 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, iw, info )
457 CALL chkxer(
'DGESVDX', infot, nout, lerr, ok )
459 CALL dgesvdx(
'N',
'N',
'V', 2, 1, a, 2, -one, zero,
460 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, iw, info )
461 CALL chkxer(
'DGESVDX', infot, nout, lerr, ok )
463 CALL dgesvdx(
'N',
'N',
'V', 2, 1, a, 2, one, zero,
464 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, iw, info )
465 CALL chkxer(
'DGESVDX', infot, nout, lerr, ok )
467 CALL dgesvdx(
'N',
'N',
'I', 2, 2, a, 2, zero, zero,
468 $ 0, 1, ns, s, u, 1, vt, 1, w, 1, iw, info )
469 CALL chkxer(
'DGESVDX', infot, nout, lerr, ok )
471 CALL dgesvdx(
'V',
'N',
'I', 2, 2, a, 2, zero, zero,
472 $ 1, 0, ns, s, u, 1, vt, 1, w, 1, iw, info )
473 CALL chkxer(
'DGESVDX', infot, nout, lerr, ok )
475 CALL dgesvdx(
'V',
'N',
'A', 2, 2, a, 2, zero, zero,
476 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, iw, info )
477 CALL chkxer(
'DGESVDX', infot, nout, lerr, ok )
479 CALL dgesvdx(
'N',
'V',
'A', 2, 2, a, 2, zero, zero,
480 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, iw, info )
481 CALL chkxer(
'DGESVDX', infot, nout, lerr, ok )
484 WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
487 WRITE( nout, fmt = 9998 )
493 IF( .NOT.
lsamen( 2, c2,
'BD' ) )
THEN
495 WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
498 WRITE( nout, fmt = 9998 )
502 9999
FORMAT( 1x, a,
' passed the tests of the error exits (', i3,
504 9998
FORMAT(
' *** ', a,
' failed the tests of the error exits ***' )
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 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 ...
logical function lsamen(N, CA, CB)
LSAMEN
subroutine chkxer(SRNAMT, INFOT, NOUT, LERR, OK)
subroutine dgesdd(JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, IWORK, INFO)
DGESDD
logical function dslect(ZR, ZI)
DSLECT
subroutine dgesvdx(JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, IL, IU, NS, S, U, LDU, VT, LDVT, WORK, LWORK, IWORK, INFO)
DGESVDX computes the singular value decomposition (SVD) for GE matrices
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 ...
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 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 dgejsv(JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, M, N, A, LDA, SVA, U, LDU, V, LDV, WORK, LWORK, IWORK, INFO)
DGEJSV