84 parameter( nmax = 4, one = 1.0e0, zero = 0.0e0 )
88 INTEGER i, ihi, ilo, info, j, nt, sdim
94 REAL 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 )
112 REAL 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 sgeev(
'X',
'N', 0, a, 1, wr, wi, vl, 1, vr, 1, w, 1,
151 CALL chkxer(
'SGEEV ', infot, nout, lerr, ok )
153 CALL sgeev(
'N',
'X', 0, a, 1, wr, wi, vl, 1, vr, 1, w, 1,
155 CALL chkxer(
'SGEEV ', infot, nout, lerr, ok )
157 CALL sgeev(
'N',
'N', -1, a, 1, wr, wi, vl, 1, vr, 1, w, 1,
159 CALL chkxer(
'SGEEV ', infot, nout, lerr, ok )
161 CALL sgeev(
'N',
'N', 2, a, 1, wr, wi, vl, 1, vr, 1, w, 6,
163 CALL chkxer(
'SGEEV ', infot, nout, lerr, ok )
165 CALL sgeev(
'V',
'N', 2, a, 2, wr, wi, vl, 1, vr, 1, w, 8,
167 CALL chkxer(
'SGEEV ', infot, nout, lerr, ok )
169 CALL sgeev(
'N',
'V', 2, a, 2, wr, wi, vl, 1, vr, 1, w, 8,
171 CALL chkxer(
'SGEEV ', infot, nout, lerr, ok )
173 CALL sgeev(
'V',
'V', 1, a, 1, wr, wi, vl, 1, vr, 1, w, 3,
175 CALL chkxer(
'SGEEV ', infot, nout, lerr, ok )
178 ELSE IF(
lsamen( 2, c2,
'ES' ) )
THEN
184 CALL sgees(
'X',
'N',
sslect, 0, a, 1, sdim, wr, wi, vl, 1, w,
186 CALL chkxer(
'SGEES ', infot, nout, lerr, ok )
188 CALL sgees(
'N',
'X',
sslect, 0, a, 1, sdim, wr, wi, vl, 1, w,
190 CALL chkxer(
'SGEES ', infot, nout, lerr, ok )
192 CALL sgees(
'N',
'S',
sslect, -1, a, 1, sdim, wr, wi, vl, 1, w,
194 CALL chkxer(
'SGEES ', infot, nout, lerr, ok )
196 CALL sgees(
'N',
'S',
sslect, 2, a, 1, sdim, wr, wi, vl, 1, w,
198 CALL chkxer(
'SGEES ', infot, nout, lerr, ok )
200 CALL sgees(
'V',
'S',
sslect, 2, a, 2, sdim, wr, wi, vl, 1, w,
202 CALL chkxer(
'SGEES ', infot, nout, lerr, ok )
204 CALL sgees(
'N',
'S',
sslect, 1, a, 1, sdim, wr, wi, vl, 1, w,
206 CALL chkxer(
'SGEES ', infot, nout, lerr, ok )
209 ELSE IF(
lsamen( 2, c2,
'VX' ) )
THEN
215 CALL sgeevx(
'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(
'SGEEVX', infot, nout, lerr, ok )
219 CALL sgeevx(
'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(
'SGEEVX', infot, nout, lerr, ok )
223 CALL sgeevx(
'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(
'SGEEVX', infot, nout, lerr, ok )
227 CALL sgeevx(
'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(
'SGEEVX', infot, nout, lerr, ok )
231 CALL sgeevx(
'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(
'SGEEVX', infot, nout, lerr, ok )
235 CALL sgeevx(
'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(
'SGEEVX', infot, nout, lerr, ok )
239 CALL sgeevx(
'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(
'SGEEVX', infot, nout, lerr, ok )
243 CALL sgeevx(
'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(
'SGEEVX', infot, nout, lerr, ok )
247 CALL sgeevx(
'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(
'SGEEVX', infot, nout, lerr, ok )
251 CALL sgeevx(
'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(
'SGEEVX', infot, nout, lerr, ok )
255 CALL sgeevx(
'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(
'SGEEVX', infot, nout, lerr, ok )
260 ELSE IF(
lsamen( 2, c2,
'SX' ) )
THEN
266 CALL sgeesx(
'X',
'N',
sslect,
'N', 0, a, 1, sdim, wr, wi, vl,
267 $ 1, r1( 1 ), r2( 1 ), w, 1, iw, 1, b, info )
268 CALL chkxer(
'SGEESX', infot, nout, lerr, ok )
270 CALL sgeesx(
'N',
'X',
sslect,
'N', 0, a, 1, sdim, wr, wi, vl,
271 $ 1, r1( 1 ), r2( 1 ), w, 1, iw, 1, b, info )
272 CALL chkxer(
'SGEESX', infot, nout, lerr, ok )
274 CALL sgeesx(
'N',
'N',
sslect,
'X', 0, a, 1, sdim, wr, wi, vl,
275 $ 1, r1( 1 ), r2( 1 ), w, 1, iw, 1, b, info )
276 CALL chkxer(
'SGEESX', infot, nout, lerr, ok )
278 CALL sgeesx(
'N',
'N',
sslect,
'N', -1, a, 1, sdim, wr, wi, vl,
279 $ 1, r1( 1 ), r2( 1 ), w, 1, iw, 1, b, info )
280 CALL chkxer(
'SGEESX', infot, nout, lerr, ok )
282 CALL sgeesx(
'N',
'N',
sslect,
'N', 2, a, 1, sdim, wr, wi, vl,
283 $ 1, r1( 1 ), r2( 1 ), w, 6, iw, 1, b, info )
284 CALL chkxer(
'SGEESX', infot, nout, lerr, ok )
286 CALL sgeesx(
'V',
'N',
sslect,
'N', 2, a, 2, sdim, wr, wi, vl,
287 $ 1, r1( 1 ), r2( 1 ), w, 6, iw, 1, b, info )
288 CALL chkxer(
'SGEESX', infot, nout, lerr, ok )
290 CALL sgeesx(
'N',
'N',
sslect,
'N', 1, a, 1, sdim, wr, wi, vl,
291 $ 1, r1( 1 ), r2( 1 ), w, 2, iw, 1, b, info )
292 CALL chkxer(
'SGEESX', infot, nout, lerr, ok )
295 ELSE IF(
lsamen( 2, c2,
'BD' ) )
THEN
301 CALL sgesvd(
'X',
'N', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, info )
302 CALL chkxer(
'SGESVD', infot, nout, lerr, ok )
304 CALL sgesvd(
'N',
'X', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, info )
305 CALL chkxer(
'SGESVD', infot, nout, lerr, ok )
307 CALL sgesvd(
'O',
'O', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, info )
308 CALL chkxer(
'SGESVD', infot, nout, lerr, ok )
310 CALL sgesvd(
'N',
'N', -1, 0, a, 1, s, u, 1, vt, 1, w, 1,
312 CALL chkxer(
'SGESVD', infot, nout, lerr, ok )
314 CALL sgesvd(
'N',
'N', 0, -1, a, 1, s, u, 1, vt, 1, w, 1,
316 CALL chkxer(
'SGESVD', infot, nout, lerr, ok )
318 CALL sgesvd(
'N',
'N', 2, 1, a, 1, s, u, 1, vt, 1, w, 5, info )
319 CALL chkxer(
'SGESVD', infot, nout, lerr, ok )
321 CALL sgesvd(
'A',
'N', 2, 1, a, 2, s, u, 1, vt, 1, w, 5, info )
322 CALL chkxer(
'SGESVD', infot, nout, lerr, ok )
324 CALL sgesvd(
'N',
'A', 1, 2, a, 1, s, u, 1, vt, 1, w, 5, info )
325 CALL chkxer(
'SGESVD', infot, nout, lerr, ok )
328 WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
331 WRITE( nout, fmt = 9998 )
338 CALL sgesdd(
'X', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, iw, info )
339 CALL chkxer(
'SGESDD', infot, nout, lerr, ok )
341 CALL sgesdd(
'N', -1, 0, a, 1, s, u, 1, vt, 1, w, 1, iw, info )
342 CALL chkxer(
'SGESDD', infot, nout, lerr, ok )
344 CALL sgesdd(
'N', 0, -1, a, 1, s, u, 1, vt, 1, w, 1, iw, info )
345 CALL chkxer(
'SGESDD', infot, nout, lerr, ok )
347 CALL sgesdd(
'N', 2, 1, a, 1, s, u, 1, vt, 1, w, 5, iw, info )
348 CALL chkxer(
'SGESDD', infot, nout, lerr, ok )
350 CALL sgesdd(
'A', 2, 1, a, 2, s, u, 1, vt, 1, w, 5, iw, info )
351 CALL chkxer(
'SGESDD', infot, nout, lerr, ok )
353 CALL sgesdd(
'A', 1, 2, a, 1, s, u, 1, vt, 1, w, 5, iw, info )
354 CALL chkxer(
'SGESDD', infot, nout, lerr, ok )
357 WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
360 WRITE( nout, fmt = 9998 )
367 CALL sgejsv(
'X',
'U',
'V',
'R',
'N',
'N',
368 $ 0, 0, a, 1, s, u, 1, vt, 1,
370 CALL chkxer(
'SGEJSV', infot, nout, lerr, ok )
372 CALL sgejsv(
'G',
'X',
'V',
'R',
'N',
'N',
373 $ 0, 0, a, 1, s, u, 1, vt, 1,
375 CALL chkxer(
'SGEJSV', infot, nout, lerr, ok )
377 CALL sgejsv(
'G',
'U',
'X',
'R',
'N',
'N',
378 $ 0, 0, a, 1, s, u, 1, vt, 1,
380 CALL chkxer(
'SGEJSV', infot, nout, lerr, ok )
382 CALL sgejsv(
'G',
'U',
'V',
'X',
'N',
'N',
383 $ 0, 0, a, 1, s, u, 1, vt, 1,
385 CALL chkxer(
'SGEJSV', infot, nout, lerr, ok )
387 CALL sgejsv(
'G',
'U',
'V',
'R',
'X',
'N',
388 $ 0, 0, a, 1, s, u, 1, vt, 1,
390 CALL chkxer(
'SGEJSV', infot, nout, lerr, ok )
392 CALL sgejsv(
'G',
'U',
'V',
'R',
'N',
'X',
393 $ 0, 0, a, 1, s, u, 1, vt, 1,
395 CALL chkxer(
'SGEJSV', infot, nout, lerr, ok )
397 CALL sgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
398 $ -1, 0, a, 1, s, u, 1, vt, 1,
400 CALL chkxer(
'SGEJSV', infot, nout, lerr, ok )
402 CALL sgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
403 $ 0, -1, a, 1, s, u, 1, vt, 1,
405 CALL chkxer(
'SGEJSV', infot, nout, lerr, ok )
407 CALL sgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
408 $ 2, 1, a, 1, s, u, 1, vt, 1,
410 CALL chkxer(
'SGEJSV', infot, nout, lerr, ok )
412 CALL sgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
413 $ 2, 2, a, 2, s, u, 1, vt, 2,
415 CALL chkxer(
'SGEJSV', infot, nout, lerr, ok )
417 CALL sgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
418 $ 2, 2, a, 2, s, u, 2, vt, 1,
420 CALL chkxer(
'SGEJSV', 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 ***' )
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 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
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
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 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 ...