86 parameter ( nmax = 4, one = 1.0e0, zero = 0.0e0 )
90 INTEGER i, ihi, ilo, info, j, ns, nt, sdim
96 REAL 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 REAL 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 sgeev(
'X',
'N', 0, a, 1, wr, wi, vl, 1, vr, 1, w, 1,
153 CALL chkxer(
'SGEEV ', infot, nout, lerr, ok )
155 CALL sgeev(
'N',
'X', 0, a, 1, wr, wi, vl, 1, vr, 1, w, 1,
157 CALL chkxer(
'SGEEV ', infot, nout, lerr, ok )
159 CALL sgeev(
'N',
'N', -1, a, 1, wr, wi, vl, 1, vr, 1, w, 1,
161 CALL chkxer(
'SGEEV ', infot, nout, lerr, ok )
163 CALL sgeev(
'N',
'N', 2, a, 1, wr, wi, vl, 1, vr, 1, w, 6,
165 CALL chkxer(
'SGEEV ', infot, nout, lerr, ok )
167 CALL sgeev(
'V',
'N', 2, a, 2, wr, wi, vl, 1, vr, 1, w, 8,
169 CALL chkxer(
'SGEEV ', infot, nout, lerr, ok )
171 CALL sgeev(
'N',
'V', 2, a, 2, wr, wi, vl, 1, vr, 1, w, 8,
173 CALL chkxer(
'SGEEV ', infot, nout, lerr, ok )
175 CALL sgeev(
'V',
'V', 1, a, 1, wr, wi, vl, 1, vr, 1, w, 3,
177 CALL chkxer(
'SGEEV ', infot, nout, lerr, ok )
180 ELSE IF(
lsamen( 2, c2,
'ES' ) )
THEN
186 CALL sgees(
'X',
'N',
sslect, 0, a, 1, sdim, wr, wi, vl, 1, w,
188 CALL chkxer(
'SGEES ', infot, nout, lerr, ok )
190 CALL sgees(
'N',
'X',
sslect, 0, a, 1, sdim, wr, wi, vl, 1, w,
192 CALL chkxer(
'SGEES ', infot, nout, lerr, ok )
194 CALL sgees(
'N',
'S',
sslect, -1, a, 1, sdim, wr, wi, vl, 1, w,
196 CALL chkxer(
'SGEES ', infot, nout, lerr, ok )
198 CALL sgees(
'N',
'S',
sslect, 2, a, 1, sdim, wr, wi, vl, 1, w,
200 CALL chkxer(
'SGEES ', infot, nout, lerr, ok )
202 CALL sgees(
'V',
'S',
sslect, 2, a, 2, sdim, wr, wi, vl, 1, w,
204 CALL chkxer(
'SGEES ', infot, nout, lerr, ok )
206 CALL sgees(
'N',
'S',
sslect, 1, a, 1, sdim, wr, wi, vl, 1, w,
208 CALL chkxer(
'SGEES ', infot, nout, lerr, ok )
211 ELSE IF(
lsamen( 2, c2,
'VX' ) )
THEN
217 CALL sgeevx(
'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(
'SGEEVX', infot, nout, lerr, ok )
221 CALL sgeevx(
'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(
'SGEEVX', infot, nout, lerr, ok )
225 CALL sgeevx(
'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(
'SGEEVX', infot, nout, lerr, ok )
229 CALL sgeevx(
'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(
'SGEEVX', infot, nout, lerr, ok )
233 CALL sgeevx(
'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(
'SGEEVX', infot, nout, lerr, ok )
237 CALL sgeevx(
'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(
'SGEEVX', infot, nout, lerr, ok )
241 CALL sgeevx(
'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(
'SGEEVX', infot, nout, lerr, ok )
245 CALL sgeevx(
'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(
'SGEEVX', infot, nout, lerr, ok )
249 CALL sgeevx(
'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(
'SGEEVX', infot, nout, lerr, ok )
253 CALL sgeevx(
'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(
'SGEEVX', infot, nout, lerr, ok )
257 CALL sgeevx(
'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(
'SGEEVX', infot, nout, lerr, ok )
262 ELSE IF(
lsamen( 2, c2,
'SX' ) )
THEN
268 CALL sgeesx(
'X',
'N',
sslect,
'N', 0, a, 1, sdim, wr, wi, vl,
269 $ 1, r1( 1 ), r2( 1 ), w, 1, iw, 1, b, info )
270 CALL chkxer(
'SGEESX', infot, nout, lerr, ok )
272 CALL sgeesx(
'N',
'X',
sslect,
'N', 0, a, 1, sdim, wr, wi, vl,
273 $ 1, r1( 1 ), r2( 1 ), w, 1, iw, 1, b, info )
274 CALL chkxer(
'SGEESX', infot, nout, lerr, ok )
276 CALL sgeesx(
'N',
'N',
sslect,
'X', 0, a, 1, sdim, wr, wi, vl,
277 $ 1, r1( 1 ), r2( 1 ), w, 1, iw, 1, b, info )
278 CALL chkxer(
'SGEESX', infot, nout, lerr, ok )
280 CALL sgeesx(
'N',
'N',
sslect,
'N', -1, a, 1, sdim, wr, wi, vl,
281 $ 1, r1( 1 ), r2( 1 ), w, 1, iw, 1, b, info )
282 CALL chkxer(
'SGEESX', infot, nout, lerr, ok )
284 CALL sgeesx(
'N',
'N',
sslect,
'N', 2, a, 1, sdim, wr, wi, vl,
285 $ 1, r1( 1 ), r2( 1 ), w, 6, iw, 1, b, info )
286 CALL chkxer(
'SGEESX', infot, nout, lerr, ok )
288 CALL sgeesx(
'V',
'N',
sslect,
'N', 2, a, 2, sdim, wr, wi, vl,
289 $ 1, r1( 1 ), r2( 1 ), w, 6, iw, 1, b, info )
290 CALL chkxer(
'SGEESX', infot, nout, lerr, ok )
292 CALL sgeesx(
'N',
'N',
sslect,
'N', 1, a, 1, sdim, wr, wi, vl,
293 $ 1, r1( 1 ), r2( 1 ), w, 2, iw, 1, b, info )
294 CALL chkxer(
'SGEESX', infot, nout, lerr, ok )
297 ELSE IF(
lsamen( 2, c2,
'BD' ) )
THEN
303 CALL sgesvd(
'X',
'N', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, info )
304 CALL chkxer(
'SGESVD', infot, nout, lerr, ok )
306 CALL sgesvd(
'N',
'X', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, info )
307 CALL chkxer(
'SGESVD', infot, nout, lerr, ok )
309 CALL sgesvd(
'O',
'O', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, info )
310 CALL chkxer(
'SGESVD', infot, nout, lerr, ok )
312 CALL sgesvd(
'N',
'N', -1, 0, a, 1, s, u, 1, vt, 1, w, 1,
314 CALL chkxer(
'SGESVD', infot, nout, lerr, ok )
316 CALL sgesvd(
'N',
'N', 0, -1, a, 1, s, u, 1, vt, 1, w, 1,
318 CALL chkxer(
'SGESVD', infot, nout, lerr, ok )
320 CALL sgesvd(
'N',
'N', 2, 1, a, 1, s, u, 1, vt, 1, w, 5, info )
321 CALL chkxer(
'SGESVD', infot, nout, lerr, ok )
323 CALL sgesvd(
'A',
'N', 2, 1, a, 2, s, u, 1, vt, 1, w, 5, info )
324 CALL chkxer(
'SGESVD', infot, nout, lerr, ok )
326 CALL sgesvd(
'N',
'A', 1, 2, a, 1, s, u, 1, vt, 1, w, 5, info )
327 CALL chkxer(
'SGESVD', infot, nout, lerr, ok )
330 WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
333 WRITE( nout, fmt = 9998 )
340 CALL sgesdd(
'X', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, iw, info )
341 CALL chkxer(
'SGESDD', infot, nout, lerr, ok )
343 CALL sgesdd(
'N', -1, 0, a, 1, s, u, 1, vt, 1, w, 1, iw, info )
344 CALL chkxer(
'SGESDD', infot, nout, lerr, ok )
346 CALL sgesdd(
'N', 0, -1, a, 1, s, u, 1, vt, 1, w, 1, iw, info )
347 CALL chkxer(
'SGESDD', infot, nout, lerr, ok )
349 CALL sgesdd(
'N', 2, 1, a, 1, s, u, 1, vt, 1, w, 5, iw, info )
350 CALL chkxer(
'SGESDD', infot, nout, lerr, ok )
352 CALL sgesdd(
'A', 2, 1, a, 2, s, u, 1, vt, 1, w, 5, iw, info )
353 CALL chkxer(
'SGESDD', infot, nout, lerr, ok )
355 CALL sgesdd(
'A', 1, 2, a, 1, s, u, 1, vt, 1, w, 5, iw, info )
356 CALL chkxer(
'SGESDD', infot, nout, lerr, ok )
359 WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
362 WRITE( nout, fmt = 9998 )
369 CALL sgejsv(
'X',
'U',
'V',
'R',
'N',
'N',
370 $ 0, 0, a, 1, s, u, 1, vt, 1,
372 CALL chkxer(
'SGEJSV', infot, nout, lerr, ok )
374 CALL sgejsv(
'G',
'X',
'V',
'R',
'N',
'N',
375 $ 0, 0, a, 1, s, u, 1, vt, 1,
377 CALL chkxer(
'SGEJSV', infot, nout, lerr, ok )
379 CALL sgejsv(
'G',
'U',
'X',
'R',
'N',
'N',
380 $ 0, 0, a, 1, s, u, 1, vt, 1,
382 CALL chkxer(
'SGEJSV', infot, nout, lerr, ok )
384 CALL sgejsv(
'G',
'U',
'V',
'X',
'N',
'N',
385 $ 0, 0, a, 1, s, u, 1, vt, 1,
387 CALL chkxer(
'SGEJSV', infot, nout, lerr, ok )
389 CALL sgejsv(
'G',
'U',
'V',
'R',
'X',
'N',
390 $ 0, 0, a, 1, s, u, 1, vt, 1,
392 CALL chkxer(
'SGEJSV', infot, nout, lerr, ok )
394 CALL sgejsv(
'G',
'U',
'V',
'R',
'N',
'X',
395 $ 0, 0, a, 1, s, u, 1, vt, 1,
397 CALL chkxer(
'SGEJSV', infot, nout, lerr, ok )
399 CALL sgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
400 $ -1, 0, a, 1, s, u, 1, vt, 1,
402 CALL chkxer(
'SGEJSV', infot, nout, lerr, ok )
404 CALL sgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
405 $ 0, -1, a, 1, s, u, 1, vt, 1,
407 CALL chkxer(
'SGEJSV', infot, nout, lerr, ok )
409 CALL sgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
410 $ 2, 1, a, 1, s, u, 1, vt, 1,
412 CALL chkxer(
'SGEJSV', infot, nout, lerr, ok )
414 CALL sgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
415 $ 2, 2, a, 2, s, u, 1, vt, 2,
417 CALL chkxer(
'SGEJSV', infot, nout, lerr, ok )
419 CALL sgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
420 $ 2, 2, a, 2, s, u, 2, vt, 1,
422 CALL chkxer(
'SGEJSV', infot, nout, lerr, ok )
425 WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
428 WRITE( nout, fmt = 9998 )
435 CALL sgesvdx(
'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(
'SGESVDX', infot, nout, lerr, ok )
439 CALL sgesvdx(
'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(
'SGESVDX', infot, nout, lerr, ok )
443 CALL sgesvdx(
'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(
'SGESVDX', infot, nout, lerr, ok )
447 CALL sgesvdx(
'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(
'SGESVDX', infot, nout, lerr, ok )
451 CALL sgesvdx(
'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(
'SGESVDX', infot, nout, lerr, ok )
455 CALL sgesvdx(
'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(
'SGESVDX', infot, nout, lerr, ok )
459 CALL sgesvdx(
'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(
'SGESVDX', infot, nout, lerr, ok )
463 CALL sgesvdx(
'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(
'SGESVDX', infot, nout, lerr, ok )
467 CALL sgesvdx(
'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(
'SGESVDX', infot, nout, lerr, ok )
471 CALL sgesvdx(
'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(
'SGESVDX', infot, nout, lerr, ok )
475 CALL sgesvdx(
'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(
'SGESVDX', infot, nout, lerr, ok )
479 CALL sgesvdx(
'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(
'SGESVDX', 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 sgeesx(JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, IWORK, LIWORK, BWORK, INFO)
SGEESX computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE...
subroutine sgees(JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, VS, LDVS, WORK, LWORK, BWORK, INFO)
SGEES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE ...
logical function lsamen(N, CA, CB)
LSAMEN
logical function sslect(ZR, ZI)
SSLECT
subroutine chkxer(SRNAMT, INFOT, NOUT, LERR, OK)
subroutine sgejsv(JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, M, N, A, LDA, SVA, U, LDU, V, LDV, WORK, LWORK, IWORK, INFO)
SGEJSV
subroutine sgeevx(BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, IWORK, INFO)
SGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices ...
subroutine sgesvdx(JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU, IL, IU, NS, S, U, LDU, VT, LDVT, WORK, LWORK, IWORK, INFO)
SGESVDX computes the singular value decomposition (SVD) for GE matrices
subroutine sgesvd(JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, INFO)
SGESVD computes the singular value decomposition (SVD) for GE matrices
subroutine sgeev(JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, WORK, LWORK, INFO)
SGEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices ...
subroutine sgesdd(JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, IWORK, INFO)
SGESDD