83 DOUBLE PRECISION one, zero
84 parameter( nmax = 4, one = 1.0d0, zero = 0.0d0 )
88 INTEGER i, ihi, ilo, info,
j, nt, sdim
89 DOUBLE PRECISION abnrm
94 DOUBLE PRECISION 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 DOUBLE PRECISION 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
dgeev(
'X',
'N', 0, a, 1, wr, wi, vl, 1, vr, 1, w, 1,
151 CALL
chkxer(
'DGEEV ', infot, nout, lerr, ok )
153 CALL
dgeev(
'N',
'X', 0, a, 1, wr, wi, vl, 1, vr, 1, w, 1,
155 CALL
chkxer(
'DGEEV ', infot, nout, lerr, ok )
157 CALL
dgeev(
'N',
'N', -1, a, 1, wr, wi, vl, 1, vr, 1, w, 1,
159 CALL
chkxer(
'DGEEV ', infot, nout, lerr, ok )
161 CALL
dgeev(
'N',
'N', 2, a, 1, wr, wi, vl, 1, vr, 1, w, 6,
163 CALL
chkxer(
'DGEEV ', infot, nout, lerr, ok )
165 CALL
dgeev(
'V',
'N', 2, a, 2, wr, wi, vl, 1, vr, 1, w, 8,
167 CALL
chkxer(
'DGEEV ', infot, nout, lerr, ok )
169 CALL
dgeev(
'N',
'V', 2, a, 2, wr, wi, vl, 1, vr, 1, w, 8,
171 CALL
chkxer(
'DGEEV ', infot, nout, lerr, ok )
173 CALL
dgeev(
'V',
'V', 1, a, 1, wr, wi, vl, 1, vr, 1, w, 3,
175 CALL
chkxer(
'DGEEV ', infot, nout, lerr, ok )
178 ELSE IF(
lsamen( 2, c2,
'ES' ) )
THEN
184 CALL
dgees(
'X',
'N',
dslect, 0, a, 1, sdim, wr, wi, vl, 1, w,
186 CALL
chkxer(
'DGEES ', infot, nout, lerr, ok )
188 CALL
dgees(
'N',
'X',
dslect, 0, a, 1, sdim, wr, wi, vl, 1, w,
190 CALL
chkxer(
'DGEES ', infot, nout, lerr, ok )
192 CALL
dgees(
'N',
'S',
dslect, -1, a, 1, sdim, wr, wi, vl, 1, w,
194 CALL
chkxer(
'DGEES ', infot, nout, lerr, ok )
196 CALL
dgees(
'N',
'S',
dslect, 2, a, 1, sdim, wr, wi, vl, 1, w,
198 CALL
chkxer(
'DGEES ', infot, nout, lerr, ok )
200 CALL
dgees(
'V',
'S',
dslect, 2, a, 2, sdim, wr, wi, vl, 1, w,
202 CALL
chkxer(
'DGEES ', infot, nout, lerr, ok )
204 CALL
dgees(
'N',
'S',
dslect, 1, a, 1, sdim, wr, wi, vl, 1, w,
206 CALL
chkxer(
'DGEES ', infot, nout, lerr, ok )
209 ELSE IF(
lsamen( 2, c2,
'VX' ) )
THEN
215 CALL
dgeevx(
'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(
'DGEEVX', infot, nout, lerr, ok )
219 CALL
dgeevx(
'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(
'DGEEVX', infot, nout, lerr, ok )
223 CALL
dgeevx(
'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(
'DGEEVX', infot, nout, lerr, ok )
227 CALL
dgeevx(
'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(
'DGEEVX', infot, nout, lerr, ok )
231 CALL
dgeevx(
'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(
'DGEEVX', infot, nout, lerr, ok )
235 CALL
dgeevx(
'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(
'DGEEVX', infot, nout, lerr, ok )
239 CALL
dgeevx(
'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(
'DGEEVX', infot, nout, lerr, ok )
243 CALL
dgeevx(
'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(
'DGEEVX', infot, nout, lerr, ok )
247 CALL
dgeevx(
'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(
'DGEEVX', infot, nout, lerr, ok )
251 CALL
dgeevx(
'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(
'DGEEVX', infot, nout, lerr, ok )
255 CALL
dgeevx(
'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(
'DGEEVX', infot, nout, lerr, ok )
260 ELSE IF(
lsamen( 2, c2,
'SX' ) )
THEN
266 CALL
dgeesx(
'X',
'N',
dslect,
'N', 0, a, 1, sdim, wr, wi, vl,
267 $ 1, r1( 1 ), r2( 1 ), w, 1, iw, 1,
b, info )
268 CALL
chkxer(
'DGEESX', infot, nout, lerr, ok )
270 CALL
dgeesx(
'N',
'X',
dslect,
'N', 0, a, 1, sdim, wr, wi, vl,
271 $ 1, r1( 1 ), r2( 1 ), w, 1, iw, 1,
b, info )
272 CALL
chkxer(
'DGEESX', infot, nout, lerr, ok )
274 CALL
dgeesx(
'N',
'N',
dslect,
'X', 0, a, 1, sdim, wr, wi, vl,
275 $ 1, r1( 1 ), r2( 1 ), w, 1, iw, 1,
b, info )
276 CALL
chkxer(
'DGEESX', infot, nout, lerr, ok )
278 CALL
dgeesx(
'N',
'N',
dslect,
'N', -1, a, 1, sdim, wr, wi, vl,
279 $ 1, r1( 1 ), r2( 1 ), w, 1, iw, 1,
b, info )
280 CALL
chkxer(
'DGEESX', infot, nout, lerr, ok )
282 CALL
dgeesx(
'N',
'N',
dslect,
'N', 2, a, 1, sdim, wr, wi, vl,
283 $ 1, r1( 1 ), r2( 1 ), w, 6, iw, 1,
b, info )
284 CALL
chkxer(
'DGEESX', infot, nout, lerr, ok )
286 CALL
dgeesx(
'V',
'N',
dslect,
'N', 2, a, 2, sdim, wr, wi, vl,
287 $ 1, r1( 1 ), r2( 1 ), w, 6, iw, 1,
b, info )
288 CALL
chkxer(
'DGEESX', infot, nout, lerr, ok )
290 CALL
dgeesx(
'N',
'N',
dslect,
'N', 1, a, 1, sdim, wr, wi, vl,
291 $ 1, r1( 1 ), r2( 1 ), w, 2, iw, 1,
b, info )
292 CALL
chkxer(
'DGEESX', infot, nout, lerr, ok )
295 ELSE IF(
lsamen( 2, c2,
'BD' ) )
THEN
301 CALL
dgesvd(
'X',
'N', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, info )
302 CALL
chkxer(
'DGESVD', infot, nout, lerr, ok )
304 CALL
dgesvd(
'N',
'X', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, info )
305 CALL
chkxer(
'DGESVD', infot, nout, lerr, ok )
307 CALL
dgesvd(
'O',
'O', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, info )
308 CALL
chkxer(
'DGESVD', infot, nout, lerr, ok )
310 CALL
dgesvd(
'N',
'N', -1, 0, a, 1, s, u, 1, vt, 1, w, 1,
312 CALL
chkxer(
'DGESVD', infot, nout, lerr, ok )
314 CALL
dgesvd(
'N',
'N', 0, -1, a, 1, s, u, 1, vt, 1, w, 1,
316 CALL
chkxer(
'DGESVD', infot, nout, lerr, ok )
318 CALL
dgesvd(
'N',
'N', 2, 1, a, 1, s, u, 1, vt, 1, w, 5, info )
319 CALL
chkxer(
'DGESVD', infot, nout, lerr, ok )
321 CALL
dgesvd(
'A',
'N', 2, 1, a, 2, s, u, 1, vt, 1, w, 5, info )
322 CALL
chkxer(
'DGESVD', infot, nout, lerr, ok )
324 CALL
dgesvd(
'N',
'A', 1, 2, a, 1, s, u, 1, vt, 1, w, 5, info )
325 CALL
chkxer(
'DGESVD', infot, nout, lerr, ok )
328 WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
331 WRITE( nout, fmt = 9998 )
338 CALL
dgesdd(
'X', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, iw, info )
339 CALL
chkxer(
'DGESDD', infot, nout, lerr, ok )
341 CALL
dgesdd(
'N', -1, 0, a, 1, s, u, 1, vt, 1, w, 1, iw, info )
342 CALL
chkxer(
'DGESDD', infot, nout, lerr, ok )
344 CALL
dgesdd(
'N', 0, -1, a, 1, s, u, 1, vt, 1, w, 1, iw, info )
345 CALL
chkxer(
'DGESDD', infot, nout, lerr, ok )
347 CALL
dgesdd(
'N', 2, 1, a, 1, s, u, 1, vt, 1, w, 5, iw, info )
348 CALL
chkxer(
'DGESDD', infot, nout, lerr, ok )
350 CALL
dgesdd(
'A', 2, 1, a, 2, s, u, 1, vt, 1, w, 5, iw, info )
351 CALL
chkxer(
'DGESDD', infot, nout, lerr, ok )
353 CALL
dgesdd(
'A', 1, 2, a, 1, s, u, 1, vt, 1, w, 5, iw, info )
354 CALL
chkxer(
'DGESDD', infot, nout, lerr, ok )
357 WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
360 WRITE( nout, fmt = 9998 )
367 CALL
dgejsv(
'X',
'U',
'V',
'R',
'N',
'N',
368 $ 0, 0, a, 1, s, u, 1, vt, 1,
370 CALL
chkxer(
'DGEJSV', infot, nout, lerr, ok )
372 CALL
dgejsv(
'G',
'X',
'V',
'R',
'N',
'N',
373 $ 0, 0, a, 1, s, u, 1, vt, 1,
375 CALL
chkxer(
'DGEJSV', infot, nout, lerr, ok )
377 CALL
dgejsv(
'G',
'U',
'X',
'R',
'N',
'N',
378 $ 0, 0, a, 1, s, u, 1, vt, 1,
380 CALL
chkxer(
'DGEJSV', infot, nout, lerr, ok )
382 CALL
dgejsv(
'G',
'U',
'V',
'X',
'N',
'N',
383 $ 0, 0, a, 1, s, u, 1, vt, 1,
385 CALL
chkxer(
'DGEJSV', infot, nout, lerr, ok )
387 CALL
dgejsv(
'G',
'U',
'V',
'R',
'X',
'N',
388 $ 0, 0, a, 1, s, u, 1, vt, 1,
390 CALL
chkxer(
'DGEJSV', infot, nout, lerr, ok )
392 CALL
dgejsv(
'G',
'U',
'V',
'R',
'N',
'X',
393 $ 0, 0, a, 1, s, u, 1, vt, 1,
395 CALL
chkxer(
'DGEJSV', infot, nout, lerr, ok )
397 CALL
dgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
398 $ -1, 0, a, 1, s, u, 1, vt, 1,
400 CALL
chkxer(
'DGEJSV', infot, nout, lerr, ok )
402 CALL
dgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
403 $ 0, -1, a, 1, s, u, 1, vt, 1,
405 CALL
chkxer(
'DGEJSV', infot, nout, lerr, ok )
407 CALL
dgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
408 $ 2, 1, a, 1, s, u, 1, vt, 1,
410 CALL
chkxer(
'DGEJSV', infot, nout, lerr, ok )
412 CALL
dgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
413 $ 2, 2, a, 2, s, u, 1, vt, 2,
415 CALL
chkxer(
'DGEJSV', infot, nout, lerr, ok )
417 CALL
dgejsv(
'G',
'U',
'V',
'R',
'N',
'N',
418 $ 2, 2, a, 2, s, u, 2, vt, 1,
420 CALL
chkxer(
'DGEJSV', 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( 1
x, a,
' passed the tests of the error exits (', i3,
443 9998
FORMAT(
' *** ', a,
' failed the tests of the error exits ***' )
subroutine dgejsv(JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, M, N, A, LDA, SVA, U, LDU, V, LDV, WORK, LWORK, IWORK, INFO)
DGEJSV
LOGICAL function dslect(ZR, ZI)
DSLECT
subroutine derred(PATH, NUNIT)
DERRED
subroutine dgesdd(JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, IWORK, INFO)
DGESDD
subroutine chkxer(SRNAMT, INFOT, NOUT, LERR, OK)
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
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 ...
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...
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
LOGICAL function lsamen(N, CA, CB)
LSAMEN
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 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 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 ...