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 )
104 LOGICAL LSAMEN, SSLECT
105 EXTERNAL lsamen, sslect
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 ***' )
subroutine serred(PATH, NUNIT)
SERRED
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 ...
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 ...