85 parameter ( nmax = 4, lw = 5*nmax )
86 DOUBLE PRECISION one, zero
87 parameter ( one = 1.0d0, zero = 0.0d0 )
91 INTEGER i, ihi, ilo, info, j, ns, nt, sdim
92 DOUBLE PRECISION abnrm
97 DOUBLE PRECISION r1( nmax ), r2( nmax ), rw( lw ), s( nmax )
98 COMPLEX*16 a( nmax, nmax ), u( nmax, nmax ),
99 $ vl( nmax, nmax ), vr( nmax, nmax ),
100 $ vt( nmax, nmax ), w( 10*nmax ), x( nmax )
115 DOUBLE PRECISION selwi( 20 ), selwr( 20 )
120 INTEGER infot, nout, seldim, selopt
123 COMMON / infoc / infot, nout, ok, lerr
124 COMMON / srnamc / srnamt
125 COMMON / sslct / selopt, seldim, selval, selwr, selwi
130 WRITE( nout, fmt = * )
146 IF(
lsamen( 2, c2,
'EV' ) )
THEN
152 CALL zgeev(
'X',
'N', 0, a, 1, x, vl, 1, vr, 1, w, 1, rw,
154 CALL chkxer(
'ZGEEV ', infot, nout, lerr, ok )
156 CALL zgeev(
'N',
'X', 0, a, 1, x, vl, 1, vr, 1, w, 1, rw,
158 CALL chkxer(
'ZGEEV ', infot, nout, lerr, ok )
160 CALL zgeev(
'N',
'N', -1, a, 1, x, vl, 1, vr, 1, w, 1, rw,
162 CALL chkxer(
'ZGEEV ', infot, nout, lerr, ok )
164 CALL zgeev(
'N',
'N', 2, a, 1, x, vl, 1, vr, 1, w, 4, rw,
166 CALL chkxer(
'ZGEEV ', infot, nout, lerr, ok )
168 CALL zgeev(
'V',
'N', 2, a, 2, x, vl, 1, vr, 1, w, 4, rw,
170 CALL chkxer(
'ZGEEV ', infot, nout, lerr, ok )
172 CALL zgeev(
'N',
'V', 2, a, 2, x, vl, 1, vr, 1, w, 4, rw,
174 CALL chkxer(
'ZGEEV ', infot, nout, lerr, ok )
176 CALL zgeev(
'V',
'V', 1, a, 1, x, vl, 1, vr, 1, w, 1, rw,
178 CALL chkxer(
'ZGEEV ', infot, nout, lerr, ok )
181 ELSE IF(
lsamen( 2, c2,
'ES' ) )
THEN
187 CALL zgees(
'X',
'N',
zslect, 0, a, 1, sdim, x, vl, 1, w, 1,
189 CALL chkxer(
'ZGEES ', infot, nout, lerr, ok )
191 CALL zgees(
'N',
'X',
zslect, 0, a, 1, sdim, x, vl, 1, w, 1,
193 CALL chkxer(
'ZGEES ', infot, nout, lerr, ok )
195 CALL zgees(
'N',
'S',
zslect, -1, a, 1, sdim, x, vl, 1, w, 1,
197 CALL chkxer(
'ZGEES ', infot, nout, lerr, ok )
199 CALL zgees(
'N',
'S',
zslect, 2, a, 1, sdim, x, vl, 1, w, 4,
201 CALL chkxer(
'ZGEES ', infot, nout, lerr, ok )
203 CALL zgees(
'V',
'S',
zslect, 2, a, 2, sdim, x, vl, 1, w, 4,
205 CALL chkxer(
'ZGEES ', infot, nout, lerr, ok )
207 CALL zgees(
'N',
'S',
zslect, 1, a, 1, sdim, x, vl, 1, w, 1,
209 CALL chkxer(
'ZGEES ', infot, nout, lerr, ok )
212 ELSE IF(
lsamen( 2, c2,
'VX' ) )
THEN
218 CALL zgeevx(
'X',
'N',
'N',
'N', 0, a, 1, x, vl, 1, vr, 1, ilo,
219 $ ihi, s, abnrm, r1, r2, w, 1, rw, info )
220 CALL chkxer(
'ZGEEVX', infot, nout, lerr, ok )
222 CALL zgeevx(
'N',
'X',
'N',
'N', 0, a, 1, x, vl, 1, vr, 1, ilo,
223 $ ihi, s, abnrm, r1, r2, w, 1, rw, info )
224 CALL chkxer(
'ZGEEVX', infot, nout, lerr, ok )
226 CALL zgeevx(
'N',
'N',
'X',
'N', 0, a, 1, x, vl, 1, vr, 1, ilo,
227 $ ihi, s, abnrm, r1, r2, w, 1, rw, info )
228 CALL chkxer(
'ZGEEVX', infot, nout, lerr, ok )
230 CALL zgeevx(
'N',
'N',
'N',
'X', 0, a, 1, x, vl, 1, vr, 1, ilo,
231 $ ihi, s, abnrm, r1, r2, w, 1, rw, info )
232 CALL chkxer(
'ZGEEVX', infot, nout, lerr, ok )
234 CALL zgeevx(
'N',
'N',
'N',
'N', -1, a, 1, x, vl, 1, vr, 1,
235 $ ilo, ihi, s, abnrm, r1, r2, w, 1, rw, info )
236 CALL chkxer(
'ZGEEVX', infot, nout, lerr, ok )
238 CALL zgeevx(
'N',
'N',
'N',
'N', 2, a, 1, x, vl, 1, vr, 1, ilo,
239 $ ihi, s, abnrm, r1, r2, w, 4, rw, info )
240 CALL chkxer(
'ZGEEVX', infot, nout, lerr, ok )
242 CALL zgeevx(
'N',
'V',
'N',
'N', 2, a, 2, x, vl, 1, vr, 1, ilo,
243 $ ihi, s, abnrm, r1, r2, w, 4, rw, info )
244 CALL chkxer(
'ZGEEVX', infot, nout, lerr, ok )
246 CALL zgeevx(
'N',
'N',
'V',
'N', 2, a, 2, x, vl, 1, vr, 1, ilo,
247 $ ihi, s, abnrm, r1, r2, w, 4, rw, info )
248 CALL chkxer(
'ZGEEVX', infot, nout, lerr, ok )
250 CALL zgeevx(
'N',
'N',
'N',
'N', 1, a, 1, x, vl, 1, vr, 1, ilo,
251 $ ihi, s, abnrm, r1, r2, w, 1, rw, info )
252 CALL chkxer(
'ZGEEVX', infot, nout, lerr, ok )
254 CALL zgeevx(
'N',
'N',
'V',
'V', 1, a, 1, x, vl, 1, vr, 1, ilo,
255 $ ihi, s, abnrm, r1, r2, w, 2, rw, info )
256 CALL chkxer(
'ZGEEVX', infot, nout, lerr, ok )
259 ELSE IF(
lsamen( 2, c2,
'SX' ) )
THEN
265 CALL zgeesx(
'X',
'N',
zslect,
'N', 0, a, 1, sdim, x, vl, 1,
266 $ r1( 1 ), r2( 1 ), w, 1, rw, b, info )
267 CALL chkxer(
'ZGEESX', infot, nout, lerr, ok )
269 CALL zgeesx(
'N',
'X',
zslect,
'N', 0, a, 1, sdim, x, vl, 1,
270 $ r1( 1 ), r2( 1 ), w, 1, rw, b, info )
271 CALL chkxer(
'ZGEESX', infot, nout, lerr, ok )
273 CALL zgeesx(
'N',
'N',
zslect,
'X', 0, a, 1, sdim, x, vl, 1,
274 $ r1( 1 ), r2( 1 ), w, 1, rw, b, info )
275 CALL chkxer(
'ZGEESX', infot, nout, lerr, ok )
277 CALL zgeesx(
'N',
'N',
zslect,
'N', -1, a, 1, sdim, x, vl, 1,
278 $ r1( 1 ), r2( 1 ), w, 1, rw, b, info )
279 CALL chkxer(
'ZGEESX', infot, nout, lerr, ok )
281 CALL zgeesx(
'N',
'N',
zslect,
'N', 2, a, 1, sdim, x, vl, 1,
282 $ r1( 1 ), r2( 1 ), w, 4, rw, b, info )
283 CALL chkxer(
'ZGEESX', infot, nout, lerr, ok )
285 CALL zgeesx(
'V',
'N',
zslect,
'N', 2, a, 2, sdim, x, vl, 1,
286 $ r1( 1 ), r2( 1 ), w, 4, rw, b, info )
287 CALL chkxer(
'ZGEESX', infot, nout, lerr, ok )
289 CALL zgeesx(
'N',
'N',
zslect,
'N', 1, a, 1, sdim, x, vl, 1,
290 $ r1( 1 ), r2( 1 ), w, 1, rw, b, info )
291 CALL chkxer(
'ZGEESX', infot, nout, lerr, ok )
294 ELSE IF(
lsamen( 2, c2,
'BD' ) )
THEN
300 CALL zgesvd(
'X',
'N', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, rw,
302 CALL chkxer(
'ZGESVD', infot, nout, lerr, ok )
304 CALL zgesvd(
'N',
'X', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, rw,
306 CALL chkxer(
'ZGESVD', infot, nout, lerr, ok )
308 CALL zgesvd(
'O',
'O', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, rw,
310 CALL chkxer(
'ZGESVD', infot, nout, lerr, ok )
312 CALL zgesvd(
'N',
'N', -1, 0, a, 1, s, u, 1, vt, 1, w, 1, rw,
314 CALL chkxer(
'ZGESVD', infot, nout, lerr, ok )
316 CALL zgesvd(
'N',
'N', 0, -1, a, 1, s, u, 1, vt, 1, w, 1, rw,
318 CALL chkxer(
'ZGESVD', infot, nout, lerr, ok )
320 CALL zgesvd(
'N',
'N', 2, 1, a, 1, s, u, 1, vt, 1, w, 5, rw,
322 CALL chkxer(
'ZGESVD', infot, nout, lerr, ok )
324 CALL zgesvd(
'A',
'N', 2, 1, a, 2, s, u, 1, vt, 1, w, 5, rw,
326 CALL chkxer(
'ZGESVD', infot, nout, lerr, ok )
328 CALL zgesvd(
'N',
'A', 1, 2, a, 1, s, u, 1, vt, 1, w, 5, rw,
330 CALL chkxer(
'ZGESVD', infot, nout, lerr, ok )
333 WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
336 WRITE( nout, fmt = 9998 )
343 CALL zgesdd(
'X', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, rw, iw,
345 CALL chkxer(
'ZGESDD', infot, nout, lerr, ok )
347 CALL zgesdd(
'N', -1, 0, a, 1, s, u, 1, vt, 1, w, 1, rw, iw,
349 CALL chkxer(
'ZGESDD', infot, nout, lerr, ok )
351 CALL zgesdd(
'N', 0, -1, a, 1, s, u, 1, vt, 1, w, 1, rw, iw,
353 CALL chkxer(
'ZGESDD', infot, nout, lerr, ok )
355 CALL zgesdd(
'N', 2, 1, a, 1, s, u, 1, vt, 1, w, 5, rw, iw,
357 CALL chkxer(
'ZGESDD', infot, nout, lerr, ok )
359 CALL zgesdd(
'A', 2, 1, a, 2, s, u, 1, vt, 1, w, 5, rw, iw,
361 CALL chkxer(
'ZGESDD', infot, nout, lerr, ok )
363 CALL zgesdd(
'A', 1, 2, a, 1, s, u, 1, vt, 1, w, 5, rw, iw,
365 CALL chkxer(
'ZGESDD', infot, nout, lerr, ok )
368 WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
371 WRITE( nout, fmt = 9998 )
378 CALL zgejsv(
'X',
'U',
'V',
'R',
'N',
'N',
379 $ 0, 0, a, 1, s, u, 1, vt, 1,
380 $ w, 1, rw, 1, iw, info)
381 CALL chkxer(
'ZGEJSV', infot, nout, lerr, ok )
383 CALL zgejsv(
'G',
'X',
'V',
'R',
'N',
'N',
384 $ 0, 0, a, 1, s, u, 1, vt, 1,
385 $ w, 1, rw, 1, iw, info)
386 CALL chkxer(
'ZGEJSV', infot, nout, lerr, ok )
388 CALL zgejsv(
'G',
'U',
'X',
'R',
'N',
'N',
389 $ 0, 0, a, 1, s, u, 1, vt, 1,
390 $ w, 1, rw, 1, iw, info)
391 CALL chkxer(
'ZGEJSV', infot, nout, lerr, ok )
393 CALL zgejsv(
'G',
'U',
'V',
'X',
'N',
'N',
394 $ 0, 0, a, 1, s, u, 1, vt, 1,
395 $ w, 1, rw, 1, iw, info)
396 CALL chkxer(
'ZGEJSV', infot, nout, lerr, ok )
398 CALL zgejsv(
'G',
'U',
'V',
'R',
'X',
'N',
399 $ 0, 0, a, 1, s, u, 1, vt, 1,
400 $ w, 1, rw, 1, iw, info)
401 CALL chkxer(
'ZGEJSV', infot, nout, lerr, ok )
403 CALL zgejsv(
'G',
'U',
'V',
'R',
'N',
'X',
404 $ 0, 0, a, 1, s, u, 1, vt, 1,
405 $ w, 1, rw, 1, iw, info)
406 CALL chkxer(
'ZGEJSV', infot, nout, lerr, ok )
408 CALL zgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
409 $ -1, 0, a, 1, s, u, 1, vt, 1,
410 $ w, 1, rw, 1, iw, info)
411 CALL chkxer(
'ZGEJSV', infot, nout, lerr, ok )
413 CALL zgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
414 $ 0, -1, a, 1, s, u, 1, vt, 1,
415 $ w, 1, rw, 1, iw, info)
416 CALL chkxer(
'ZGEJSV', infot, nout, lerr, ok )
418 CALL zgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
419 $ 2, 1, a, 1, s, u, 1, vt, 1,
420 $ w, 1, rw, 1, iw, info)
421 CALL chkxer(
'ZGEJSV', infot, nout, lerr, ok )
423 CALL zgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
424 $ 2, 2, a, 2, s, u, 1, vt, 2,
425 $ w, 1, rw, 1, iw, info)
426 CALL chkxer(
'ZGEJSV', infot, nout, lerr, ok )
428 CALL zgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
429 $ 2, 2, a, 2, s, u, 2, vt, 1,
430 $ w, 1, rw, 1, iw, info)
431 CALL chkxer(
'ZGEJSV', infot, nout, lerr, ok )
434 WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
437 WRITE( nout, fmt = 9998 )
444 CALL zgesvdx(
'X',
'N',
'A', 0, 0, a, 1, zero, zero,
445 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, rw, iw, info )
446 CALL chkxer(
'ZGESVDX', infot, nout, lerr, ok )
448 CALL zgesvdx(
'N',
'X',
'A', 0, 0, a, 1, zero, zero,
449 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, rw, iw, info )
450 CALL chkxer(
'ZGESVDX', infot, nout, lerr, ok )
452 CALL zgesvdx(
'N',
'N',
'X', 0, 0, a, 1, zero, zero,
453 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, rw, iw, info )
454 CALL chkxer(
'ZGESVDX', infot, nout, lerr, ok )
456 CALL zgesvdx(
'N',
'N',
'A', -1, 0, a, 1, zero, zero,
457 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, rw, iw, info )
458 CALL chkxer(
'ZGESVDX', infot, nout, lerr, ok )
460 CALL zgesvdx(
'N',
'N',
'A', 0, -1, a, 1, zero, zero,
461 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, rw, iw, info )
462 CALL chkxer(
'ZGESVDX', infot, nout, lerr, ok )
464 CALL zgesvdx(
'N',
'N',
'A', 2, 1, a, 1, zero, zero,
465 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, rw, iw, info )
466 CALL chkxer(
'ZGESVDX', infot, nout, lerr, ok )
468 CALL zgesvdx(
'N',
'N',
'V', 2, 1, a, 2, -one, zero,
469 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, rw, iw, info )
470 CALL chkxer(
'ZGESVDX', infot, nout, lerr, ok )
472 CALL zgesvdx(
'N',
'N',
'V', 2, 1, a, 2, one, zero,
473 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, rw, iw, info )
474 CALL chkxer(
'ZGESVDX', infot, nout, lerr, ok )
476 CALL zgesvdx(
'N',
'N',
'I', 2, 2, a, 2, zero, zero,
477 $ 0, 1, ns, s, u, 1, vt, 1, w, 1, rw, iw, info )
478 CALL chkxer(
'ZGESVDX', infot, nout, lerr, ok )
480 CALL zgesvdx(
'V',
'N',
'I', 2, 2, a, 2, zero, zero,
481 $ 1, 0, ns, s, u, 1, vt, 1, w, 1, rw, iw, info )
482 CALL chkxer(
'ZGESVDX', infot, nout, lerr, ok )
484 CALL zgesvdx(
'V',
'N',
'A', 2, 2, a, 2, zero, zero,
485 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, rw, iw, info )
486 CALL chkxer(
'ZGESVDX', infot, nout, lerr, ok )
488 CALL zgesvdx(
'N',
'V',
'A', 2, 2, a, 2, zero, zero,
489 $ 0, 0, ns, s, u, 1, vt, 1, w, 1, rw, iw, info )
490 CALL chkxer(
'ZGESVDX', infot, nout, lerr, ok )
493 WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
496 WRITE( nout, fmt = 9998 )
502 IF( .NOT.
lsamen( 2, c2,
'BD' ) )
THEN
504 WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
507 WRITE( nout, fmt = 9998 )
511 9999
FORMAT( 1x, a,
' passed the tests of the error exits (', i3,
513 9998
FORMAT(
' *** ', a,
' failed the tests of the error exits ***' )
subroutine zgesdd(JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, IWORK, INFO)
ZGESDD
subroutine zgesvd(JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, INFO)
ZGESVD computes the singular value decomposition (SVD) for GE matrices
subroutine zgees(JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS, LDVS, WORK, LWORK, RWORK, BWORK, INFO)
ZGEES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE ...
logical function lsamen(N, CA, CB)
LSAMEN
subroutine zgeev(JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO)
ZGEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices ...
subroutine zgesvdx(JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, IL, IU, NS, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, IWORK, INFO)
ZGESVDX computes the singular value decomposition (SVD) for GE matrices
subroutine chkxer(SRNAMT, INFOT, NOUT, LERR, OK)
subroutine zgesvj(JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, LDV, CWORK, LWORK, RWORK, LRWORK, INFO)
ZGESVJ
subroutine zgejsv(JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, M, N, A, LDA, SVA, U, LDU, V, LDV, CWORK, LWORK, RWORK, LRWORK, IWORK, INFO)
ZGEJSV
subroutine zgeevx(BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, RWORK, INFO)
ZGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices ...
subroutine zgeesx(JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, W, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, RWORK, BWORK, INFO)
ZGEESX computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE...
logical function zslect(Z)
ZSLECT