dgeevx.c 24 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704
  1. /* dgeevx.f -- translated by f2c (version 20061008).
  2. You must link the resulting object file with libf2c:
  3. on Microsoft Windows system, link with libf2c.lib;
  4. on Linux or Unix systems, link with .../path/to/libf2c.a -lm
  5. or, if you install libf2c.a in a standard place, with -lf2c -lm
  6. -- in that order, at the end of the command line, as in
  7. cc *.o -lf2c -lm
  8. Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
  9. http://www.netlib.org/f2c/libf2c.zip
  10. */
  11. #include "f2c.h"
  12. #include "blaswrap.h"
  13. /* Table of constant values */
  14. static integer c__1 = 1;
  15. static integer c__0 = 0;
  16. static integer c_n1 = -1;
  17. /* Subroutine */ int _starpu_dgeevx_(char *balanc, char *jobvl, char *jobvr, char *
  18. sense, integer *n, doublereal *a, integer *lda, doublereal *wr,
  19. doublereal *wi, doublereal *vl, integer *ldvl, doublereal *vr,
  20. integer *ldvr, integer *ilo, integer *ihi, doublereal *scale,
  21. doublereal *abnrm, doublereal *rconde, doublereal *rcondv, doublereal
  22. *work, integer *lwork, integer *iwork, integer *info)
  23. {
  24. /* System generated locals */
  25. integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
  26. i__2, i__3;
  27. doublereal d__1, d__2;
  28. /* Builtin functions */
  29. double sqrt(doublereal);
  30. /* Local variables */
  31. integer i__, k;
  32. doublereal r__, cs, sn;
  33. char job[1];
  34. doublereal scl, dum[1], eps;
  35. char side[1];
  36. doublereal anrm;
  37. integer ierr, itau;
  38. extern /* Subroutine */ int _starpu_drot_(integer *, doublereal *, integer *,
  39. doublereal *, integer *, doublereal *, doublereal *);
  40. integer iwrk, nout;
  41. extern doublereal _starpu_dnrm2_(integer *, doublereal *, integer *);
  42. extern /* Subroutine */ int _starpu_dscal_(integer *, doublereal *, doublereal *,
  43. integer *);
  44. integer icond;
  45. extern logical _starpu_lsame_(char *, char *);
  46. extern doublereal _starpu_dlapy2_(doublereal *, doublereal *);
  47. extern /* Subroutine */ int _starpu_dlabad_(doublereal *, doublereal *), _starpu_dgebak_(
  48. char *, char *, integer *, integer *, integer *, doublereal *,
  49. integer *, doublereal *, integer *, integer *),
  50. _starpu_dgebal_(char *, integer *, doublereal *, integer *, integer *,
  51. integer *, doublereal *, integer *);
  52. logical scalea;
  53. extern doublereal _starpu_dlamch_(char *);
  54. doublereal cscale;
  55. extern doublereal _starpu_dlange_(char *, integer *, integer *, doublereal *,
  56. integer *, doublereal *);
  57. extern /* Subroutine */ int _starpu_dgehrd_(integer *, integer *, integer *,
  58. doublereal *, integer *, doublereal *, doublereal *, integer *,
  59. integer *), _starpu_dlascl_(char *, integer *, integer *, doublereal *,
  60. doublereal *, integer *, integer *, doublereal *, integer *,
  61. integer *);
  62. extern integer _starpu_idamax_(integer *, doublereal *, integer *);
  63. extern /* Subroutine */ int _starpu_dlacpy_(char *, integer *, integer *,
  64. doublereal *, integer *, doublereal *, integer *),
  65. _starpu_dlartg_(doublereal *, doublereal *, doublereal *, doublereal *,
  66. doublereal *), _starpu_xerbla_(char *, integer *);
  67. logical select[1];
  68. extern integer _starpu_ilaenv_(integer *, char *, char *, integer *, integer *,
  69. integer *, integer *);
  70. doublereal bignum;
  71. extern /* Subroutine */ int _starpu_dorghr_(integer *, integer *, integer *,
  72. doublereal *, integer *, doublereal *, doublereal *, integer *,
  73. integer *), _starpu_dhseqr_(char *, char *, integer *, integer *, integer
  74. *, doublereal *, integer *, doublereal *, doublereal *,
  75. doublereal *, integer *, doublereal *, integer *, integer *), _starpu_dtrevc_(char *, char *, logical *, integer *,
  76. doublereal *, integer *, doublereal *, integer *, doublereal *,
  77. integer *, integer *, integer *, doublereal *, integer *), _starpu_dtrsna_(char *, char *, logical *, integer *, doublereal
  78. *, integer *, doublereal *, integer *, doublereal *, integer *,
  79. doublereal *, doublereal *, integer *, integer *, doublereal *,
  80. integer *, integer *, integer *);
  81. integer minwrk, maxwrk;
  82. logical wantvl, wntsnb;
  83. integer hswork;
  84. logical wntsne;
  85. doublereal smlnum;
  86. logical lquery, wantvr, wntsnn, wntsnv;
  87. /* -- LAPACK driver routine (version 3.2) -- */
  88. /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
  89. /* November 2006 */
  90. /* .. Scalar Arguments .. */
  91. /* .. */
  92. /* .. Array Arguments .. */
  93. /* .. */
  94. /* Purpose */
  95. /* ======= */
  96. /* DGEEVX computes for an N-by-N real nonsymmetric matrix A, the */
  97. /* eigenvalues and, optionally, the left and/or right eigenvectors. */
  98. /* Optionally also, it computes a balancing transformation to improve */
  99. /* the conditioning of the eigenvalues and eigenvectors (ILO, IHI, */
  100. /* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues */
  101. /* (RCONDE), and reciprocal condition numbers for the right */
  102. /* eigenvectors (RCONDV). */
  103. /* The right eigenvector v(j) of A satisfies */
  104. /* A * v(j) = lambda(j) * v(j) */
  105. /* where lambda(j) is its eigenvalue. */
  106. /* The left eigenvector u(j) of A satisfies */
  107. /* u(j)**H * A = lambda(j) * u(j)**H */
  108. /* where u(j)**H denotes the conjugate transpose of u(j). */
  109. /* The computed eigenvectors are normalized to have Euclidean norm */
  110. /* equal to 1 and largest component real. */
  111. /* Balancing a matrix means permuting the rows and columns to make it */
  112. /* more nearly upper triangular, and applying a diagonal similarity */
  113. /* transformation D * A * D**(-1), where D is a diagonal matrix, to */
  114. /* make its rows and columns closer in norm and the condition numbers */
  115. /* of its eigenvalues and eigenvectors smaller. The computed */
  116. /* reciprocal condition numbers correspond to the balanced matrix. */
  117. /* Permuting rows and columns will not change the condition numbers */
  118. /* (in exact arithmetic) but diagonal scaling will. For further */
  119. /* explanation of balancing, see section 4.10.2 of the LAPACK */
  120. /* Users' Guide. */
  121. /* Arguments */
  122. /* ========= */
  123. /* BALANC (input) CHARACTER*1 */
  124. /* Indicates how the input matrix should be diagonally scaled */
  125. /* and/or permuted to improve the conditioning of its */
  126. /* eigenvalues. */
  127. /* = 'N': Do not diagonally scale or permute; */
  128. /* = 'P': Perform permutations to make the matrix more nearly */
  129. /* upper triangular. Do not diagonally scale; */
  130. /* = 'S': Diagonally scale the matrix, i.e. replace A by */
  131. /* D*A*D**(-1), where D is a diagonal matrix chosen */
  132. /* to make the rows and columns of A more equal in */
  133. /* norm. Do not permute; */
  134. /* = 'B': Both diagonally scale and permute A. */
  135. /* Computed reciprocal condition numbers will be for the matrix */
  136. /* after balancing and/or permuting. Permuting does not change */
  137. /* condition numbers (in exact arithmetic), but balancing does. */
  138. /* JOBVL (input) CHARACTER*1 */
  139. /* = 'N': left eigenvectors of A are not computed; */
  140. /* = 'V': left eigenvectors of A are computed. */
  141. /* If SENSE = 'E' or 'B', JOBVL must = 'V'. */
  142. /* JOBVR (input) CHARACTER*1 */
  143. /* = 'N': right eigenvectors of A are not computed; */
  144. /* = 'V': right eigenvectors of A are computed. */
  145. /* If SENSE = 'E' or 'B', JOBVR must = 'V'. */
  146. /* SENSE (input) CHARACTER*1 */
  147. /* Determines which reciprocal condition numbers are computed. */
  148. /* = 'N': None are computed; */
  149. /* = 'E': Computed for eigenvalues only; */
  150. /* = 'V': Computed for right eigenvectors only; */
  151. /* = 'B': Computed for eigenvalues and right eigenvectors. */
  152. /* If SENSE = 'E' or 'B', both left and right eigenvectors */
  153. /* must also be computed (JOBVL = 'V' and JOBVR = 'V'). */
  154. /* N (input) INTEGER */
  155. /* The order of the matrix A. N >= 0. */
  156. /* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
  157. /* On entry, the N-by-N matrix A. */
  158. /* On exit, A has been overwritten. If JOBVL = 'V' or */
  159. /* JOBVR = 'V', A contains the real Schur form of the balanced */
  160. /* version of the input matrix A. */
  161. /* LDA (input) INTEGER */
  162. /* The leading dimension of the array A. LDA >= max(1,N). */
  163. /* WR (output) DOUBLE PRECISION array, dimension (N) */
  164. /* WI (output) DOUBLE PRECISION array, dimension (N) */
  165. /* WR and WI contain the real and imaginary parts, */
  166. /* respectively, of the computed eigenvalues. Complex */
  167. /* conjugate pairs of eigenvalues will appear consecutively */
  168. /* with the eigenvalue having the positive imaginary part */
  169. /* first. */
  170. /* VL (output) DOUBLE PRECISION array, dimension (LDVL,N) */
  171. /* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
  172. /* after another in the columns of VL, in the same order */
  173. /* as their eigenvalues. */
  174. /* If JOBVL = 'N', VL is not referenced. */
  175. /* If the j-th eigenvalue is real, then u(j) = VL(:,j), */
  176. /* the j-th column of VL. */
  177. /* If the j-th and (j+1)-st eigenvalues form a complex */
  178. /* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and */
  179. /* u(j+1) = VL(:,j) - i*VL(:,j+1). */
  180. /* LDVL (input) INTEGER */
  181. /* The leading dimension of the array VL. LDVL >= 1; if */
  182. /* JOBVL = 'V', LDVL >= N. */
  183. /* VR (output) DOUBLE PRECISION array, dimension (LDVR,N) */
  184. /* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
  185. /* after another in the columns of VR, in the same order */
  186. /* as their eigenvalues. */
  187. /* If JOBVR = 'N', VR is not referenced. */
  188. /* If the j-th eigenvalue is real, then v(j) = VR(:,j), */
  189. /* the j-th column of VR. */
  190. /* If the j-th and (j+1)-st eigenvalues form a complex */
  191. /* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and */
  192. /* v(j+1) = VR(:,j) - i*VR(:,j+1). */
  193. /* LDVR (input) INTEGER */
  194. /* The leading dimension of the array VR. LDVR >= 1, and if */
  195. /* JOBVR = 'V', LDVR >= N. */
  196. /* ILO (output) INTEGER */
  197. /* IHI (output) INTEGER */
  198. /* ILO and IHI are integer values determined when A was */
  199. /* balanced. The balanced A(i,j) = 0 if I > J and */
  200. /* J = 1,...,ILO-1 or I = IHI+1,...,N. */
  201. /* SCALE (output) DOUBLE PRECISION array, dimension (N) */
  202. /* Details of the permutations and scaling factors applied */
  203. /* when balancing A. If P(j) is the index of the row and column */
  204. /* interchanged with row and column j, and D(j) is the scaling */
  205. /* factor applied to row and column j, then */
  206. /* SCALE(J) = P(J), for J = 1,...,ILO-1 */
  207. /* = D(J), for J = ILO,...,IHI */
  208. /* = P(J) for J = IHI+1,...,N. */
  209. /* The order in which the interchanges are made is N to IHI+1, */
  210. /* then 1 to ILO-1. */
  211. /* ABNRM (output) DOUBLE PRECISION */
  212. /* The one-norm of the balanced matrix (the maximum */
  213. /* of the sum of absolute values of elements of any column). */
  214. /* RCONDE (output) DOUBLE PRECISION array, dimension (N) */
  215. /* RCONDE(j) is the reciprocal condition number of the j-th */
  216. /* eigenvalue. */
  217. /* RCONDV (output) DOUBLE PRECISION array, dimension (N) */
  218. /* RCONDV(j) is the reciprocal condition number of the j-th */
  219. /* right eigenvector. */
  220. /* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
  221. /* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
  222. /* LWORK (input) INTEGER */
  223. /* The dimension of the array WORK. If SENSE = 'N' or 'E', */
  224. /* LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V', */
  225. /* LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6). */
  226. /* For good performance, LWORK must generally be larger. */
  227. /* If LWORK = -1, then a workspace query is assumed; the routine */
  228. /* only calculates the optimal size of the WORK array, returns */
  229. /* this value as the first entry of the WORK array, and no error */
  230. /* message related to LWORK is issued by XERBLA. */
  231. /* IWORK (workspace) INTEGER array, dimension (2*N-2) */
  232. /* If SENSE = 'N' or 'E', not referenced. */
  233. /* INFO (output) INTEGER */
  234. /* = 0: successful exit */
  235. /* < 0: if INFO = -i, the i-th argument had an illegal value. */
  236. /* > 0: if INFO = i, the QR algorithm failed to compute all the */
  237. /* eigenvalues, and no eigenvectors or condition numbers */
  238. /* have been computed; elements 1:ILO-1 and i+1:N of WR */
  239. /* and WI contain eigenvalues which have converged. */
  240. /* ===================================================================== */
  241. /* .. Parameters .. */
  242. /* .. */
  243. /* .. Local Scalars .. */
  244. /* .. */
  245. /* .. Local Arrays .. */
  246. /* .. */
  247. /* .. External Subroutines .. */
  248. /* .. */
  249. /* .. External Functions .. */
  250. /* .. */
  251. /* .. Intrinsic Functions .. */
  252. /* .. */
  253. /* .. Executable Statements .. */
  254. /* Test the input arguments */
  255. /* Parameter adjustments */
  256. a_dim1 = *lda;
  257. a_offset = 1 + a_dim1;
  258. a -= a_offset;
  259. --wr;
  260. --wi;
  261. vl_dim1 = *ldvl;
  262. vl_offset = 1 + vl_dim1;
  263. vl -= vl_offset;
  264. vr_dim1 = *ldvr;
  265. vr_offset = 1 + vr_dim1;
  266. vr -= vr_offset;
  267. --scale;
  268. --rconde;
  269. --rcondv;
  270. --work;
  271. --iwork;
  272. /* Function Body */
  273. *info = 0;
  274. lquery = *lwork == -1;
  275. wantvl = _starpu_lsame_(jobvl, "V");
  276. wantvr = _starpu_lsame_(jobvr, "V");
  277. wntsnn = _starpu_lsame_(sense, "N");
  278. wntsne = _starpu_lsame_(sense, "E");
  279. wntsnv = _starpu_lsame_(sense, "V");
  280. wntsnb = _starpu_lsame_(sense, "B");
  281. if (! (_starpu_lsame_(balanc, "N") || _starpu_lsame_(balanc, "S") || _starpu_lsame_(balanc, "P")
  282. || _starpu_lsame_(balanc, "B"))) {
  283. *info = -1;
  284. } else if (! wantvl && ! _starpu_lsame_(jobvl, "N")) {
  285. *info = -2;
  286. } else if (! wantvr && ! _starpu_lsame_(jobvr, "N")) {
  287. *info = -3;
  288. } else if (! (wntsnn || wntsne || wntsnb || wntsnv) || (wntsne || wntsnb)
  289. && ! (wantvl && wantvr)) {
  290. *info = -4;
  291. } else if (*n < 0) {
  292. *info = -5;
  293. } else if (*lda < max(1,*n)) {
  294. *info = -7;
  295. } else if (*ldvl < 1 || wantvl && *ldvl < *n) {
  296. *info = -11;
  297. } else if (*ldvr < 1 || wantvr && *ldvr < *n) {
  298. *info = -13;
  299. }
  300. /* Compute workspace */
  301. /* (Note: Comments in the code beginning "Workspace:" describe the */
  302. /* minimal amount of workspace needed at that point in the code, */
  303. /* as well as the preferred amount for good performance. */
  304. /* NB refers to the optimal block size for the immediately */
  305. /* following subroutine, as returned by ILAENV. */
  306. /* HSWORK refers to the workspace preferred by DHSEQR, as */
  307. /* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
  308. /* the worst case.) */
  309. if (*info == 0) {
  310. if (*n == 0) {
  311. minwrk = 1;
  312. maxwrk = 1;
  313. } else {
  314. maxwrk = *n + *n * _starpu_ilaenv_(&c__1, "DGEHRD", " ", n, &c__1, n, &
  315. c__0);
  316. if (wantvl) {
  317. _starpu_dhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
  318. 1], &vl[vl_offset], ldvl, &work[1], &c_n1, info);
  319. } else if (wantvr) {
  320. _starpu_dhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
  321. 1], &vr[vr_offset], ldvr, &work[1], &c_n1, info);
  322. } else {
  323. if (wntsnn) {
  324. _starpu_dhseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &wr[1],
  325. &wi[1], &vr[vr_offset], ldvr, &work[1], &c_n1,
  326. info);
  327. } else {
  328. _starpu_dhseqr_("S", "N", n, &c__1, n, &a[a_offset], lda, &wr[1],
  329. &wi[1], &vr[vr_offset], ldvr, &work[1], &c_n1,
  330. info);
  331. }
  332. }
  333. hswork = (integer) work[1];
  334. if (! wantvl && ! wantvr) {
  335. minwrk = *n << 1;
  336. if (! wntsnn) {
  337. /* Computing MAX */
  338. i__1 = minwrk, i__2 = *n * *n + *n * 6;
  339. minwrk = max(i__1,i__2);
  340. }
  341. maxwrk = max(maxwrk,hswork);
  342. if (! wntsnn) {
  343. /* Computing MAX */
  344. i__1 = maxwrk, i__2 = *n * *n + *n * 6;
  345. maxwrk = max(i__1,i__2);
  346. }
  347. } else {
  348. minwrk = *n * 3;
  349. if (! wntsnn && ! wntsne) {
  350. /* Computing MAX */
  351. i__1 = minwrk, i__2 = *n * *n + *n * 6;
  352. minwrk = max(i__1,i__2);
  353. }
  354. maxwrk = max(maxwrk,hswork);
  355. /* Computing MAX */
  356. i__1 = maxwrk, i__2 = *n + (*n - 1) * _starpu_ilaenv_(&c__1, "DORGHR",
  357. " ", n, &c__1, n, &c_n1);
  358. maxwrk = max(i__1,i__2);
  359. if (! wntsnn && ! wntsne) {
  360. /* Computing MAX */
  361. i__1 = maxwrk, i__2 = *n * *n + *n * 6;
  362. maxwrk = max(i__1,i__2);
  363. }
  364. /* Computing MAX */
  365. i__1 = maxwrk, i__2 = *n * 3;
  366. maxwrk = max(i__1,i__2);
  367. }
  368. maxwrk = max(maxwrk,minwrk);
  369. }
  370. work[1] = (doublereal) maxwrk;
  371. if (*lwork < minwrk && ! lquery) {
  372. *info = -21;
  373. }
  374. }
  375. if (*info != 0) {
  376. i__1 = -(*info);
  377. _starpu_xerbla_("DGEEVX", &i__1);
  378. return 0;
  379. } else if (lquery) {
  380. return 0;
  381. }
  382. /* Quick return if possible */
  383. if (*n == 0) {
  384. return 0;
  385. }
  386. /* Get machine constants */
  387. eps = _starpu_dlamch_("P");
  388. smlnum = _starpu_dlamch_("S");
  389. bignum = 1. / smlnum;
  390. _starpu_dlabad_(&smlnum, &bignum);
  391. smlnum = sqrt(smlnum) / eps;
  392. bignum = 1. / smlnum;
  393. /* Scale A if max element outside range [SMLNUM,BIGNUM] */
  394. icond = 0;
  395. anrm = _starpu_dlange_("M", n, n, &a[a_offset], lda, dum);
  396. scalea = FALSE_;
  397. if (anrm > 0. && anrm < smlnum) {
  398. scalea = TRUE_;
  399. cscale = smlnum;
  400. } else if (anrm > bignum) {
  401. scalea = TRUE_;
  402. cscale = bignum;
  403. }
  404. if (scalea) {
  405. _starpu_dlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
  406. ierr);
  407. }
  408. /* Balance the matrix and compute ABNRM */
  409. _starpu_dgebal_(balanc, n, &a[a_offset], lda, ilo, ihi, &scale[1], &ierr);
  410. *abnrm = _starpu_dlange_("1", n, n, &a[a_offset], lda, dum);
  411. if (scalea) {
  412. dum[0] = *abnrm;
  413. _starpu_dlascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &c__1, &
  414. ierr);
  415. *abnrm = dum[0];
  416. }
  417. /* Reduce to upper Hessenberg form */
  418. /* (Workspace: need 2*N, prefer N+N*NB) */
  419. itau = 1;
  420. iwrk = itau + *n;
  421. i__1 = *lwork - iwrk + 1;
  422. _starpu_dgehrd_(n, ilo, ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, &
  423. ierr);
  424. if (wantvl) {
  425. /* Want left eigenvectors */
  426. /* Copy Householder vectors to VL */
  427. *(unsigned char *)side = 'L';
  428. _starpu_dlacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl)
  429. ;
  430. /* Generate orthogonal matrix in VL */
  431. /* (Workspace: need 2*N-1, prefer N+(N-1)*NB) */
  432. i__1 = *lwork - iwrk + 1;
  433. _starpu_dorghr_(n, ilo, ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], &
  434. i__1, &ierr);
  435. /* Perform QR iteration, accumulating Schur vectors in VL */
  436. /* (Workspace: need 1, prefer HSWORK (see comments) ) */
  437. iwrk = itau;
  438. i__1 = *lwork - iwrk + 1;
  439. _starpu_dhseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vl[
  440. vl_offset], ldvl, &work[iwrk], &i__1, info);
  441. if (wantvr) {
  442. /* Want left and right eigenvectors */
  443. /* Copy Schur vectors to VR */
  444. *(unsigned char *)side = 'B';
  445. _starpu_dlacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr);
  446. }
  447. } else if (wantvr) {
  448. /* Want right eigenvectors */
  449. /* Copy Householder vectors to VR */
  450. *(unsigned char *)side = 'R';
  451. _starpu_dlacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr)
  452. ;
  453. /* Generate orthogonal matrix in VR */
  454. /* (Workspace: need 2*N-1, prefer N+(N-1)*NB) */
  455. i__1 = *lwork - iwrk + 1;
  456. _starpu_dorghr_(n, ilo, ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], &
  457. i__1, &ierr);
  458. /* Perform QR iteration, accumulating Schur vectors in VR */
  459. /* (Workspace: need 1, prefer HSWORK (see comments) ) */
  460. iwrk = itau;
  461. i__1 = *lwork - iwrk + 1;
  462. _starpu_dhseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vr[
  463. vr_offset], ldvr, &work[iwrk], &i__1, info);
  464. } else {
  465. /* Compute eigenvalues only */
  466. /* If condition numbers desired, compute Schur form */
  467. if (wntsnn) {
  468. *(unsigned char *)job = 'E';
  469. } else {
  470. *(unsigned char *)job = 'S';
  471. }
  472. /* (Workspace: need 1, prefer HSWORK (see comments) ) */
  473. iwrk = itau;
  474. i__1 = *lwork - iwrk + 1;
  475. _starpu_dhseqr_(job, "N", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vr[
  476. vr_offset], ldvr, &work[iwrk], &i__1, info);
  477. }
  478. /* If INFO > 0 from DHSEQR, then quit */
  479. if (*info > 0) {
  480. goto L50;
  481. }
  482. if (wantvl || wantvr) {
  483. /* Compute left and/or right eigenvectors */
  484. /* (Workspace: need 3*N) */
  485. _starpu_dtrevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
  486. &vr[vr_offset], ldvr, n, &nout, &work[iwrk], &ierr);
  487. }
  488. /* Compute condition numbers if desired */
  489. /* (Workspace: need N*N+6*N unless SENSE = 'E') */
  490. if (! wntsnn) {
  491. _starpu_dtrsna_(sense, "A", select, n, &a[a_offset], lda, &vl[vl_offset],
  492. ldvl, &vr[vr_offset], ldvr, &rconde[1], &rcondv[1], n, &nout,
  493. &work[iwrk], n, &iwork[1], &icond);
  494. }
  495. if (wantvl) {
  496. /* Undo balancing of left eigenvectors */
  497. _starpu_dgebak_(balanc, "L", n, ilo, ihi, &scale[1], n, &vl[vl_offset], ldvl,
  498. &ierr);
  499. /* Normalize left eigenvectors and make largest component real */
  500. i__1 = *n;
  501. for (i__ = 1; i__ <= i__1; ++i__) {
  502. if (wi[i__] == 0.) {
  503. scl = 1. / _starpu_dnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
  504. _starpu_dscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
  505. } else if (wi[i__] > 0.) {
  506. d__1 = _starpu_dnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
  507. d__2 = _starpu_dnrm2_(n, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
  508. scl = 1. / _starpu_dlapy2_(&d__1, &d__2);
  509. _starpu_dscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
  510. _starpu_dscal_(n, &scl, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
  511. i__2 = *n;
  512. for (k = 1; k <= i__2; ++k) {
  513. /* Computing 2nd power */
  514. d__1 = vl[k + i__ * vl_dim1];
  515. /* Computing 2nd power */
  516. d__2 = vl[k + (i__ + 1) * vl_dim1];
  517. work[k] = d__1 * d__1 + d__2 * d__2;
  518. /* L10: */
  519. }
  520. k = _starpu_idamax_(n, &work[1], &c__1);
  521. _starpu_dlartg_(&vl[k + i__ * vl_dim1], &vl[k + (i__ + 1) * vl_dim1],
  522. &cs, &sn, &r__);
  523. _starpu_drot_(n, &vl[i__ * vl_dim1 + 1], &c__1, &vl[(i__ + 1) *
  524. vl_dim1 + 1], &c__1, &cs, &sn);
  525. vl[k + (i__ + 1) * vl_dim1] = 0.;
  526. }
  527. /* L20: */
  528. }
  529. }
  530. if (wantvr) {
  531. /* Undo balancing of right eigenvectors */
  532. _starpu_dgebak_(balanc, "R", n, ilo, ihi, &scale[1], n, &vr[vr_offset], ldvr,
  533. &ierr);
  534. /* Normalize right eigenvectors and make largest component real */
  535. i__1 = *n;
  536. for (i__ = 1; i__ <= i__1; ++i__) {
  537. if (wi[i__] == 0.) {
  538. scl = 1. / _starpu_dnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
  539. _starpu_dscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
  540. } else if (wi[i__] > 0.) {
  541. d__1 = _starpu_dnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
  542. d__2 = _starpu_dnrm2_(n, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
  543. scl = 1. / _starpu_dlapy2_(&d__1, &d__2);
  544. _starpu_dscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
  545. _starpu_dscal_(n, &scl, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
  546. i__2 = *n;
  547. for (k = 1; k <= i__2; ++k) {
  548. /* Computing 2nd power */
  549. d__1 = vr[k + i__ * vr_dim1];
  550. /* Computing 2nd power */
  551. d__2 = vr[k + (i__ + 1) * vr_dim1];
  552. work[k] = d__1 * d__1 + d__2 * d__2;
  553. /* L30: */
  554. }
  555. k = _starpu_idamax_(n, &work[1], &c__1);
  556. _starpu_dlartg_(&vr[k + i__ * vr_dim1], &vr[k + (i__ + 1) * vr_dim1],
  557. &cs, &sn, &r__);
  558. _starpu_drot_(n, &vr[i__ * vr_dim1 + 1], &c__1, &vr[(i__ + 1) *
  559. vr_dim1 + 1], &c__1, &cs, &sn);
  560. vr[k + (i__ + 1) * vr_dim1] = 0.;
  561. }
  562. /* L40: */
  563. }
  564. }
  565. /* Undo scaling if necessary */
  566. L50:
  567. if (scalea) {
  568. i__1 = *n - *info;
  569. /* Computing MAX */
  570. i__3 = *n - *info;
  571. i__2 = max(i__3,1);
  572. _starpu_dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[*info +
  573. 1], &i__2, &ierr);
  574. i__1 = *n - *info;
  575. /* Computing MAX */
  576. i__3 = *n - *info;
  577. i__2 = max(i__3,1);
  578. _starpu_dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[*info +
  579. 1], &i__2, &ierr);
  580. if (*info == 0) {
  581. if ((wntsnv || wntsnb) && icond == 0) {
  582. _starpu_dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &rcondv[
  583. 1], n, &ierr);
  584. }
  585. } else {
  586. i__1 = *ilo - 1;
  587. _starpu_dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[1],
  588. n, &ierr);
  589. i__1 = *ilo - 1;
  590. _starpu_dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[1],
  591. n, &ierr);
  592. }
  593. }
  594. work[1] = (doublereal) maxwrk;
  595. return 0;
  596. /* End of DGEEVX */
  597. } /* _starpu_dgeevx_ */