1 #include "clapack.h"
2 #include "f2cP.h"
3
dtbcon_(const char * norm,const char * uplo,const char * diag,integer * n,integer * kd,double * ab,integer * ldab,double * rcond,double * work,integer * iwork,integer * info)4 /* Subroutine */ int dtbcon_(const char *norm, const char *uplo, const char *diag, integer *n,
5 integer *kd, double *ab, integer *ldab, double *rcond,
6 double *work, integer *iwork, integer *info)
7 {
8 /* Table of constant values */
9 static integer c__1 = 1;
10
11 /* System generated locals */
12 integer ab_dim1, ab_offset, i__1;
13 double d__1;
14
15 /* Local variables */
16 integer ix, kase, kase1;
17 double scale;
18 integer isave[3];
19 double anorm;
20 bool upper;
21 double xnorm;
22 double ainvnm;
23 bool onenrm;
24 char normin[1];
25 double smlnum;
26 bool nounit;
27
28
29 /* -- LAPACK routine (version 3.1) -- */
30 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
31 /* November 2006 */
32
33 /* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
34
35 /* .. Scalar Arguments .. */
36 /* .. */
37 /* .. Array Arguments .. */
38 /* .. */
39
40 /* Purpose */
41 /* ======= */
42
43 /* DTBCON estimates the reciprocal of the condition number of a */
44 /* triangular band matrix A, in either the 1-norm or the infinity-norm. */
45
46 /* The norm of A is computed and an estimate is obtained for */
47 /* norm(inv(A)), then the reciprocal of the condition number is */
48 /* computed as */
49 /* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
50
51 /* Arguments */
52 /* ========= */
53
54 /* NORM (input) CHARACTER*1 */
55 /* Specifies whether the 1-norm condition number or the */
56 /* infinity-norm condition number is required: */
57 /* = '1' or 'O': 1-norm; */
58 /* = 'I': Infinity-norm. */
59
60 /* UPLO (input) CHARACTER*1 */
61 /* = 'U': A is upper triangular; */
62 /* = 'L': A is lower triangular. */
63
64 /* DIAG (input) CHARACTER*1 */
65 /* = 'N': A is non-unit triangular; */
66 /* = 'U': A is unit triangular. */
67
68 /* N (input) INTEGER */
69 /* The order of the matrix A. N >= 0. */
70
71 /* KD (input) INTEGER */
72 /* The number of superdiagonals or subdiagonals of the */
73 /* triangular band matrix A. KD >= 0. */
74
75 /* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
76 /* The upper or lower triangular band matrix A, stored in the */
77 /* first kd+1 rows of the array. The j-th column of A is stored */
78 /* in the j-th column of the array AB as follows: */
79 /* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
80 /* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
81 /* If DIAG = 'U', the diagonal elements of A are not referenced */
82 /* and are assumed to be 1. */
83
84 /* LDAB (input) INTEGER */
85 /* The leading dimension of the array AB. LDAB >= KD+1. */
86
87 /* RCOND (output) DOUBLE PRECISION */
88 /* The reciprocal of the condition number of the matrix A, */
89 /* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
90
91 /* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
92
93 /* IWORK (workspace) INTEGER array, dimension (N) */
94
95 /* INFO (output) INTEGER */
96 /* = 0: successful exit */
97 /* < 0: if INFO = -i, the i-th argument had an illegal value */
98
99 /* ===================================================================== */
100
101 /* .. Parameters .. */
102 /* .. */
103 /* .. Local Scalars .. */
104 /* .. */
105 /* .. Local Arrays .. */
106 /* .. */
107 /* .. External Functions .. */
108 /* .. */
109 /* .. External Subroutines .. */
110 /* .. */
111 /* .. Intrinsic Functions .. */
112 /* .. */
113 /* .. Executable Statements .. */
114
115 /* Test the input parameters. */
116
117 /* Parameter adjustments */
118 ab_dim1 = *ldab;
119 ab_offset = 1 + ab_dim1;
120 ab -= ab_offset;
121 --work;
122 --iwork;
123
124 /* Function Body */
125 *info = 0;
126 upper = lsame_(uplo, "U");
127 onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
128 nounit = lsame_(diag, "N");
129
130 if (! onenrm && ! lsame_(norm, "I")) {
131 *info = -1;
132 } else if (! upper && ! lsame_(uplo, "L")) {
133 *info = -2;
134 } else if (! nounit && ! lsame_(diag, "U")) {
135 *info = -3;
136 } else if (*n < 0) {
137 *info = -4;
138 } else if (*kd < 0) {
139 *info = -5;
140 } else if (*ldab < *kd + 1) {
141 *info = -7;
142 }
143 if (*info != 0) {
144 i__1 = -(*info);
145 xerbla_("DTBCON", &i__1);
146 return 0;
147 }
148
149 /* Quick return if possible */
150
151 if (*n == 0) {
152 *rcond = 1.;
153 return 0;
154 }
155
156 *rcond = 0.;
157 smlnum = dlamch_("Safe minimum") * (double) std::max(1_integer,*n);
158
159 /* Compute the norm of the triangular matrix A. */
160
161 anorm = dlantb_(norm, uplo, diag, n, kd, &ab[ab_offset], ldab, &work[1]);
162
163 /* Continue only if ANORM > 0. */
164
165 if (anorm > 0.) {
166
167 /* Estimate the norm of the inverse of A. */
168
169 ainvnm = 0.;
170 *(unsigned char *)normin = 'N';
171 if (onenrm) {
172 kase1 = 1;
173 } else {
174 kase1 = 2;
175 }
176 kase = 0;
177 L10:
178 dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
179 if (kase != 0) {
180 if (kase == kase1) {
181
182 /* Multiply by inv(A). */
183
184 dlatbs_(uplo, "No transpose", diag, normin, n, kd, &ab[
185 ab_offset], ldab, &work[1], &scale, &work[(*n << 1) +
186 1], info)
187 ;
188 } else {
189
190 /* Multiply by inv(A'). */
191
192 dlatbs_(uplo, "Transpose", diag, normin, n, kd, &ab[ab_offset]
193 , ldab, &work[1], &scale, &work[(*n << 1) + 1], info);
194 }
195 *(unsigned char *)normin = 'Y';
196
197 /* Multiply by 1/SCALE if doing so will not cause overflow. */
198
199 if (scale != 1.) {
200 ix = idamax_(n, &work[1], &c__1);
201 xnorm = (d__1 = work[ix], abs(d__1));
202 if (scale < xnorm * smlnum || scale == 0.) {
203 goto L20;
204 }
205 drscl_(n, &scale, &work[1], &c__1);
206 }
207 goto L10;
208 }
209
210 /* Compute the estimate of the reciprocal condition number. */
211
212 if (ainvnm != 0.) {
213 *rcond = 1. / anorm / ainvnm;
214 }
215 }
216
217 L20:
218 return 0;
219
220 /* End of DTBCON */
221
222 } /* dtbcon_ */
223
dtbrfs_(const char * uplo,const char * trans,const char * diag,integer * n,integer * kd,integer * nrhs,double * ab,integer * ldab,double * b,integer * ldb,double * x,integer * ldx,double * ferr,double * berr,double * work,integer * iwork,integer * info)224 /* Subroutine */ int dtbrfs_(const char *uplo, const char *trans, const char *diag, integer *n,
225 integer *kd, integer *nrhs, double *ab, integer *ldab, double
226 *b, integer *ldb, double *x, integer *ldx, double *ferr,
227 double *berr, double *work, integer *iwork, integer *info)
228 {
229 /* Table of constant values */
230 static integer c__1 = 1;
231 static double c_b19 = -1.;
232
233 /* System generated locals */
234 integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1,
235 i__2, i__3, i__4, i__5;
236 double d__1, d__2, d__3;
237
238 /* Local variables */
239 integer i__, j, k;
240 double s, xk;
241 integer nz;
242 double eps;
243 integer kase;
244 double safe1, safe2;
245 integer isave[3];
246 bool upper;
247 double safmin;
248 bool notran;
249 char transt[1];
250 bool nounit;
251 double lstres;
252
253
254 /* -- LAPACK routine (version 3.1) -- */
255 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
256 /* November 2006 */
257
258 /* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
259
260 /* .. Scalar Arguments .. */
261 /* .. */
262 /* .. Array Arguments .. */
263 /* .. */
264
265 /* Purpose */
266 /* ======= */
267
268 /* DTBRFS provides error bounds and backward error estimates for the */
269 /* solution to a system of linear equations with a triangular band */
270 /* coefficient matrix. */
271
272 /* The solution matrix X must be computed by DTBTRS or some other */
273 /* means before entering this routine. DTBRFS does not do iterative */
274 /* refinement because doing so cannot improve the backward error. */
275
276 /* Arguments */
277 /* ========= */
278
279 /* UPLO (input) CHARACTER*1 */
280 /* = 'U': A is upper triangular; */
281 /* = 'L': A is lower triangular. */
282
283 /* TRANS (input) CHARACTER*1 */
284 /* Specifies the form of the system of equations: */
285 /* = 'N': A * X = B (No transpose) */
286 /* = 'T': A**T * X = B (Transpose) */
287 /* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
288
289 /* DIAG (input) CHARACTER*1 */
290 /* = 'N': A is non-unit triangular; */
291 /* = 'U': A is unit triangular. */
292
293 /* N (input) INTEGER */
294 /* The order of the matrix A. N >= 0. */
295
296 /* KD (input) INTEGER */
297 /* The number of superdiagonals or subdiagonals of the */
298 /* triangular band matrix A. KD >= 0. */
299
300 /* NRHS (input) INTEGER */
301 /* The number of right hand sides, i.e., the number of columns */
302 /* of the matrices B and X. NRHS >= 0. */
303
304 /* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
305 /* The upper or lower triangular band matrix A, stored in the */
306 /* first kd+1 rows of the array. The j-th column of A is stored */
307 /* in the j-th column of the array AB as follows: */
308 /* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
309 /* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
310 /* If DIAG = 'U', the diagonal elements of A are not referenced */
311 /* and are assumed to be 1. */
312
313 /* LDAB (input) INTEGER */
314 /* The leading dimension of the array AB. LDAB >= KD+1. */
315
316 /* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
317 /* The right hand side matrix B. */
318
319 /* LDB (input) INTEGER */
320 /* The leading dimension of the array B. LDB >= max(1,N). */
321
322 /* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
323 /* The solution matrix X. */
324
325 /* LDX (input) INTEGER */
326 /* The leading dimension of the array X. LDX >= max(1,N). */
327
328 /* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
329 /* The estimated forward error bound for each solution vector */
330 /* X(j) (the j-th column of the solution matrix X). */
331 /* If XTRUE is the true solution corresponding to X(j), FERR(j) */
332 /* is an estimated upper bound for the magnitude of the largest */
333 /* element in (X(j) - XTRUE) divided by the magnitude of the */
334 /* largest element in X(j). The estimate is as reliable as */
335 /* the estimate for RCOND, and is almost always a slight */
336 /* overestimate of the true error. */
337
338 /* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
339 /* The componentwise relative backward error of each solution */
340 /* vector X(j) (i.e., the smallest relative change in */
341 /* any element of A or B that makes X(j) an exact solution). */
342
343 /* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
344
345 /* IWORK (workspace) INTEGER array, dimension (N) */
346
347 /* INFO (output) INTEGER */
348 /* = 0: successful exit */
349 /* < 0: if INFO = -i, the i-th argument had an illegal value */
350
351 /* ===================================================================== */
352
353 /* .. Parameters .. */
354 /* .. */
355 /* .. Local Scalars .. */
356 /* .. */
357 /* .. Local Arrays .. */
358 /* .. */
359 /* .. External Subroutines .. */
360 /* .. */
361 /* .. Intrinsic Functions .. */
362 /* .. */
363 /* .. External Functions .. */
364 /* .. */
365 /* .. Executable Statements .. */
366
367 /* Test the input parameters. */
368
369 /* Parameter adjustments */
370 ab_dim1 = *ldab;
371 ab_offset = 1 + ab_dim1;
372 ab -= ab_offset;
373 b_dim1 = *ldb;
374 b_offset = 1 + b_dim1;
375 b -= b_offset;
376 x_dim1 = *ldx;
377 x_offset = 1 + x_dim1;
378 x -= x_offset;
379 --ferr;
380 --berr;
381 --work;
382 --iwork;
383
384 /* Function Body */
385 *info = 0;
386 upper = lsame_(uplo, "U");
387 notran = lsame_(trans, "N");
388 nounit = lsame_(diag, "N");
389
390 if (! upper && ! lsame_(uplo, "L")) {
391 *info = -1;
392 } else if (! notran && ! lsame_(trans, "T") && !
393 lsame_(trans, "C")) {
394 *info = -2;
395 } else if (! nounit && ! lsame_(diag, "U")) {
396 *info = -3;
397 } else if (*n < 0) {
398 *info = -4;
399 } else if (*kd < 0) {
400 *info = -5;
401 } else if (*nrhs < 0) {
402 *info = -6;
403 } else if (*ldab < *kd + 1) {
404 *info = -8;
405 } else if (*ldb < std::max(1_integer,*n)) {
406 *info = -10;
407 } else if (*ldx < std::max(1_integer,*n)) {
408 *info = -12;
409 }
410 if (*info != 0) {
411 i__1 = -(*info);
412 xerbla_("DTBRFS", &i__1);
413 return 0;
414 }
415
416 /* Quick return if possible */
417
418 if (*n == 0 || *nrhs == 0) {
419 i__1 = *nrhs;
420 for (j = 1; j <= i__1; ++j) {
421 ferr[j] = 0.;
422 berr[j] = 0.;
423 /* L10: */
424 }
425 return 0;
426 }
427
428 if (notran) {
429 *(unsigned char *)transt = 'T';
430 } else {
431 *(unsigned char *)transt = 'N';
432 }
433
434 /* NZ = maximum number of nonzero elements in each row of A, plus 1 */
435
436 nz = *kd + 2;
437 eps = dlamch_("Epsilon");
438 safmin = dlamch_("Safe minimum");
439 safe1 = nz * safmin;
440 safe2 = safe1 / eps;
441
442 /* Do for each right hand side */
443
444 i__1 = *nrhs;
445 for (j = 1; j <= i__1; ++j) {
446
447 /* Compute residual R = B - op(A) * X, */
448 /* where op(A) = A or A', depending on TRANS. */
449
450 dcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[*n + 1], &c__1);
451 dtbmv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[*n + 1],
452 &c__1);
453 daxpy_(n, &c_b19, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
454
455 /* Compute componentwise relative backward error from formula */
456
457 /* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
458
459 /* where abs(Z) is the componentwise absolute value of the matrix */
460 /* or vector Z. If the i-th component of the denominator is less */
461 /* than SAFE2, then SAFE1 is added to the i-th components of the */
462 /* numerator and denominator before dividing. */
463
464 i__2 = *n;
465 for (i__ = 1; i__ <= i__2; ++i__) {
466 work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1));
467 /* L20: */
468 }
469
470 if (notran) {
471
472 /* Compute abs(A)*abs(X) + abs(B). */
473
474 if (upper) {
475 if (nounit) {
476 i__2 = *n;
477 for (k = 1; k <= i__2; ++k) {
478 xk = (d__1 = x[k + j * x_dim1], abs(d__1));
479 /* Computing MAX */
480 i__3 = 1, i__4 = k - *kd;
481 i__5 = k;
482 for (i__ = std::max(i__3,i__4); i__ <= i__5; ++i__) {
483 work[i__] += (d__1 = ab[*kd + 1 + i__ - k + k *
484 ab_dim1], abs(d__1)) * xk;
485 /* L30: */
486 }
487 /* L40: */
488 }
489 } else {
490 i__2 = *n;
491 for (k = 1; k <= i__2; ++k) {
492 xk = (d__1 = x[k + j * x_dim1], abs(d__1));
493 /* Computing MAX */
494 i__5 = 1, i__3 = k - *kd;
495 i__4 = k - 1;
496 for (i__ = std::max(i__5,i__3); i__ <= i__4; ++i__) {
497 work[i__] += (d__1 = ab[*kd + 1 + i__ - k + k *
498 ab_dim1], abs(d__1)) * xk;
499 /* L50: */
500 }
501 work[k] += xk;
502 /* L60: */
503 }
504 }
505 } else {
506 if (nounit) {
507 i__2 = *n;
508 for (k = 1; k <= i__2; ++k) {
509 xk = (d__1 = x[k + j * x_dim1], abs(d__1));
510 /* Computing MIN */
511 i__5 = *n, i__3 = k + *kd;
512 i__4 = std::min(i__5,i__3);
513 for (i__ = k; i__ <= i__4; ++i__) {
514 work[i__] += (d__1 = ab[i__ + 1 - k + k * ab_dim1]
515 , abs(d__1)) * xk;
516 /* L70: */
517 }
518 /* L80: */
519 }
520 } else {
521 i__2 = *n;
522 for (k = 1; k <= i__2; ++k) {
523 xk = (d__1 = x[k + j * x_dim1], abs(d__1));
524 /* Computing MIN */
525 i__5 = *n, i__3 = k + *kd;
526 i__4 = std::min(i__5,i__3);
527 for (i__ = k + 1; i__ <= i__4; ++i__) {
528 work[i__] += (d__1 = ab[i__ + 1 - k + k * ab_dim1]
529 , abs(d__1)) * xk;
530 /* L90: */
531 }
532 work[k] += xk;
533 /* L100: */
534 }
535 }
536 }
537 } else {
538
539 /* Compute abs(A')*abs(X) + abs(B). */
540
541 if (upper) {
542 if (nounit) {
543 i__2 = *n;
544 for (k = 1; k <= i__2; ++k) {
545 s = 0.;
546 /* Computing MAX */
547 i__4 = 1, i__5 = k - *kd;
548 i__3 = k;
549 for (i__ = std::max(i__4,i__5); i__ <= i__3; ++i__) {
550 s += (d__1 = ab[*kd + 1 + i__ - k + k * ab_dim1],
551 abs(d__1)) * (d__2 = x[i__ + j * x_dim1],
552 abs(d__2));
553 /* L110: */
554 }
555 work[k] += s;
556 /* L120: */
557 }
558 } else {
559 i__2 = *n;
560 for (k = 1; k <= i__2; ++k) {
561 s = (d__1 = x[k + j * x_dim1], abs(d__1));
562 /* Computing MAX */
563 i__3 = 1, i__4 = k - *kd;
564 i__5 = k - 1;
565 for (i__ = std::max(i__3,i__4); i__ <= i__5; ++i__) {
566 s += (d__1 = ab[*kd + 1 + i__ - k + k * ab_dim1],
567 abs(d__1)) * (d__2 = x[i__ + j * x_dim1],
568 abs(d__2));
569 /* L130: */
570 }
571 work[k] += s;
572 /* L140: */
573 }
574 }
575 } else {
576 if (nounit) {
577 i__2 = *n;
578 for (k = 1; k <= i__2; ++k) {
579 s = 0.;
580 /* Computing MIN */
581 i__3 = *n, i__4 = k + *kd;
582 i__5 = std::min(i__3,i__4);
583 for (i__ = k; i__ <= i__5; ++i__) {
584 s += (d__1 = ab[i__ + 1 - k + k * ab_dim1], abs(
585 d__1)) * (d__2 = x[i__ + j * x_dim1], abs(
586 d__2));
587 /* L150: */
588 }
589 work[k] += s;
590 /* L160: */
591 }
592 } else {
593 i__2 = *n;
594 for (k = 1; k <= i__2; ++k) {
595 s = (d__1 = x[k + j * x_dim1], abs(d__1));
596 /* Computing MIN */
597 i__3 = *n, i__4 = k + *kd;
598 i__5 = std::min(i__3,i__4);
599 for (i__ = k + 1; i__ <= i__5; ++i__) {
600 s += (d__1 = ab[i__ + 1 - k + k * ab_dim1], abs(
601 d__1)) * (d__2 = x[i__ + j * x_dim1], abs(
602 d__2));
603 /* L170: */
604 }
605 work[k] += s;
606 /* L180: */
607 }
608 }
609 }
610 }
611 s = 0.;
612 i__2 = *n;
613 for (i__ = 1; i__ <= i__2; ++i__) {
614 if (work[i__] > safe2) {
615 /* Computing MAX */
616 d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[
617 i__];
618 s = std::max(d__2,d__3);
619 } else {
620 /* Computing MAX */
621 d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1)
622 / (work[i__] + safe1);
623 s = std::max(d__2,d__3);
624 }
625 /* L190: */
626 }
627 berr[j] = s;
628
629 /* Bound error from formula */
630
631 /* norm(X - XTRUE) / norm(X) .le. FERR = */
632 /* norm( abs(inv(op(A)))* */
633 /* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
634
635 /* where */
636 /* norm(Z) is the magnitude of the largest component of Z */
637 /* inv(op(A)) is the inverse of op(A) */
638 /* abs(Z) is the componentwise absolute value of the matrix or */
639 /* vector Z */
640 /* NZ is the maximum number of nonzeros in any row of A, plus 1 */
641 /* EPS is machine epsilon */
642
643 /* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
644 /* is incremented by SAFE1 if the i-th component of */
645 /* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
646
647 /* Use DLACN2 to estimate the infinity-norm of the matrix */
648 /* inv(op(A)) * diag(W), */
649 /* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
650
651 i__2 = *n;
652 for (i__ = 1; i__ <= i__2; ++i__) {
653 if (work[i__] > safe2) {
654 work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
655 work[i__];
656 } else {
657 work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
658 work[i__] + safe1;
659 }
660 /* L200: */
661 }
662
663 kase = 0;
664 L210:
665 dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
666 kase, isave);
667 if (kase != 0) {
668 if (kase == 1) {
669
670 /* Multiply by diag(W)*inv(op(A)'). */
671
672 dtbsv_(uplo, transt, diag, n, kd, &ab[ab_offset], ldab, &work[
673 *n + 1], &c__1);
674 i__2 = *n;
675 for (i__ = 1; i__ <= i__2; ++i__) {
676 work[*n + i__] = work[i__] * work[*n + i__];
677 /* L220: */
678 }
679 } else {
680
681 /* Multiply by inv(op(A))*diag(W). */
682
683 i__2 = *n;
684 for (i__ = 1; i__ <= i__2; ++i__) {
685 work[*n + i__] = work[i__] * work[*n + i__];
686 /* L230: */
687 }
688 dtbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[*
689 n + 1], &c__1);
690 }
691 goto L210;
692 }
693
694 /* Normalize error. */
695
696 lstres = 0.;
697 i__2 = *n;
698 for (i__ = 1; i__ <= i__2; ++i__) {
699 /* Computing MAX */
700 d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1));
701 lstres = std::max(d__2,d__3);
702 /* L240: */
703 }
704 if (lstres != 0.) {
705 ferr[j] /= lstres;
706 }
707
708 /* L250: */
709 }
710
711 return 0;
712
713 /* End of DTBRFS */
714
715 } /* dtbrfs_ */
716
dtbtrs_(const char * uplo,const char * trans,const char * diag,integer * n,integer * kd,integer * nrhs,double * ab,integer * ldab,double * b,integer * ldb,integer * info)717 /* Subroutine */ int dtbtrs_(const char *uplo, const char *trans, const char *diag, integer *n,
718 integer *kd, integer *nrhs, double *ab, integer *ldab, double
719 *b, integer *ldb, integer *info)
720 {
721 /* Table of constant values */
722 static integer c__1 = 1;
723
724 /* System generated locals */
725 integer ab_dim1, ab_offset, b_dim1, b_offset, i__1;
726
727 /* Local variables */
728 integer j;
729 bool upper;
730 bool nounit;
731
732
733 /* -- LAPACK routine (version 3.1) -- */
734 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
735 /* November 2006 */
736
737 /* .. Scalar Arguments .. */
738 /* .. */
739 /* .. Array Arguments .. */
740 /* .. */
741
742 /* Purpose */
743 /* ======= */
744
745 /* DTBTRS solves a triangular system of the form */
746
747 /* A * X = B or A**T * X = B, */
748
749 /* where A is a triangular band matrix of order N, and B is an */
750 /* N-by NRHS matrix. A check is made to verify that A is nonsingular. */
751
752 /* Arguments */
753 /* ========= */
754
755 /* UPLO (input) CHARACTER*1 */
756 /* = 'U': A is upper triangular; */
757 /* = 'L': A is lower triangular. */
758
759 /* TRANS (input) CHARACTER*1 */
760 /* Specifies the form the system of equations: */
761 /* = 'N': A * X = B (No transpose) */
762 /* = 'T': A**T * X = B (Transpose) */
763 /* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
764
765 /* DIAG (input) CHARACTER*1 */
766 /* = 'N': A is non-unit triangular; */
767 /* = 'U': A is unit triangular. */
768
769 /* N (input) INTEGER */
770 /* The order of the matrix A. N >= 0. */
771
772 /* KD (input) INTEGER */
773 /* The number of superdiagonals or subdiagonals of the */
774 /* triangular band matrix A. KD >= 0. */
775
776 /* NRHS (input) INTEGER */
777 /* The number of right hand sides, i.e., the number of columns */
778 /* of the matrix B. NRHS >= 0. */
779
780 /* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
781 /* The upper or lower triangular band matrix A, stored in the */
782 /* first kd+1 rows of AB. The j-th column of A is stored */
783 /* in the j-th column of the array AB as follows: */
784 /* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
785 /* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
786 /* If DIAG = 'U', the diagonal elements of A are not referenced */
787 /* and are assumed to be 1. */
788
789 /* LDAB (input) INTEGER */
790 /* The leading dimension of the array AB. LDAB >= KD+1. */
791
792 /* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
793 /* On entry, the right hand side matrix B. */
794 /* On exit, if INFO = 0, the solution matrix X. */
795
796 /* LDB (input) INTEGER */
797 /* The leading dimension of the array B. LDB >= max(1,N). */
798
799 /* INFO (output) INTEGER */
800 /* = 0: successful exit */
801 /* < 0: if INFO = -i, the i-th argument had an illegal value */
802 /* > 0: if INFO = i, the i-th diagonal element of A is zero, */
803 /* indicating that the matrix is singular and the */
804 /* solutions X have not been computed. */
805
806 /* ===================================================================== */
807
808 /* .. Parameters .. */
809 /* .. */
810 /* .. Local Scalars .. */
811 /* .. */
812 /* .. External Functions .. */
813 /* .. */
814 /* .. External Subroutines .. */
815 /* .. */
816 /* .. Intrinsic Functions .. */
817 /* .. */
818 /* .. Executable Statements .. */
819
820 /* Test the input parameters. */
821
822 /* Parameter adjustments */
823 ab_dim1 = *ldab;
824 ab_offset = 1 + ab_dim1;
825 ab -= ab_offset;
826 b_dim1 = *ldb;
827 b_offset = 1 + b_dim1;
828 b -= b_offset;
829
830 /* Function Body */
831 *info = 0;
832 nounit = lsame_(diag, "N");
833 upper = lsame_(uplo, "U");
834 if (! upper && ! lsame_(uplo, "L")) {
835 *info = -1;
836 } else if (! lsame_(trans, "N") && ! lsame_(trans,
837 "T") && ! lsame_(trans, "C")) {
838 *info = -2;
839 } else if (! nounit && ! lsame_(diag, "U")) {
840 *info = -3;
841 } else if (*n < 0) {
842 *info = -4;
843 } else if (*kd < 0) {
844 *info = -5;
845 } else if (*nrhs < 0) {
846 *info = -6;
847 } else if (*ldab < *kd + 1) {
848 *info = -8;
849 } else if (*ldb < std::max(1_integer,*n)) {
850 *info = -10;
851 }
852 if (*info != 0) {
853 i__1 = -(*info);
854 xerbla_("DTBTRS", &i__1);
855 return 0;
856 }
857
858 /* Quick return if possible */
859
860 if (*n == 0) {
861 return 0;
862 }
863
864 /* Check for singularity. */
865
866 if (nounit) {
867 if (upper) {
868 i__1 = *n;
869 for (*info = 1; *info <= i__1; ++(*info)) {
870 if (ab[*kd + 1 + *info * ab_dim1] == 0.) {
871 return 0;
872 }
873 /* L10: */
874 }
875 } else {
876 i__1 = *n;
877 for (*info = 1; *info <= i__1; ++(*info)) {
878 if (ab[*info * ab_dim1 + 1] == 0.) {
879 return 0;
880 }
881 /* L20: */
882 }
883 }
884 }
885 *info = 0;
886
887 /* Solve A * X = B or A' * X = B. */
888
889 i__1 = *nrhs;
890 for (j = 1; j <= i__1; ++j) {
891 dtbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &b[j * b_dim1
892 + 1], &c__1);
893 /* L30: */
894 }
895
896 return 0;
897
898 /* End of DTBTRS */
899
900 } /* dtbtrs_ */
901
dtfsm_(const char * transr,const char * side,const char * uplo,const char * trans,const char * diag,integer * m,integer * n,double * alpha,double * a,double * b,integer * ldb)902 int dtfsm_(const char *transr, const char *side, const char *uplo, const char *trans,
903 const char *diag, integer *m, integer *n, double *alpha, double *a, double *b, integer *ldb)
904 {
905 /* Table of constant values */
906 static double c_b23 = -1.;
907 static double c_b27 = 1.;
908
909 /* System generated locals */
910 integer b_dim1, b_offset, i__1, i__2;
911
912 /* Local variables */
913 integer i__, j, k, m1, m2, n1, n2, info;
914 bool normaltransr, lside, lower, misodd, nisodd, notrans;
915
916
917 /* -- LAPACK routine (version 3.2.1) -- */
918
919 /* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
920 /* -- April 2009 -- */
921
922 /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
923 /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
924
925 /* .. */
926 /* .. Scalar Arguments .. */
927 /* .. */
928 /* .. Array Arguments .. */
929 /* .. */
930
931 /* Purpose */
932 /* ======= */
933
934 /* Level 3 BLAS like routine for A in RFP Format. */
935
936 /* DTFSM solves the matrix equation */
937
938 /* op( A )*X = alpha*B or X*op( A ) = alpha*B */
939
940 /* where alpha is a scalar, X and B are m by n matrices, A is a unit, or */
941 /* non-unit, upper or lower triangular matrix and op( A ) is one of */
942
943 /* op( A ) = A or op( A ) = A'. */
944
945 /* A is in Rectangular Full Packed (RFP) Format. */
946
947 /* The matrix X is overwritten on B. */
948
949 /* Arguments */
950 /* ========== */
951
952 /* TRANSR - (input) CHARACTER */
953 /* = 'N': The Normal Form of RFP A is stored; */
954 /* = 'T': The Transpose Form of RFP A is stored. */
955
956 /* SIDE - (input) CHARACTER */
957 /* On entry, SIDE specifies whether op( A ) appears on the left */
958 /* or right of X as follows: */
959
960 /* SIDE = 'L' or 'l' op( A )*X = alpha*B. */
961
962 /* SIDE = 'R' or 'r' X*op( A ) = alpha*B. */
963
964 /* Unchanged on exit. */
965
966 /* UPLO - (input) CHARACTER */
967 /* On entry, UPLO specifies whether the RFP matrix A came from */
968 /* an upper or lower triangular matrix as follows: */
969 /* UPLO = 'U' or 'u' RFP A came from an upper triangular matrix */
970 /* UPLO = 'L' or 'l' RFP A came from a lower triangular matrix */
971
972 /* Unchanged on exit. */
973
974 /* TRANS - (input) CHARACTER */
975 /* On entry, TRANS specifies the form of op( A ) to be used */
976 /* in the matrix multiplication as follows: */
977
978 /* TRANS = 'N' or 'n' op( A ) = A. */
979
980 /* TRANS = 'T' or 't' op( A ) = A'. */
981
982 /* Unchanged on exit. */
983
984 /* DIAG - (input) CHARACTER */
985 /* On entry, DIAG specifies whether or not RFP A is unit */
986 /* triangular as follows: */
987
988 /* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
989
990 /* DIAG = 'N' or 'n' A is not assumed to be unit */
991 /* triangular. */
992
993 /* Unchanged on exit. */
994
995 /* M - (input) INTEGER. */
996 /* On entry, M specifies the number of rows of B. M must be at */
997 /* least zero. */
998 /* Unchanged on exit. */
999
1000 /* N - (input) INTEGER. */
1001 /* On entry, N specifies the number of columns of B. N must be */
1002 /* at least zero. */
1003 /* Unchanged on exit. */
1004
1005 /* ALPHA - (input) DOUBLE PRECISION. */
1006 /* On entry, ALPHA specifies the scalar alpha. When alpha is */
1007 /* zero then A is not referenced and B need not be set before */
1008 /* entry. */
1009 /* Unchanged on exit. */
1010
1011 /* A - (input) DOUBLE PRECISION array, dimension (NT); */
1012 /* NT = N*(N+1)/2. On entry, the matrix A in RFP Format. */
1013 /* RFP Format is described by TRANSR, UPLO and N as follows: */
1014 /* If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even; */
1015 /* K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If */
1016 /* TRANSR = 'T' then RFP is the transpose of RFP A as */
1017 /* defined when TRANSR = 'N'. The contents of RFP A are defined */
1018 /* by UPLO as follows: If UPLO = 'U' the RFP A contains the NT */
1019 /* elements of upper packed A either in normal or */
1020 /* transpose Format. If UPLO = 'L' the RFP A contains */
1021 /* the NT elements of lower packed A either in normal or */
1022 /* transpose Format. The LDA of RFP A is (N+1)/2 when */
1023 /* TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is */
1024 /* even and is N when is odd. */
1025 /* See the Note below for more details. Unchanged on exit. */
1026
1027 /* B - (input/ouptut) DOUBLE PRECISION array, DIMENSION (LDB,N) */
1028 /* Before entry, the leading m by n part of the array B must */
1029 /* contain the right-hand side matrix B, and on exit is */
1030 /* overwritten by the solution matrix X. */
1031
1032 /* LDB - (input) INTEGER. */
1033 /* On entry, LDB specifies the first dimension of B as declared */
1034 /* in the calling (sub) program. LDB must be at least */
1035 /* max( 1, m ). */
1036 /* Unchanged on exit. */
1037
1038 /* Further Details */
1039 /* =============== */
1040
1041 /* We first consider Rectangular Full Packed (RFP) Format when N is */
1042 /* even. We give an example where N = 6. */
1043
1044 /* AP is Upper AP is Lower */
1045
1046 /* 00 01 02 03 04 05 00 */
1047 /* 11 12 13 14 15 10 11 */
1048 /* 22 23 24 25 20 21 22 */
1049 /* 33 34 35 30 31 32 33 */
1050 /* 44 45 40 41 42 43 44 */
1051 /* 55 50 51 52 53 54 55 */
1052
1053
1054 /* Let TRANSR = 'N'. RFP holds AP as follows: */
1055 /* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
1056 /* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
1057 /* the transpose of the first three columns of AP upper. */
1058 /* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
1059 /* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
1060 /* the transpose of the last three columns of AP lower. */
1061 /* This covers the case N even and TRANSR = 'N'. */
1062
1063 /* RFP A RFP A */
1064
1065 /* 03 04 05 33 43 53 */
1066 /* 13 14 15 00 44 54 */
1067 /* 23 24 25 10 11 55 */
1068 /* 33 34 35 20 21 22 */
1069 /* 00 44 45 30 31 32 */
1070 /* 01 11 55 40 41 42 */
1071 /* 02 12 22 50 51 52 */
1072
1073 /* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
1074 /* transpose of RFP A above. One therefore gets: */
1075
1076
1077 /* RFP A RFP A */
1078
1079 /* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
1080 /* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
1081 /* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
1082
1083
1084 /* We first consider Rectangular Full Packed (RFP) Format when N is */
1085 /* odd. We give an example where N = 5. */
1086
1087 /* AP is Upper AP is Lower */
1088
1089 /* 00 01 02 03 04 00 */
1090 /* 11 12 13 14 10 11 */
1091 /* 22 23 24 20 21 22 */
1092 /* 33 34 30 31 32 33 */
1093 /* 44 40 41 42 43 44 */
1094
1095
1096 /* Let TRANSR = 'N'. RFP holds AP as follows: */
1097 /* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
1098 /* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
1099 /* the transpose of the first two columns of AP upper. */
1100 /* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
1101 /* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
1102 /* the transpose of the last two columns of AP lower. */
1103 /* This covers the case N odd and TRANSR = 'N'. */
1104
1105 /* RFP A RFP A */
1106
1107 /* 02 03 04 00 33 43 */
1108 /* 12 13 14 10 11 44 */
1109 /* 22 23 24 20 21 22 */
1110 /* 00 33 34 30 31 32 */
1111 /* 01 11 44 40 41 42 */
1112
1113 /* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
1114 /* transpose of RFP A above. One therefore gets: */
1115
1116 /* RFP A RFP A */
1117
1118 /* 02 12 22 00 01 00 10 20 30 40 50 */
1119 /* 03 13 23 33 11 33 11 21 31 41 51 */
1120 /* 04 14 24 34 44 43 44 22 32 42 52 */
1121
1122 /* Reference */
1123 /* ========= */
1124
1125 /* ===================================================================== */
1126
1127 /* .. */
1128 /* .. Parameters .. */
1129 /* .. */
1130 /* .. Local Scalars .. */
1131 /* .. */
1132 /* .. External Functions .. */
1133 /* .. */
1134 /* .. External Subroutines .. */
1135 /* .. */
1136 /* .. Intrinsic Functions .. */
1137 /* .. */
1138 /* .. Executable Statements .. */
1139
1140 /* Test the input parameters. */
1141
1142 /* Parameter adjustments */
1143 b_dim1 = *ldb - 1 - 0 + 1;
1144 b_offset = 0 + b_dim1 * 0;
1145 b -= b_offset;
1146
1147 /* Function Body */
1148 info = 0;
1149 normaltransr = lsame_(transr, "N");
1150 lside = lsame_(side, "L");
1151 lower = lsame_(uplo, "L");
1152 notrans = lsame_(trans, "N");
1153 if (! normaltransr && ! lsame_(transr, "T")) {
1154 info = -1;
1155 } else if (! lside && ! lsame_(side, "R")) {
1156 info = -2;
1157 } else if (! lower && ! lsame_(uplo, "U")) {
1158 info = -3;
1159 } else if (! notrans && ! lsame_(trans, "T")) {
1160 info = -4;
1161 } else if (! lsame_(diag, "N") && ! lsame_(diag,
1162 "U")) {
1163 info = -5;
1164 } else if (*m < 0) {
1165 info = -6;
1166 } else if (*n < 0) {
1167 info = -7;
1168 } else if (*ldb < std::max(1_integer,*m)) {
1169 info = -11;
1170 }
1171 if (info != 0) {
1172 i__1 = -info;
1173 xerbla_("DTFSM ", &i__1);
1174 return 0;
1175 }
1176
1177 /* Quick return when ( (N.EQ.0).OR.(M.EQ.0) ) */
1178
1179 if (*m == 0 || *n == 0) {
1180 return 0;
1181 }
1182
1183 /* Quick return when ALPHA.EQ.(0D+0) */
1184
1185 if (*alpha == 0.) {
1186 i__1 = *n - 1;
1187 for (j = 0; j <= i__1; ++j) {
1188 i__2 = *m - 1;
1189 for (i__ = 0; i__ <= i__2; ++i__) {
1190 b[i__ + j * b_dim1] = 0.;
1191 /* L10: */
1192 }
1193 /* L20: */
1194 }
1195 return 0;
1196 }
1197
1198 if (lside) {
1199
1200 /* SIDE = 'L' */
1201
1202 /* A is M-by-M. */
1203 /* If M is odd, set NISODD = .TRUE., and M1 and M2. */
1204 /* If M is even, NISODD = .FALSE., and M. */
1205
1206 if (*m % 2 == 0) {
1207 misodd = false;
1208 k = *m / 2;
1209 } else {
1210 misodd = true;
1211 if (lower) {
1212 m2 = *m / 2;
1213 m1 = *m - m2;
1214 } else {
1215 m1 = *m / 2;
1216 m2 = *m - m1;
1217 }
1218 }
1219
1220
1221 if (misodd) {
1222
1223 /* SIDE = 'L' and N is odd */
1224
1225 if (normaltransr) {
1226
1227 /* SIDE = 'L', N is odd, and TRANSR = 'N' */
1228
1229 if (lower) {
1230
1231 /* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'L' */
1232
1233 if (notrans) {
1234
1235 /* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and */
1236 /* TRANS = 'N' */
1237
1238 if (*m == 1) {
1239 dtrsm_("L", "L", "N", diag, &m1, n, alpha, a, m, &b[b_offset], ldb);
1240 } else {
1241 dtrsm_("L", "L", "N", diag, &m1, n, alpha, a, m, &b[b_offset], ldb);
1242 dgemm_("N", "N", &m2, n, &m1, &c_b23, &a[m1], m, &b[b_offset], ldb, alpha, &b[m1], ldb);
1243 dtrsm_("L", "U", "T", diag, &m2, n, &c_b27, &a[*m], m, &b[m1], ldb);
1244 }
1245
1246 } else {
1247
1248 /* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and */
1249 /* TRANS = 'T' */
1250
1251 if (*m == 1) {
1252 dtrsm_("L", "L", "T", diag, &m1, n, alpha, a, m, &b[b_offset], ldb);
1253 } else {
1254 dtrsm_("L", "U", "N", diag, &m2, n, alpha, &a[*m], m, &b[m1], ldb);
1255 dgemm_("T", "N", &m1, n, &m2, &c_b23, &a[m1], m, &b[m1], ldb, alpha, &b[b_offset], ldb);
1256 dtrsm_("L", "L", "T", diag, &m1, n, &c_b27, a, m, &b[b_offset], ldb);
1257 }
1258
1259 }
1260
1261 } else {
1262
1263 /* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'U' */
1264
1265 if (! notrans) {
1266
1267 /* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and */
1268 /* TRANS = 'N' */
1269
1270 dtrsm_("L", "L", "N", diag, &m1, n, alpha, &a[m2], m, &b[b_offset], ldb);
1271 dgemm_("T", "N", &m2, n, &m1, &c_b23, a, m, &b[b_offset], ldb, alpha, &b[m1], ldb);
1272 dtrsm_("L", "U", "T", diag, &m2, n, &c_b27, &a[m1], m, &b[m1], ldb);
1273
1274 } else {
1275
1276 /* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and */
1277 /* TRANS = 'T' */
1278
1279 dtrsm_("L", "U", "N", diag, &m2, n, alpha, &a[m1], m, &b[m1], ldb);
1280 dgemm_("N", "N", &m1, n, &m2, &c_b23, a, m, &b[m1], ldb, alpha, &b[b_offset], ldb);
1281 dtrsm_("L", "L", "T", diag, &m1, n, &c_b27, &a[m2], m, &b[b_offset], ldb);
1282
1283 }
1284
1285 }
1286
1287 } else {
1288
1289 /* SIDE = 'L', N is odd, and TRANSR = 'T' */
1290
1291 if (lower) {
1292
1293 /* SIDE ='L', N is odd, TRANSR = 'T', and UPLO = 'L' */
1294
1295 if (notrans) {
1296
1297 /* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'L', and */
1298 /* TRANS = 'N' */
1299
1300 if (*m == 1) {
1301 dtrsm_("L", "U", "T", diag, &m1, n, alpha, a, &m1, &b[b_offset], ldb);
1302 } else {
1303 dtrsm_("L", "U", "T", diag, &m1, n, alpha, a, &m1, &b[b_offset], ldb);
1304 dgemm_("T", "N", &m2, n, &m1, &c_b23, &a[m1 * m1], &m1, &b[b_offset], ldb, alpha, &b[m1], ldb);
1305 dtrsm_("L", "L", "N", diag, &m2, n, &c_b27, &a[1], &m1, &b[m1], ldb);
1306 }
1307
1308 } else {
1309
1310 /* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'L', and */
1311 /* TRANS = 'T' */
1312
1313 if (*m == 1) {
1314 dtrsm_("L", "U", "N", diag, &m1, n, alpha, a, &m1, &b[b_offset], ldb);
1315 } else {
1316 dtrsm_("L", "L", "T", diag, &m2, n, alpha, &a[1], &m1, &b[m1], ldb);
1317 dgemm_("N", "N", &m1, n, &m2, &c_b23, &a[m1 * m1], &m1, &b[m1], ldb, alpha, &b[b_offset], ldb);
1318 dtrsm_("L", "U", "N", diag, &m1, n, &c_b27, a, &m1, &b[b_offset], ldb);
1319 }
1320
1321 }
1322
1323 } else {
1324
1325 /* SIDE ='L', N is odd, TRANSR = 'T', and UPLO = 'U' */
1326
1327 if (! notrans) {
1328
1329 /* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'U', and */
1330 /* TRANS = 'N' */
1331
1332 dtrsm_("L", "U", "T", diag, &m1, n, alpha, &a[m2 * m2], &m2, &b[b_offset], ldb);
1333 dgemm_("N", "N", &m2, n, &m1, &c_b23, a, &m2, &b[b_offset], ldb, alpha, &b[m1], ldb);
1334 dtrsm_("L", "L", "N", diag, &m2, n, &c_b27, &a[m1 * m2], &m2, &b[m1], ldb);
1335
1336 } else {
1337
1338 /* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'U', and */
1339 /* TRANS = 'T' */
1340
1341 dtrsm_("L", "L", "T", diag, &m2, n, alpha, &a[m1 * m2], &m2, &b[m1], ldb);
1342 dgemm_("T", "N", &m1, n, &m2, &c_b23, a, &m2, &b[m1], ldb, alpha, &b[b_offset], ldb);
1343 dtrsm_("L", "U", "N", diag, &m1, n, &c_b27, &a[m2 * m2], &m2, &b[b_offset], ldb);
1344
1345 }
1346
1347 }
1348
1349 }
1350
1351 } else {
1352
1353 /* SIDE = 'L' and N is even */
1354
1355 if (normaltransr) {
1356
1357 /* SIDE = 'L', N is even, and TRANSR = 'N' */
1358
1359 if (lower) {
1360
1361 /* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'L' */
1362
1363 if (notrans) {
1364
1365 /* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', */
1366 /* and TRANS = 'N' */
1367
1368 i__1 = *m + 1;
1369 dtrsm_("L", "L", "N", diag, &k, n, alpha, &a[1], &i__1, &b[b_offset], ldb);
1370 i__1 = *m + 1;
1371 dgemm_("N", "N", &k, n, &k, &c_b23, &a[k + 1], &i__1, &b[b_offset], ldb, alpha, &b[k], ldb);
1372 i__1 = *m + 1;
1373 dtrsm_("L", "U", "T", diag, &k, n, &c_b27, a, &i__1, &b[k], ldb);
1374
1375 } else {
1376
1377 /* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', */
1378 /* and TRANS = 'T' */
1379
1380 i__1 = *m + 1;
1381 dtrsm_("L", "U", "N", diag, &k, n, alpha, a, &i__1, &b[k], ldb);
1382 i__1 = *m + 1;
1383 dgemm_("T", "N", &k, n, &k, &c_b23, &a[k + 1], &i__1, &b[k], ldb, alpha, &b[b_offset], ldb);
1384 i__1 = *m + 1;
1385 dtrsm_("L", "L", "T", diag, &k, n, &c_b27, &a[1], &i__1, &b[b_offset], ldb);
1386
1387 }
1388
1389 } else {
1390
1391 /* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'U' */
1392
1393 if (! notrans) {
1394
1395 /* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', */
1396 /* and TRANS = 'N' */
1397
1398 i__1 = *m + 1;
1399 dtrsm_("L", "L", "N", diag, &k, n, alpha, &a[k + 1], &i__1, &b[b_offset], ldb);
1400 i__1 = *m + 1;
1401 dgemm_("T", "N", &k, n, &k, &c_b23, a, &i__1, &b[b_offset], ldb, alpha, &b[k], ldb);
1402 i__1 = *m + 1;
1403 dtrsm_("L", "U", "T", diag, &k, n, &c_b27, &a[k], &i__1, &b[k], ldb);
1404
1405 } else {
1406
1407 /* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', */
1408 /* and TRANS = 'T' */
1409 i__1 = *m + 1;
1410 dtrsm_("L", "U", "N", diag, &k, n, alpha, &a[k], &i__1, &b[k], ldb);
1411 i__1 = *m + 1;
1412 dgemm_("N", "N", &k, n, &k, &c_b23, a, &i__1, &b[k], ldb, alpha, &b[b_offset], ldb);
1413 i__1 = *m + 1;
1414 dtrsm_("L", "L", "T", diag, &k, n, &c_b27, &a[k + 1], &i__1, &b[b_offset], ldb);
1415
1416 }
1417
1418 }
1419
1420 } else {
1421
1422 /* SIDE = 'L', N is even, and TRANSR = 'T' */
1423
1424 if (lower) {
1425
1426 /* SIDE ='L', N is even, TRANSR = 'T', and UPLO = 'L' */
1427
1428 if (notrans) {
1429
1430 /* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'L', */
1431 /* and TRANS = 'N' */
1432
1433 dtrsm_("L", "U", "T", diag, &k, n, alpha, &a[k], &k, &b[b_offset], ldb);
1434 dgemm_("T", "N", &k, n, &k, &c_b23, &a[k * (k + 1)], &k, &b[b_offset], ldb, alpha, &b[k], ldb);
1435 dtrsm_("L", "L", "N", diag, &k, n, &c_b27, a, &k, &b[k], ldb);
1436
1437 } else {
1438
1439 /* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'L', */
1440 /* and TRANS = 'T' */
1441
1442 dtrsm_("L", "L", "T", diag, &k, n, alpha, a, &k, &b[k], ldb);
1443 dgemm_("N", "N", &k, n, &k, &c_b23, &a[k * (k + 1)], &k, &b[k], ldb, alpha, &b[b_offset], ldb);
1444 dtrsm_("L", "U", "N", diag, &k, n, &c_b27, &a[k], &k, &b[b_offset], ldb);
1445
1446 }
1447
1448 } else {
1449
1450 /* SIDE ='L', N is even, TRANSR = 'T', and UPLO = 'U' */
1451
1452 if (! notrans) {
1453
1454 /* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'U', */
1455 /* and TRANS = 'N' */
1456
1457 dtrsm_("L", "U", "T", diag, &k, n, alpha, &a[k * (k + 1)], &k, &b[b_offset], ldb);
1458 dgemm_("N", "N", &k, n, &k, &c_b23, a, &k, &b[b_offset], ldb, alpha, &b[k], ldb);
1459 dtrsm_("L", "L", "N", diag, &k, n, &c_b27, &a[k * k], &k, &b[k], ldb);
1460
1461 } else {
1462
1463 /* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'U', */
1464 /* and TRANS = 'T' */
1465
1466 dtrsm_("L", "L", "T", diag, &k, n, alpha, &a[k * k], &k, &b[k], ldb);
1467 dgemm_("T", "N", &k, n, &k, &c_b23, a, &k, &b[k], ldb, alpha, &b[b_offset], ldb);
1468 dtrsm_("L", "U", "N", diag, &k, n, &c_b27, &a[k * (k + 1)], &k, &b[b_offset], ldb);
1469
1470 }
1471
1472 }
1473
1474 }
1475
1476 }
1477
1478 } else {
1479
1480 /* SIDE = 'R' */
1481
1482 /* A is N-by-N. */
1483 /* If N is odd, set NISODD = .TRUE., and N1 and N2. */
1484 /* If N is even, NISODD = .FALSE., and K. */
1485
1486 if (*n % 2 == 0) {
1487 nisodd = false;
1488 k = *n / 2;
1489 } else {
1490 nisodd = true;
1491 if (lower) {
1492 n2 = *n / 2;
1493 n1 = *n - n2;
1494 } else {
1495 n1 = *n / 2;
1496 n2 = *n - n1;
1497 }
1498 }
1499
1500 if (nisodd) {
1501
1502 /* SIDE = 'R' and N is odd */
1503
1504 if (normaltransr) {
1505
1506 /* SIDE = 'R', N is odd, and TRANSR = 'N' */
1507
1508 if (lower) {
1509
1510 /* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'L' */
1511
1512 if (notrans) {
1513
1514 /* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and */
1515 /* TRANS = 'N' */
1516
1517 dtrsm_("R", "U", "T", diag, m, &n2, alpha, &a[*n], n, &b[n1 * b_dim1], ldb);
1518 dgemm_("N", "N", m, &n1, &n2, &c_b23, &b[n1 * b_dim1], ldb, &a[n1], n, alpha, b, ldb);
1519 dtrsm_("R", "L", "N", diag, m, &n1, &c_b27, a, n, b, ldb);
1520
1521 } else {
1522
1523 /* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and */
1524 /* TRANS = 'T' */
1525
1526 dtrsm_("R", "L", "T", diag, m, &n1, alpha, a, n, b, ldb);
1527 dgemm_("N", "T", m, &n2, &n1, &c_b23, b, ldb, &a[n1], n, alpha, &b[n1 * b_dim1], ldb);
1528 dtrsm_("R", "U", "N", diag, m, &n2, &c_b27, &a[*n], n, &b[n1 * b_dim1], ldb);
1529
1530 }
1531
1532 } else {
1533
1534 /* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'U' */
1535
1536 if (notrans) {
1537
1538 /* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and */
1539 /* TRANS = 'N' */
1540
1541 dtrsm_("R", "L", "T", diag, m, &n1, alpha, &a[n2], n, b, ldb);
1542 dgemm_("N", "N", m, &n2, &n1, &c_b23, b, ldb, a, n, alpha, &b[n1 * b_dim1], ldb);
1543 dtrsm_("R", "U", "N", diag, m, &n2, &c_b27, &a[n1], n, &b[n1 * b_dim1], ldb);
1544
1545 } else {
1546
1547 /* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and */
1548 /* TRANS = 'T' */
1549
1550 dtrsm_("R", "U", "T", diag, m, &n2, alpha, &a[n1], n, &b[n1 * b_dim1], ldb);
1551 dgemm_("N", "T", m, &n1, &n2, &c_b23, &b[n1 * b_dim1], ldb, a, n, alpha, b, ldb);
1552 dtrsm_("R", "L", "N", diag, m, &n1, &c_b27, &a[n2], n, b, ldb);
1553
1554 }
1555
1556 }
1557
1558 } else {
1559
1560 /* SIDE = 'R', N is odd, and TRANSR = 'T' */
1561
1562 if (lower) {
1563
1564 /* SIDE ='R', N is odd, TRANSR = 'T', and UPLO = 'L' */
1565
1566 if (notrans) {
1567
1568 /* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'L', and */
1569 /* TRANS = 'N' */
1570
1571 dtrsm_("R", "L", "N", diag, m, &n2, alpha, &a[1], &n1, &b[n1 * b_dim1], ldb);
1572 dgemm_("N", "T", m, &n1, &n2, &c_b23, &b[n1 * b_dim1], ldb, &a[n1 * n1], &n1, alpha, b, ldb);
1573 dtrsm_("R", "U", "T", diag, m, &n1, &c_b27, a, &n1, b, ldb);
1574
1575 } else {
1576
1577 /* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'L', and */
1578 /* TRANS = 'T' */
1579
1580 dtrsm_("R", "U", "N", diag, m, &n1, alpha, a, &n1, b, ldb);
1581 dgemm_("N", "N", m, &n2, &n1, &c_b23, b, ldb, &a[n1 * n1], &n1, alpha, &b[n1 * b_dim1], ldb);
1582 dtrsm_("R", "L", "T", diag, m, &n2, &c_b27, &a[1], &n1, &b[n1 * b_dim1], ldb);
1583
1584 }
1585
1586 } else {
1587
1588 /* SIDE ='R', N is odd, TRANSR = 'T', and UPLO = 'U' */
1589
1590 if (notrans) {
1591
1592 /* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'U', and */
1593 /* TRANS = 'N' */
1594
1595 dtrsm_("R", "U", "N", diag, m, &n1, alpha, &a[n2 * n2], &n2, b, ldb);
1596 dgemm_("N", "T", m, &n2, &n1, &c_b23, b, ldb, a, &n2, alpha, &b[n1 * b_dim1], ldb);
1597 dtrsm_("R", "L", "T", diag, m, &n2, &c_b27, &a[n1 * n2], &n2, &b[n1 * b_dim1], ldb);
1598
1599 } else {
1600
1601 /* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'U', and */
1602 /* TRANS = 'T' */
1603
1604 dtrsm_("R", "L", "N", diag, m, &n2, alpha, &a[n1 * n2], &n2, &b[n1 * b_dim1], ldb);
1605 dgemm_("N", "N", m, &n1, &n2, &c_b23, &b[n1 * b_dim1], ldb, a, &n2, alpha, b, ldb);
1606 dtrsm_("R", "U", "T", diag, m, &n1, &c_b27, &a[n2 * n2], &n2, b, ldb);
1607
1608 }
1609
1610 }
1611
1612 }
1613
1614 } else {
1615
1616 /* SIDE = 'R' and N is even */
1617
1618 if (normaltransr) {
1619
1620 /* SIDE = 'R', N is even, and TRANSR = 'N' */
1621
1622 if (lower) {
1623
1624 /* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'L' */
1625
1626 if (notrans) {
1627
1628 /* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', */
1629 /* and TRANS = 'N' */
1630
1631 i__1 = *n + 1;
1632 dtrsm_("R", "U", "T", diag, m, &k, alpha, a, &i__1, &b[k * b_dim1], ldb);
1633 i__1 = *n + 1;
1634 dgemm_("N", "N", m, &k, &k, &c_b23, &b[k * b_dim1], ldb, &a[k + 1], &i__1, alpha, b, ldb);
1635 i__1 = *n + 1;
1636 dtrsm_("R", "L", "N", diag, m, &k, &c_b27, &a[1], &i__1, b, ldb);
1637
1638 } else {
1639
1640 /* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', */
1641 /* and TRANS = 'T' */
1642
1643 i__1 = *n + 1;
1644 dtrsm_("R", "L", "T", diag, m, &k, alpha, &a[1], &i__1, b, ldb);
1645 i__1 = *n + 1;
1646 dgemm_("N", "T", m, &k, &k, &c_b23, b, ldb, &a[k + 1], &i__1, alpha, &b[k * b_dim1], ldb);
1647 i__1 = *n + 1;
1648 dtrsm_("R", "U", "N", diag, m, &k, &c_b27, a, &i__1, &b[k * b_dim1], ldb);
1649
1650 }
1651
1652 } else {
1653
1654 /* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'U' */
1655
1656 if (notrans) {
1657
1658 /* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', */
1659 /* and TRANS = 'N' */
1660
1661 i__1 = *n + 1;
1662 dtrsm_("R", "L", "T", diag, m, &k, alpha, &a[k + 1], &i__1, b, ldb);
1663 i__1 = *n + 1;
1664 dgemm_("N", "N", m, &k, &k, &c_b23, b, ldb, a, &i__1, alpha, &b[k * b_dim1], ldb);
1665 i__1 = *n + 1;
1666 dtrsm_("R", "U", "N", diag, m, &k, &c_b27, &a[k], &i__1, &b[k * b_dim1], ldb);
1667
1668 } else {
1669
1670 /* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', */
1671 /* and TRANS = 'T' */
1672
1673 i__1 = *n + 1;
1674 dtrsm_("R", "U", "T", diag, m, &k, alpha, &a[k], &i__1, &b[k * b_dim1], ldb);
1675 i__1 = *n + 1;
1676 dgemm_("N", "T", m, &k, &k, &c_b23, &b[k * b_dim1], ldb, a, &i__1, alpha, b, ldb);
1677 i__1 = *n + 1;
1678 dtrsm_("R", "L", "N", diag, m, &k, &c_b27, &a[k + 1], &i__1, b, ldb);
1679
1680 }
1681
1682 }
1683
1684 } else {
1685
1686 /* SIDE = 'R', N is even, and TRANSR = 'T' */
1687
1688 if (lower) {
1689
1690 /* SIDE ='R', N is even, TRANSR = 'T', and UPLO = 'L' */
1691
1692 if (notrans) {
1693
1694 /* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'L', */
1695 /* and TRANS = 'N' */
1696
1697 dtrsm_("R", "L", "N", diag, m, &k, alpha, a, &k, &b[k * b_dim1], ldb);
1698 dgemm_("N", "T", m, &k, &k, &c_b23, &b[k * b_dim1], ldb, &a[(k + 1) * k], &k, alpha, b, ldb);
1699 dtrsm_("R", "U", "T", diag, m, &k, &c_b27, &a[k], &k, b, ldb);
1700
1701 } else {
1702
1703 /* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'L', */
1704 /* and TRANS = 'T' */
1705
1706 dtrsm_("R", "U", "N", diag, m, &k, alpha, &a[k], &k, b, ldb);
1707 dgemm_("N", "N", m, &k, &k, &c_b23, b, ldb, &a[(k + 1) * k], &k, alpha, &b[k * b_dim1], ldb);
1708 dtrsm_("R", "L", "T", diag, m, &k, &c_b27, a, &k, &b[k * b_dim1], ldb);
1709
1710 }
1711
1712 } else {
1713
1714 /* SIDE ='R', N is even, TRANSR = 'T', and UPLO = 'U' */
1715
1716 if (notrans) {
1717
1718 /* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'U', */
1719 /* and TRANS = 'N' */
1720
1721 dtrsm_("R", "U", "N", diag, m, &k, alpha, &a[(k + 1) * k], &k, b, ldb);
1722 dgemm_("N", "T", m, &k, &k, &c_b23, b, ldb, a, &k, alpha, &b[k * b_dim1], ldb);
1723 dtrsm_("R", "L", "T", diag, m, &k, &c_b27, &a[k * k], &k, &b[k * b_dim1], ldb);
1724
1725 } else {
1726
1727 /* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'U', */
1728 /* and TRANS = 'T' */
1729
1730 dtrsm_("R", "L", "N", diag, m, &k, alpha, &a[k * k], &k, &b[k * b_dim1], ldb);
1731 dgemm_("N", "N", m, &k, &k, &c_b23, &b[k * b_dim1], ldb, a, &k, alpha, b, ldb);
1732 dtrsm_("R", "U", "T", diag, m, &k, &c_b27, &a[(k + 1) * k], &k, b, ldb);
1733
1734 }
1735
1736 }
1737
1738 }
1739
1740 }
1741 }
1742
1743 return 0;
1744
1745 /* End of DTFSM */
1746
1747 } /* dtfsm_ */
1748
dtftri_(const char * transr,const char * uplo,const char * diag,integer * n,double * a,integer * info)1749 int dtftri_(const char *transr, const char *uplo, const char *diag, integer *n, double *a, integer *info)
1750 {
1751 /* Table of constant values */
1752 static double c_b13 = -1.;
1753 static double c_b18 = 1.;
1754
1755 /* System generated locals */
1756 integer i__1, i__2;
1757
1758 /* Local variables */
1759 integer k, n1, n2;
1760 bool normaltransr, lower, nisodd;
1761
1762
1763 /* -- LAPACK routine (version 3.2) -- */
1764
1765 /* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
1766 /* -- November 2008 -- */
1767
1768 /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
1769 /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
1770
1771 /* .. Scalar Arguments .. */
1772 /* .. */
1773 /* .. Array Arguments .. */
1774 /* .. */
1775
1776 /* Purpose */
1777 /* ======= */
1778
1779 /* DTFTRI computes the inverse of a triangular matrix A stored in RFP */
1780 /* format. */
1781
1782 /* This is a Level 3 BLAS version of the algorithm. */
1783
1784 /* Arguments */
1785 /* ========= */
1786
1787 /* TRANSR (input) CHARACTER */
1788 /* = 'N': The Normal TRANSR of RFP A is stored; */
1789 /* = 'T': The Transpose TRANSR of RFP A is stored. */
1790
1791 /* UPLO (input) CHARACTER */
1792 /* = 'U': A is upper triangular; */
1793 /* = 'L': A is lower triangular. */
1794
1795 /* DIAG (input) CHARACTER */
1796 /* = 'N': A is non-unit triangular; */
1797 /* = 'U': A is unit triangular. */
1798
1799 /* N (input) INTEGER */
1800 /* The order of the matrix A. N >= 0. */
1801
1802 /* A (input/output) DOUBLE PRECISION array, dimension (0:nt-1); */
1803 /* nt=N*(N+1)/2. On entry, the triangular factor of a Hermitian */
1804 /* Positive Definite matrix A in RFP format. RFP format is */
1805 /* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' */
1806 /* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is */
1807 /* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is */
1808 /* the transpose of RFP A as defined when */
1809 /* TRANSR = 'N'. The contents of RFP A are defined by UPLO as */
1810 /* follows: If UPLO = 'U' the RFP A contains the nt elements of */
1811 /* upper packed A; If UPLO = 'L' the RFP A contains the nt */
1812 /* elements of lower packed A. The LDA of RFP A is (N+1)/2 when */
1813 /* TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is */
1814 /* even and N is odd. See the Note below for more details. */
1815
1816 /* On exit, the (triangular) inverse of the original matrix, in */
1817 /* the same storage format. */
1818
1819 /* INFO (output) INTEGER */
1820 /* = 0: successful exit */
1821 /* < 0: if INFO = -i, the i-th argument had an illegal value */
1822 /* > 0: if INFO = i, A(i,i) is exactly zero. The triangular */
1823 /* matrix is singular and its inverse can not be computed. */
1824
1825 /* Notes */
1826 /* ===== */
1827
1828 /* We first consider Rectangular Full Packed (RFP) Format when N is */
1829 /* even. We give an example where N = 6. */
1830
1831 /* AP is Upper AP is Lower */
1832
1833 /* 00 01 02 03 04 05 00 */
1834 /* 11 12 13 14 15 10 11 */
1835 /* 22 23 24 25 20 21 22 */
1836 /* 33 34 35 30 31 32 33 */
1837 /* 44 45 40 41 42 43 44 */
1838 /* 55 50 51 52 53 54 55 */
1839
1840
1841 /* Let TRANSR = 'N'. RFP holds AP as follows: */
1842 /* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
1843 /* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
1844 /* the transpose of the first three columns of AP upper. */
1845 /* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
1846 /* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
1847 /* the transpose of the last three columns of AP lower. */
1848 /* This covers the case N even and TRANSR = 'N'. */
1849
1850 /* RFP A RFP A */
1851
1852 /* 03 04 05 33 43 53 */
1853 /* 13 14 15 00 44 54 */
1854 /* 23 24 25 10 11 55 */
1855 /* 33 34 35 20 21 22 */
1856 /* 00 44 45 30 31 32 */
1857 /* 01 11 55 40 41 42 */
1858 /* 02 12 22 50 51 52 */
1859
1860 /* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
1861 /* transpose of RFP A above. One therefore gets: */
1862
1863
1864 /* RFP A RFP A */
1865
1866 /* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
1867 /* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
1868 /* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
1869
1870
1871 /* We first consider Rectangular Full Packed (RFP) Format when N is */
1872 /* odd. We give an example where N = 5. */
1873
1874 /* AP is Upper AP is Lower */
1875
1876 /* 00 01 02 03 04 00 */
1877 /* 11 12 13 14 10 11 */
1878 /* 22 23 24 20 21 22 */
1879 /* 33 34 30 31 32 33 */
1880 /* 44 40 41 42 43 44 */
1881
1882
1883 /* Let TRANSR = 'N'. RFP holds AP as follows: */
1884 /* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
1885 /* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
1886 /* the transpose of the first two columns of AP upper. */
1887 /* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
1888 /* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
1889 /* the transpose of the last two columns of AP lower. */
1890 /* This covers the case N odd and TRANSR = 'N'. */
1891
1892 /* RFP A RFP A */
1893
1894 /* 02 03 04 00 33 43 */
1895 /* 12 13 14 10 11 44 */
1896 /* 22 23 24 20 21 22 */
1897 /* 00 33 34 30 31 32 */
1898 /* 01 11 44 40 41 42 */
1899
1900 /* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
1901 /* transpose of RFP A above. One therefore gets: */
1902
1903 /* RFP A RFP A */
1904
1905 /* 02 12 22 00 01 00 10 20 30 40 50 */
1906 /* 03 13 23 33 11 33 11 21 31 41 51 */
1907 /* 04 14 24 34 44 43 44 22 32 42 52 */
1908
1909 /* ===================================================================== */
1910
1911 /* .. Parameters .. */
1912 /* .. */
1913 /* .. Local Scalars .. */
1914 /* .. */
1915 /* .. External Functions .. */
1916 /* .. */
1917 /* .. External Subroutines .. */
1918 /* .. */
1919 /* .. Intrinsic Functions .. */
1920 /* .. */
1921 /* .. Executable Statements .. */
1922
1923 /* Test the input parameters. */
1924
1925 *info = 0;
1926 normaltransr = lsame_(transr, "N");
1927 lower = lsame_(uplo, "L");
1928 if (! normaltransr && ! lsame_(transr, "T")) {
1929 *info = -1;
1930 } else if (! lower && ! lsame_(uplo, "U")) {
1931 *info = -2;
1932 } else if (! lsame_(diag, "N") && ! lsame_(diag,
1933 "U")) {
1934 *info = -3;
1935 } else if (*n < 0) {
1936 *info = -4;
1937 }
1938 if (*info != 0) {
1939 i__1 = -(*info);
1940 xerbla_("DTFTRI", &i__1);
1941 return 0;
1942 }
1943
1944 /* Quick return if possible */
1945
1946 if (*n == 0) {
1947 return 0;
1948 }
1949
1950 /* If N is odd, set NISODD = .TRUE. */
1951 /* If N is even, set K = N/2 and NISODD = .FALSE. */
1952
1953 if (*n % 2 == 0) {
1954 k = *n / 2;
1955 nisodd = false;
1956 } else {
1957 nisodd = true;
1958 }
1959
1960 /* Set N1 and N2 depending on LOWER */
1961
1962 if (lower) {
1963 n2 = *n / 2;
1964 n1 = *n - n2;
1965 } else {
1966 n1 = *n / 2;
1967 n2 = *n - n1;
1968 }
1969
1970
1971 /* start execution: there are eight cases */
1972
1973 if (nisodd) {
1974
1975 /* N is odd */
1976
1977 if (normaltransr) {
1978
1979 /* N is odd and TRANSR = 'N' */
1980
1981 if (lower) {
1982
1983 /* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */
1984 /* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */
1985 /* T1 -> a(0), T2 -> a(n), S -> a(n1) */
1986
1987 dtrtri_("L", diag, &n1, a, n, info);
1988 if (*info > 0) {
1989 return 0;
1990 }
1991 dtrmm_("R", "L", "N", diag, &n2, &n1, &c_b13, a, n, &a[n1], n);
1992 dtrtri_("U", diag, &n2, &a[*n], n, info)
1993 ;
1994 if (*info > 0) {
1995 *info += n1;
1996 }
1997 if (*info > 0) {
1998 return 0;
1999 }
2000 dtrmm_("L", "U", "T", diag, &n2, &n1, &c_b18, &a[*n], n, &a[
2001 n1], n);
2002
2003 } else {
2004
2005 /* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */
2006 /* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */
2007 /* T1 -> a(n2), T2 -> a(n1), S -> a(0) */
2008
2009 dtrtri_("L", diag, &n1, &a[n2], n, info)
2010 ;
2011 if (*info > 0) {
2012 return 0;
2013 }
2014 dtrmm_("L", "L", "T", diag, &n1, &n2, &c_b13, &a[n2], n, a, n);
2015 dtrtri_("U", diag, &n2, &a[n1], n, info)
2016 ;
2017 if (*info > 0) {
2018 *info += n1;
2019 }
2020 if (*info > 0) {
2021 return 0;
2022 }
2023 dtrmm_("R", "U", "N", diag, &n1, &n2, &c_b18, &a[n1], n, a, n);
2024
2025 }
2026
2027 } else {
2028
2029 /* N is odd and TRANSR = 'T' */
2030
2031 if (lower) {
2032
2033 /* SRPA for LOWER, TRANSPOSE and N is odd */
2034 /* T1 -> a(0), T2 -> a(1), S -> a(0+n1*n1) */
2035
2036 dtrtri_("U", diag, &n1, a, &n1, info);
2037 if (*info > 0) {
2038 return 0;
2039 }
2040 dtrmm_("L", "U", "N", diag, &n1, &n2, &c_b13, a, &n1, &a[n1 * n1], &n1);
2041 dtrtri_("L", diag, &n2, &a[1], &n1, info);
2042 if (*info > 0) {
2043 *info += n1;
2044 }
2045 if (*info > 0) {
2046 return 0;
2047 }
2048 dtrmm_("R", "L", "T", diag, &n1, &n2, &c_b18, &a[1], &n1, &a[n1 * n1], &n1);
2049
2050 } else {
2051
2052 /* SRPA for UPPER, TRANSPOSE and N is odd */
2053 /* T1 -> a(0+n2*n2), T2 -> a(0+n1*n2), S -> a(0) */
2054
2055 dtrtri_("U", diag, &n1, &a[n2 * n2], &n2, info);
2056 if (*info > 0) {
2057 return 0;
2058 }
2059 dtrmm_("R", "U", "T", diag, &n2, &n1, &c_b13, &a[n2 * n2], &n2, a, &n2);
2060 dtrtri_("L", diag, &n2, &a[n1 * n2], &n2, info);
2061 if (*info > 0) {
2062 *info += n1;
2063 }
2064 if (*info > 0) {
2065 return 0;
2066 }
2067 dtrmm_("L", "L", "N", diag, &n2, &n1, &c_b18, &a[n1 * n2], &n2, a, &n2);
2068 }
2069
2070 }
2071
2072 } else {
2073
2074 /* N is even */
2075
2076 if (normaltransr) {
2077
2078 /* N is even and TRANSR = 'N' */
2079
2080 if (lower) {
2081
2082 /* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
2083 /* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */
2084 /* T1 -> a(1), T2 -> a(0), S -> a(k+1) */
2085
2086 i__1 = *n + 1;
2087 dtrtri_("L", diag, &k, &a[1], &i__1, info);
2088 if (*info > 0) {
2089 return 0;
2090 }
2091 i__1 = *n + 1;
2092 i__2 = *n + 1;
2093 dtrmm_("R", "L", "N", diag, &k, &k, &c_b13, &a[1], &i__1, &a[k + 1], &i__2);
2094 i__1 = *n + 1;
2095 dtrtri_("U", diag, &k, a, &i__1, info);
2096 if (*info > 0) {
2097 *info += k;
2098 }
2099 if (*info > 0) {
2100 return 0;
2101 }
2102 i__1 = *n + 1;
2103 i__2 = *n + 1;
2104 dtrmm_("L", "U", "T", diag, &k, &k, &c_b18, a, &i__1, &a[k + 1], &i__2)
2105 ;
2106
2107 } else {
2108
2109 /* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
2110 /* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */
2111 /* T1 -> a(k+1), T2 -> a(k), S -> a(0) */
2112
2113 i__1 = *n + 1;
2114 dtrtri_("L", diag, &k, &a[k + 1], &i__1, info);
2115 if (*info > 0) {
2116 return 0;
2117 }
2118 i__1 = *n + 1;
2119 i__2 = *n + 1;
2120 dtrmm_("L", "L", "T", diag, &k, &k, &c_b13, &a[k + 1], &i__1, a, &i__2);
2121 i__1 = *n + 1;
2122 dtrtri_("U", diag, &k, &a[k], &i__1, info);
2123 if (*info > 0) {
2124 *info += k;
2125 }
2126 if (*info > 0) {
2127 return 0;
2128 }
2129 i__1 = *n + 1;
2130 i__2 = *n + 1;
2131 dtrmm_("R", "U", "N", diag, &k, &k, &c_b18, &a[k], &i__1, a, &i__2);
2132 }
2133 } else {
2134
2135 /* N is even and TRANSR = 'T' */
2136
2137 if (lower) {
2138
2139 /* SRPA for LOWER, TRANSPOSE and N is even (see paper) */
2140 /* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) */
2141 /* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */
2142
2143 dtrtri_("U", diag, &k, &a[k], &k, info);
2144 if (*info > 0) {
2145 return 0;
2146 }
2147 dtrmm_("L", "U", "N", diag, &k, &k, &c_b13, &a[k], &k, &a[k * (k + 1)], &k);
2148 dtrtri_("L", diag, &k, a, &k, info);
2149 if (*info > 0) {
2150 *info += k;
2151 }
2152 if (*info > 0) {
2153 return 0;
2154 }
2155 dtrmm_("R", "L", "T", diag, &k, &k, &c_b18, a, &k, &a[k * (k + 1)], &k)
2156 ;
2157 } else {
2158
2159 /* SRPA for UPPER, TRANSPOSE and N is even (see paper) */
2160 /* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) */
2161 /* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */
2162
2163 dtrtri_("U", diag, &k, &a[k * (k + 1)], &k, info);
2164 if (*info > 0) {
2165 return 0;
2166 }
2167 dtrmm_("R", "U", "T", diag, &k, &k, &c_b13, &a[k * (k + 1)], &k, a, &k);
2168 dtrtri_("L", diag, &k, &a[k * k], &k, info);
2169 if (*info > 0) {
2170 *info += k;
2171 }
2172 if (*info > 0) {
2173 return 0;
2174 }
2175 dtrmm_("L", "L", "N", diag, &k, &k, &c_b18, &a[k * k], &k, a, &k);
2176 }
2177 }
2178 }
2179
2180 return 0;
2181
2182 /* End of DTFTRI */
2183
2184 } /* dtftri_ */
2185
dtfttp_(const char * transr,const char * uplo,integer * n,double * arf,double * ap,integer * info)2186 int dtfttp_(const char *transr, const char *uplo, integer *n, double *arf, double *ap, integer *info)
2187 {
2188 /* System generated locals */
2189 integer i__1, i__2, i__3;
2190
2191 /* Local variables */
2192 integer i__, j, k, n1, n2, ij, jp, js, lda, ijp;
2193 bool normaltransr, lower, nisodd;
2194
2195
2196 /* -- LAPACK routine (version 3.2) -- */
2197
2198 /* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
2199 /* -- November 2008 -- */
2200
2201 /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
2202 /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
2203
2204 /* .. */
2205 /* .. Scalar Arguments .. */
2206 /* .. */
2207 /* .. Array Arguments .. */
2208 /* .. */
2209
2210 /* Purpose */
2211 /* ======= */
2212
2213 /* DTFTTP copies a triangular matrix A from rectangular full packed */
2214 /* format (TF) to standard packed format (TP). */
2215
2216 /* Arguments */
2217 /* ========= */
2218
2219 /* TRANSR (input) CHARACTER */
2220 /* = 'N': ARF is in Normal format; */
2221 /* = 'T': ARF is in Transpose format; */
2222
2223 /* UPLO (input) CHARACTER */
2224 /* = 'U': A is upper triangular; */
2225 /* = 'L': A is lower triangular. */
2226
2227 /* N (input) INTEGER */
2228 /* The order of the matrix A. N >= 0. */
2229
2230 /* ARF (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), */
2231 /* On entry, the upper or lower triangular matrix A stored in */
2232 /* RFP format. For a further discussion see Notes below. */
2233
2234 /* AP (output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), */
2235 /* On exit, the upper or lower triangular matrix A, packed */
2236 /* columnwise in a linear array. The j-th column of A is stored */
2237 /* in the array AP as follows: */
2238 /* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
2239 /* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
2240
2241 /* INFO (output) INTEGER */
2242 /* = 0: successful exit */
2243 /* < 0: if INFO = -i, the i-th argument had an illegal value */
2244
2245 /* Notes */
2246 /* ===== */
2247
2248 /* We first consider Rectangular Full Packed (RFP) Format when N is */
2249 /* even. We give an example where N = 6. */
2250
2251 /* AP is Upper AP is Lower */
2252
2253 /* 00 01 02 03 04 05 00 */
2254 /* 11 12 13 14 15 10 11 */
2255 /* 22 23 24 25 20 21 22 */
2256 /* 33 34 35 30 31 32 33 */
2257 /* 44 45 40 41 42 43 44 */
2258 /* 55 50 51 52 53 54 55 */
2259
2260
2261 /* Let TRANSR = 'N'. RFP holds AP as follows: */
2262 /* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
2263 /* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
2264 /* the transpose of the first three columns of AP upper. */
2265 /* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
2266 /* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
2267 /* the transpose of the last three columns of AP lower. */
2268 /* This covers the case N even and TRANSR = 'N'. */
2269
2270 /* RFP A RFP A */
2271
2272 /* 03 04 05 33 43 53 */
2273 /* 13 14 15 00 44 54 */
2274 /* 23 24 25 10 11 55 */
2275 /* 33 34 35 20 21 22 */
2276 /* 00 44 45 30 31 32 */
2277 /* 01 11 55 40 41 42 */
2278 /* 02 12 22 50 51 52 */
2279
2280 /* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
2281 /* transpose of RFP A above. One therefore gets: */
2282
2283
2284 /* RFP A RFP A */
2285
2286 /* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
2287 /* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
2288 /* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
2289
2290
2291 /* We first consider Rectangular Full Packed (RFP) Format when N is */
2292 /* odd. We give an example where N = 5. */
2293
2294 /* AP is Upper AP is Lower */
2295
2296 /* 00 01 02 03 04 00 */
2297 /* 11 12 13 14 10 11 */
2298 /* 22 23 24 20 21 22 */
2299 /* 33 34 30 31 32 33 */
2300 /* 44 40 41 42 43 44 */
2301
2302
2303 /* Let TRANSR = 'N'. RFP holds AP as follows: */
2304 /* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
2305 /* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
2306 /* the transpose of the first two columns of AP upper. */
2307 /* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
2308 /* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
2309 /* the transpose of the last two columns of AP lower. */
2310 /* This covers the case N odd and TRANSR = 'N'. */
2311
2312 /* RFP A RFP A */
2313
2314 /* 02 03 04 00 33 43 */
2315 /* 12 13 14 10 11 44 */
2316 /* 22 23 24 20 21 22 */
2317 /* 00 33 34 30 31 32 */
2318 /* 01 11 44 40 41 42 */
2319
2320 /* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
2321 /* transpose of RFP A above. One therefore gets: */
2322
2323 /* RFP A RFP A */
2324
2325 /* 02 12 22 00 01 00 10 20 30 40 50 */
2326 /* 03 13 23 33 11 33 11 21 31 41 51 */
2327 /* 04 14 24 34 44 43 44 22 32 42 52 */
2328
2329 /* ===================================================================== */
2330
2331 /* .. Parameters .. */
2332 /* .. */
2333 /* .. Local Scalars .. */
2334 /* .. */
2335 /* .. External Functions .. */
2336 /* .. */
2337 /* .. External Subroutines .. */
2338 /* .. */
2339 /* .. Executable Statements .. */
2340
2341 /* Test the input parameters. */
2342
2343 *info = 0;
2344 normaltransr = lsame_(transr, "N");
2345 lower = lsame_(uplo, "L");
2346 if (! normaltransr && ! lsame_(transr, "T")) {
2347 *info = -1;
2348 } else if (! lower && ! lsame_(uplo, "U")) {
2349 *info = -2;
2350 } else if (*n < 0) {
2351 *info = -3;
2352 }
2353 if (*info != 0) {
2354 i__1 = -(*info);
2355 xerbla_("DTFTTP", &i__1);
2356 return 0;
2357 }
2358
2359 /* Quick return if possible */
2360
2361 if (*n == 0) {
2362 return 0;
2363 }
2364
2365 if (*n == 1) {
2366 if (normaltransr) {
2367 ap[0] = arf[0];
2368 } else {
2369 ap[0] = arf[0];
2370 }
2371 return 0;
2372 }
2373
2374 /* Size of array ARF(0:NT-1) */
2375
2376 // nt = *n * (*n + 1) / 2;
2377
2378 /* Set N1 and N2 depending on LOWER */
2379
2380 if (lower) {
2381 n2 = *n / 2;
2382 n1 = *n - n2;
2383 } else {
2384 n1 = *n / 2;
2385 n2 = *n - n1;
2386 }
2387
2388 /* If N is odd, set NISODD = .TRUE. */
2389 /* If N is even, set K = N/2 and NISODD = .FALSE. */
2390
2391 /* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) */
2392 /* where noe = 0 if n is even, noe = 1 if n is odd */
2393
2394 if (*n % 2 == 0) {
2395 k = *n / 2;
2396 nisodd = false;
2397 lda = *n + 1;
2398 } else {
2399 nisodd = true;
2400 lda = *n;
2401 }
2402
2403 /* ARF^C has lda rows and n+1-noe cols */
2404
2405 if (! normaltransr) {
2406 lda = (*n + 1) / 2;
2407 }
2408
2409 /* start execution: there are eight cases */
2410
2411 if (nisodd) {
2412
2413 /* N is odd */
2414
2415 if (normaltransr) {
2416
2417 /* N is odd and TRANSR = 'N' */
2418
2419 if (lower) {
2420
2421 /* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */
2422 /* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */
2423 /* T1 -> a(0), T2 -> a(n), S -> a(n1); lda = n */
2424
2425 ijp = 0;
2426 jp = 0;
2427 i__1 = n2;
2428 for (j = 0; j <= i__1; ++j) {
2429 i__2 = *n - 1;
2430 for (i__ = j; i__ <= i__2; ++i__) {
2431 ij = i__ + jp;
2432 ap[ijp] = arf[ij];
2433 ++ijp;
2434 }
2435 jp += lda;
2436 }
2437 i__1 = n2 - 1;
2438 for (i__ = 0; i__ <= i__1; ++i__) {
2439 i__2 = n2;
2440 for (j = i__ + 1; j <= i__2; ++j) {
2441 ij = i__ + j * lda;
2442 ap[ijp] = arf[ij];
2443 ++ijp;
2444 }
2445 }
2446
2447 } else {
2448
2449 /* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */
2450 /* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */
2451 /* T1 -> a(n2), T2 -> a(n1), S -> a(0) */
2452
2453 ijp = 0;
2454 i__1 = n1 - 1;
2455 for (j = 0; j <= i__1; ++j) {
2456 ij = n2 + j;
2457 i__2 = j;
2458 for (i__ = 0; i__ <= i__2; ++i__) {
2459 ap[ijp] = arf[ij];
2460 ++ijp;
2461 ij += lda;
2462 }
2463 }
2464 js = 0;
2465 i__1 = *n - 1;
2466 for (j = n1; j <= i__1; ++j) {
2467 ij = js;
2468 i__2 = js + j;
2469 for (ij = js; ij <= i__2; ++ij) {
2470 ap[ijp] = arf[ij];
2471 ++ijp;
2472 }
2473 js += lda;
2474 }
2475
2476 }
2477
2478 } else {
2479
2480 /* N is odd and TRANSR = 'T' */
2481
2482 if (lower) {
2483
2484 /* SRPA for LOWER, TRANSPOSE and N is odd */
2485 /* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) */
2486 /* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 */
2487
2488 ijp = 0;
2489 i__1 = n2;
2490 for (i__ = 0; i__ <= i__1; ++i__) {
2491 i__2 = *n * lda - 1;
2492 i__3 = lda;
2493 for (ij = i__ * (lda + 1); i__3 < 0 ? ij >= i__2 : ij <= i__2; ij += i__3) {
2494 ap[ijp] = arf[ij];
2495 ++ijp;
2496 }
2497 }
2498 js = 1;
2499 i__1 = n2 - 1;
2500 for (j = 0; j <= i__1; ++j) {
2501 i__3 = js + n2 - j - 1;
2502 for (ij = js; ij <= i__3; ++ij) {
2503 ap[ijp] = arf[ij];
2504 ++ijp;
2505 }
2506 js = js + lda + 1;
2507 }
2508
2509 } else {
2510
2511 /* SRPA for UPPER, TRANSPOSE and N is odd */
2512 /* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) */
2513 /* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 */
2514
2515 ijp = 0;
2516 js = n2 * lda;
2517 i__1 = n1 - 1;
2518 for (j = 0; j <= i__1; ++j) {
2519 i__3 = js + j;
2520 for (ij = js; ij <= i__3; ++ij) {
2521 ap[ijp] = arf[ij];
2522 ++ijp;
2523 }
2524 js += lda;
2525 }
2526 i__1 = n1;
2527 for (i__ = 0; i__ <= i__1; ++i__) {
2528 i__3 = i__ + (n1 + i__) * lda;
2529 i__2 = lda;
2530 for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij += i__2) {
2531 ap[ijp] = arf[ij];
2532 ++ijp;
2533 }
2534 }
2535
2536 }
2537
2538 }
2539
2540 } else {
2541
2542 /* N is even */
2543
2544 if (normaltransr) {
2545
2546 /* N is even and TRANSR = 'N' */
2547
2548 if (lower) {
2549
2550 /* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
2551 /* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */
2552 /* T1 -> a(1), T2 -> a(0), S -> a(k+1) */
2553
2554 ijp = 0;
2555 jp = 0;
2556 i__1 = k - 1;
2557 for (j = 0; j <= i__1; ++j) {
2558 i__2 = *n - 1;
2559 for (i__ = j; i__ <= i__2; ++i__) {
2560 ij = i__ + 1 + jp;
2561 ap[ijp] = arf[ij];
2562 ++ijp;
2563 }
2564 jp += lda;
2565 }
2566 i__1 = k - 1;
2567 for (i__ = 0; i__ <= i__1; ++i__) {
2568 i__2 = k - 1;
2569 for (j = i__; j <= i__2; ++j) {
2570 ij = i__ + j * lda;
2571 ap[ijp] = arf[ij];
2572 ++ijp;
2573 }
2574 }
2575
2576 } else {
2577
2578 /* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
2579 /* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */
2580 /* T1 -> a(k+1), T2 -> a(k), S -> a(0) */
2581
2582 ijp = 0;
2583 i__1 = k - 1;
2584 for (j = 0; j <= i__1; ++j) {
2585 ij = k + 1 + j;
2586 i__2 = j;
2587 for (i__ = 0; i__ <= i__2; ++i__) {
2588 ap[ijp] = arf[ij];
2589 ++ijp;
2590 ij += lda;
2591 }
2592 }
2593 js = 0;
2594 i__1 = *n - 1;
2595 for (j = k; j <= i__1; ++j) {
2596 ij = js;
2597 i__2 = js + j;
2598 for (ij = js; ij <= i__2; ++ij) {
2599 ap[ijp] = arf[ij];
2600 ++ijp;
2601 }
2602 js += lda;
2603 }
2604
2605 }
2606
2607 } else {
2608
2609 /* N is even and TRANSR = 'T' */
2610
2611 if (lower) {
2612
2613 /* SRPA for LOWER, TRANSPOSE and N is even (see paper) */
2614 /* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) */
2615 /* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */
2616
2617 ijp = 0;
2618 i__1 = k - 1;
2619 for (i__ = 0; i__ <= i__1; ++i__) {
2620 i__2 = (*n + 1) * lda - 1;
2621 i__3 = lda;
2622 for (ij = i__ + (i__ + 1) * lda; i__3 < 0 ? ij >= i__2 : ij <= i__2; ij += i__3) {
2623 ap[ijp] = arf[ij];
2624 ++ijp;
2625 }
2626 }
2627 js = 0;
2628 i__1 = k - 1;
2629 for (j = 0; j <= i__1; ++j) {
2630 i__3 = js + k - j - 1;
2631 for (ij = js; ij <= i__3; ++ij) {
2632 ap[ijp] = arf[ij];
2633 ++ijp;
2634 }
2635 js = js + lda + 1;
2636 }
2637
2638 } else {
2639
2640 /* SRPA for UPPER, TRANSPOSE and N is even (see paper) */
2641 /* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) */
2642 /* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */
2643
2644 ijp = 0;
2645 js = (k + 1) * lda;
2646 i__1 = k - 1;
2647 for (j = 0; j <= i__1; ++j) {
2648 i__3 = js + j;
2649 for (ij = js; ij <= i__3; ++ij) {
2650 ap[ijp] = arf[ij];
2651 ++ijp;
2652 }
2653 js += lda;
2654 }
2655 i__1 = k - 1;
2656 for (i__ = 0; i__ <= i__1; ++i__) {
2657 i__3 = i__ + (k + i__) * lda;
2658 i__2 = lda;
2659 for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij += i__2) {
2660 ap[ijp] = arf[ij];
2661 ++ijp;
2662 }
2663 }
2664
2665 }
2666
2667 }
2668
2669 }
2670
2671 return 0;
2672
2673 /* End of DTFTTP */
2674
2675 } /* dtfttp_ */
2676
dtfttr_(const char * transr,const char * uplo,integer * n,double * arf,double * a,integer * lda,integer * info)2677 int dtfttr_(const char *transr, const char *uplo, integer *n, double *arf, double *a, integer *lda, integer *info)
2678 {
2679 /* System generated locals */
2680 integer a_dim1, a_offset, i__1, i__2;
2681
2682 /* Local variables */
2683 integer i__, j, k, l, n1, n2, ij, nt, nx2, np1x2;
2684 bool normaltransr, lower, nisodd;
2685
2686
2687 /* -- LAPACK routine (version 3.2) -- */
2688
2689 /* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
2690 /* -- November 2008 -- */
2691
2692 /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
2693 /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
2694
2695 /* .. Scalar Arguments .. */
2696 /* .. */
2697 /* .. Array Arguments .. */
2698 /* .. */
2699
2700 /* Purpose */
2701 /* ======= */
2702
2703 /* DTFTTR copies a triangular matrix A from rectangular full packed */
2704 /* format (TF) to standard full format (TR). */
2705
2706 /* Arguments */
2707 /* ========= */
2708
2709 /* TRANSR (input) CHARACTER */
2710 /* = 'N': ARF is in Normal format; */
2711 /* = 'T': ARF is in Transpose format. */
2712
2713 /* UPLO (input) CHARACTER */
2714 /* = 'U': A is upper triangular; */
2715 /* = 'L': A is lower triangular. */
2716
2717 /* N (input) INTEGER */
2718 /* The order of the matrices ARF and A. N >= 0. */
2719
2720 /* ARF (input) DOUBLE PRECISION array, dimension (N*(N+1)/2). */
2721 /* On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L') */
2722 /* matrix A in RFP format. See the "Notes" below for more */
2723 /* details. */
2724
2725 /* A (output) DOUBLE PRECISION array, dimension (LDA,N) */
2726 /* On exit, the triangular matrix A. If UPLO = 'U', the */
2727 /* leading N-by-N upper triangular part of the array A contains */
2728 /* the upper triangular matrix, and the strictly lower */
2729 /* triangular part of A is not referenced. If UPLO = 'L', the */
2730 /* leading N-by-N lower triangular part of the array A contains */
2731 /* the lower triangular matrix, and the strictly upper */
2732 /* triangular part of A is not referenced. */
2733
2734 /* LDA (input) INTEGER */
2735 /* The leading dimension of the array A. LDA >= max(1,N). */
2736
2737 /* INFO (output) INTEGER */
2738 /* = 0: successful exit */
2739 /* < 0: if INFO = -i, the i-th argument had an illegal value */
2740
2741 /* Notes */
2742 /* ===== */
2743
2744 /* We first consider Rectangular Full Packed (RFP) Format when N is */
2745 /* even. We give an example where N = 6. */
2746
2747 /* AP is Upper AP is Lower */
2748
2749 /* 00 01 02 03 04 05 00 */
2750 /* 11 12 13 14 15 10 11 */
2751 /* 22 23 24 25 20 21 22 */
2752 /* 33 34 35 30 31 32 33 */
2753 /* 44 45 40 41 42 43 44 */
2754 /* 55 50 51 52 53 54 55 */
2755
2756
2757 /* Let TRANSR = 'N'. RFP holds AP as follows: */
2758 /* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
2759 /* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
2760 /* the transpose of the first three columns of AP upper. */
2761 /* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
2762 /* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
2763 /* the transpose of the last three columns of AP lower. */
2764 /* This covers the case N even and TRANSR = 'N'. */
2765
2766 /* RFP A RFP A */
2767
2768 /* 03 04 05 33 43 53 */
2769 /* 13 14 15 00 44 54 */
2770 /* 23 24 25 10 11 55 */
2771 /* 33 34 35 20 21 22 */
2772 /* 00 44 45 30 31 32 */
2773 /* 01 11 55 40 41 42 */
2774 /* 02 12 22 50 51 52 */
2775
2776 /* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
2777 /* transpose of RFP A above. One therefore gets: */
2778
2779
2780 /* RFP A RFP A */
2781
2782 /* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
2783 /* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
2784 /* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
2785
2786
2787 /* We first consider Rectangular Full Packed (RFP) Format when N is */
2788 /* odd. We give an example where N = 5. */
2789
2790 /* AP is Upper AP is Lower */
2791
2792 /* 00 01 02 03 04 00 */
2793 /* 11 12 13 14 10 11 */
2794 /* 22 23 24 20 21 22 */
2795 /* 33 34 30 31 32 33 */
2796 /* 44 40 41 42 43 44 */
2797
2798
2799 /* Let TRANSR = 'N'. RFP holds AP as follows: */
2800 /* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
2801 /* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
2802 /* the transpose of the first two columns of AP upper. */
2803 /* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
2804 /* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
2805 /* the transpose of the last two columns of AP lower. */
2806 /* This covers the case N odd and TRANSR = 'N'. */
2807
2808 /* RFP A RFP A */
2809
2810 /* 02 03 04 00 33 43 */
2811 /* 12 13 14 10 11 44 */
2812 /* 22 23 24 20 21 22 */
2813 /* 00 33 34 30 31 32 */
2814 /* 01 11 44 40 41 42 */
2815
2816 /* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
2817 /* transpose of RFP A above. One therefore gets: */
2818
2819 /* RFP A RFP A */
2820
2821 /* 02 12 22 00 01 00 10 20 30 40 50 */
2822 /* 03 13 23 33 11 33 11 21 31 41 51 */
2823 /* 04 14 24 34 44 43 44 22 32 42 52 */
2824
2825 /* Reference */
2826 /* ========= */
2827
2828 /* ===================================================================== */
2829
2830 /* .. */
2831 /* .. Local Scalars .. */
2832 /* .. */
2833 /* .. External Functions .. */
2834 /* .. */
2835 /* .. External Subroutines .. */
2836 /* .. */
2837 /* .. Intrinsic Functions .. */
2838 /* .. */
2839 /* .. Executable Statements .. */
2840
2841 /* Test the input parameters. */
2842
2843 /* Parameter adjustments */
2844 a_dim1 = *lda - 1 - 0 + 1;
2845 a_offset = 0 + a_dim1 * 0;
2846 a -= a_offset;
2847
2848 /* Function Body */
2849 *info = 0;
2850 normaltransr = lsame_(transr, "N");
2851 lower = lsame_(uplo, "L");
2852 if (! normaltransr && ! lsame_(transr, "T")) {
2853 *info = -1;
2854 } else if (! lower && ! lsame_(uplo, "U")) {
2855 *info = -2;
2856 } else if (*n < 0) {
2857 *info = -3;
2858 } else if (*lda < std::max(1_integer,*n)) {
2859 *info = -6;
2860 }
2861 if (*info != 0) {
2862 i__1 = -(*info);
2863 xerbla_("DTFTTR", &i__1);
2864 return 0;
2865 }
2866
2867 /* Quick return if possible */
2868
2869 if (*n <= 1) {
2870 if (*n == 1) {
2871 a[0] = arf[0];
2872 }
2873 return 0;
2874 }
2875
2876 /* Size of array ARF(0:nt-1) */
2877
2878 nt = *n * (*n + 1) / 2;
2879
2880 /* set N1 and N2 depending on LOWER: for N even N1=N2=K */
2881
2882 if (lower) {
2883 n2 = *n / 2;
2884 n1 = *n - n2;
2885 } else {
2886 n1 = *n / 2;
2887 n2 = *n - n1;
2888 }
2889
2890 /* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. */
2891 /* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is */
2892 /* N--by--(N+1)/2. */
2893
2894 if (*n % 2 == 0) {
2895 k = *n / 2;
2896 nisodd = false;
2897 if (! lower) {
2898 np1x2 = *n + *n + 2;
2899 }
2900 } else {
2901 nisodd = true;
2902 if (! lower) {
2903 nx2 = *n + *n;
2904 }
2905 }
2906
2907 if (nisodd) {
2908
2909 /* N is odd */
2910
2911 if (normaltransr) {
2912
2913 /* N is odd and TRANSR = 'N' */
2914
2915 if (lower) {
2916
2917 /* N is odd, TRANSR = 'N', and UPLO = 'L' */
2918
2919 ij = 0;
2920 i__1 = n2;
2921 for (j = 0; j <= i__1; ++j) {
2922 i__2 = n2 + j;
2923 for (i__ = n1; i__ <= i__2; ++i__) {
2924 a[n2 + j + i__ * a_dim1] = arf[ij];
2925 ++ij;
2926 }
2927 i__2 = *n - 1;
2928 for (i__ = j; i__ <= i__2; ++i__) {
2929 a[i__ + j * a_dim1] = arf[ij];
2930 ++ij;
2931 }
2932 }
2933
2934 } else {
2935
2936 /* N is odd, TRANSR = 'N', and UPLO = 'U' */
2937
2938 ij = nt - *n;
2939 i__1 = n1;
2940 for (j = *n - 1; j >= i__1; --j) {
2941 i__2 = j;
2942 for (i__ = 0; i__ <= i__2; ++i__) {
2943 a[i__ + j * a_dim1] = arf[ij];
2944 ++ij;
2945 }
2946 i__2 = n1 - 1;
2947 for (l = j - n1; l <= i__2; ++l) {
2948 a[j - n1 + l * a_dim1] = arf[ij];
2949 ++ij;
2950 }
2951 ij -= nx2;
2952 }
2953
2954 }
2955
2956 } else {
2957
2958 /* N is odd and TRANSR = 'T' */
2959
2960 if (lower) {
2961
2962 /* N is odd, TRANSR = 'T', and UPLO = 'L' */
2963
2964 ij = 0;
2965 i__1 = n2 - 1;
2966 for (j = 0; j <= i__1; ++j) {
2967 i__2 = j;
2968 for (i__ = 0; i__ <= i__2; ++i__) {
2969 a[j + i__ * a_dim1] = arf[ij];
2970 ++ij;
2971 }
2972 i__2 = *n - 1;
2973 for (i__ = n1 + j; i__ <= i__2; ++i__) {
2974 a[i__ + (n1 + j) * a_dim1] = arf[ij];
2975 ++ij;
2976 }
2977 }
2978 i__1 = *n - 1;
2979 for (j = n2; j <= i__1; ++j) {
2980 i__2 = n1 - 1;
2981 for (i__ = 0; i__ <= i__2; ++i__) {
2982 a[j + i__ * a_dim1] = arf[ij];
2983 ++ij;
2984 }
2985 }
2986
2987 } else {
2988
2989 /* N is odd, TRANSR = 'T', and UPLO = 'U' */
2990
2991 ij = 0;
2992 i__1 = n1;
2993 for (j = 0; j <= i__1; ++j) {
2994 i__2 = *n - 1;
2995 for (i__ = n1; i__ <= i__2; ++i__) {
2996 a[j + i__ * a_dim1] = arf[ij];
2997 ++ij;
2998 }
2999 }
3000 i__1 = n1 - 1;
3001 for (j = 0; j <= i__1; ++j) {
3002 i__2 = j;
3003 for (i__ = 0; i__ <= i__2; ++i__) {
3004 a[i__ + j * a_dim1] = arf[ij];
3005 ++ij;
3006 }
3007 i__2 = *n - 1;
3008 for (l = n2 + j; l <= i__2; ++l) {
3009 a[n2 + j + l * a_dim1] = arf[ij];
3010 ++ij;
3011 }
3012 }
3013
3014 }
3015
3016 }
3017
3018 } else {
3019
3020 /* N is even */
3021
3022 if (normaltransr) {
3023
3024 /* N is even and TRANSR = 'N' */
3025
3026 if (lower) {
3027
3028 /* N is even, TRANSR = 'N', and UPLO = 'L' */
3029
3030 ij = 0;
3031 i__1 = k - 1;
3032 for (j = 0; j <= i__1; ++j) {
3033 i__2 = k + j;
3034 for (i__ = k; i__ <= i__2; ++i__) {
3035 a[k + j + i__ * a_dim1] = arf[ij];
3036 ++ij;
3037 }
3038 i__2 = *n - 1;
3039 for (i__ = j; i__ <= i__2; ++i__) {
3040 a[i__ + j * a_dim1] = arf[ij];
3041 ++ij;
3042 }
3043 }
3044
3045 } else {
3046
3047 /* N is even, TRANSR = 'N', and UPLO = 'U' */
3048
3049 ij = nt - *n - 1;
3050 i__1 = k;
3051 for (j = *n - 1; j >= i__1; --j) {
3052 i__2 = j;
3053 for (i__ = 0; i__ <= i__2; ++i__) {
3054 a[i__ + j * a_dim1] = arf[ij];
3055 ++ij;
3056 }
3057 i__2 = k - 1;
3058 for (l = j - k; l <= i__2; ++l) {
3059 a[j - k + l * a_dim1] = arf[ij];
3060 ++ij;
3061 }
3062 ij -= np1x2;
3063 }
3064
3065 }
3066
3067 } else {
3068
3069 /* N is even and TRANSR = 'T' */
3070
3071 if (lower) {
3072
3073 /* N is even, TRANSR = 'T', and UPLO = 'L' */
3074
3075 ij = 0;
3076 j = k;
3077 i__1 = *n - 1;
3078 for (i__ = k; i__ <= i__1; ++i__) {
3079 a[i__ + j * a_dim1] = arf[ij];
3080 ++ij;
3081 }
3082 i__1 = k - 2;
3083 for (j = 0; j <= i__1; ++j) {
3084 i__2 = j;
3085 for (i__ = 0; i__ <= i__2; ++i__) {
3086 a[j + i__ * a_dim1] = arf[ij];
3087 ++ij;
3088 }
3089 i__2 = *n - 1;
3090 for (i__ = k + 1 + j; i__ <= i__2; ++i__) {
3091 a[i__ + (k + 1 + j) * a_dim1] = arf[ij];
3092 ++ij;
3093 }
3094 }
3095 i__1 = *n - 1;
3096 for (j = k - 1; j <= i__1; ++j) {
3097 i__2 = k - 1;
3098 for (i__ = 0; i__ <= i__2; ++i__) {
3099 a[j + i__ * a_dim1] = arf[ij];
3100 ++ij;
3101 }
3102 }
3103
3104 } else {
3105
3106 /* N is even, TRANSR = 'T', and UPLO = 'U' */
3107
3108 ij = 0;
3109 i__1 = k;
3110 for (j = 0; j <= i__1; ++j) {
3111 i__2 = *n - 1;
3112 for (i__ = k; i__ <= i__2; ++i__) {
3113 a[j + i__ * a_dim1] = arf[ij];
3114 ++ij;
3115 }
3116 }
3117 i__1 = k - 2;
3118 for (j = 0; j <= i__1; ++j) {
3119 i__2 = j;
3120 for (i__ = 0; i__ <= i__2; ++i__) {
3121 a[i__ + j * a_dim1] = arf[ij];
3122 ++ij;
3123 }
3124 i__2 = *n - 1;
3125 for (l = k + 1 + j; l <= i__2; ++l) {
3126 a[k + 1 + j + l * a_dim1] = arf[ij];
3127 ++ij;
3128 }
3129 }
3130 /* Note that here, on exit of the loop, J = K-1 */
3131 i__1 = j;
3132 for (i__ = 0; i__ <= i__1; ++i__) {
3133 a[i__ + j * a_dim1] = arf[ij];
3134 ++ij;
3135 }
3136
3137 }
3138
3139 }
3140
3141 }
3142
3143 return 0;
3144
3145 /* End of DTFTTR */
3146
3147 } /* dtfttr_ */
3148
dtgevc_(const char * side,const char * howmny,bool * select,integer * n,double * s,integer * lds,double * p,integer * ldp,double * vl,integer * ldvl,double * vr,integer * ldvr,integer * mm,integer * m,double * work,integer * info)3149 /* Subroutine */ int dtgevc_(const char *side, const char *howmny, bool *select,
3150 integer *n, double *s, integer *lds, double *p, integer *ldp,
3151 double *vl, integer *ldvl, double *vr, integer *ldvr, integer
3152 *mm, integer *m, double *work, integer *info)
3153 {
3154 /* Table of constant values */
3155 static bool c_true = true;
3156 static integer c__2 = 2;
3157 static double c_b34 = 1.;
3158 static integer c__1 = 1;
3159 static double c_b36 = 0.;
3160 static bool c_false = false;
3161
3162 /* System generated locals */
3163 integer p_dim1, p_offset, s_dim1, s_offset, vl_dim1, vl_offset, vr_dim1,
3164 vr_offset, i__1, i__2, i__3, i__4, i__5;
3165 double d__1, d__2, d__3, d__4, d__5, d__6;
3166
3167 /* Local variables */
3168 integer i__, j, ja, jc, je, na, im, jr, jw, nw;
3169 double big;
3170 bool lsa, lsb;
3171 double ulp, sum[4] /* was [2][2] */;
3172 integer ibeg, ieig, iend;
3173 double dmin__, temp, xmax, sump[4] /* was [2][2] */, sums[4]
3174 /* was [2][2] */;
3175 double cim2a, cim2b, cre2a, cre2b, temp2, bdiag[2], acoef, scale;
3176 bool ilall;
3177 integer iside;
3178 double sbeta;
3179 bool il2by2;
3180 integer iinfo;
3181 double small;
3182 bool compl_x; // djmw changed variable from "compl" to compl_x because the c++ compiler protested.
3183 double anorm, bnorm;
3184 bool compr;
3185 double temp2i;
3186 double temp2r;
3187 bool ilabad, ilbbad;
3188 double acoefa, bcoefa, cimaga, cimagb;
3189 bool ilback;
3190 double bcoefi, ascale, bscale, creala, crealb;
3191 double bcoefr, salfar, safmin;
3192 double xscale, bignum;
3193 bool ilcomp, ilcplx;
3194 integer ihwmny;
3195
3196
3197 /* -- LAPACK routine (version 3.1) -- */
3198 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
3199 /* November 2006 */
3200
3201 /* .. Scalar Arguments .. */
3202 /* .. */
3203 /* .. Array Arguments .. */
3204 /* .. */
3205
3206
3207 /* Purpose */
3208 /* ======= */
3209
3210 /* DTGEVC computes some or all of the right and/or left eigenvectors of */
3211 /* a pair of real matrices (S,P), where S is a quasi-triangular matrix */
3212 /* and P is upper triangular. Matrix pairs of this type are produced by */
3213 /* the generalized Schur factorization of a matrix pair (A,B): */
3214
3215 /* A = Q*S*Z**T, B = Q*P*Z**T */
3216
3217 /* as computed by DGGHRD + DHGEQZ. */
3218
3219 /* The right eigenvector x and the left eigenvector y of (S,P) */
3220 /* corresponding to an eigenvalue w are defined by: */
3221
3222 /* S*x = w*P*x, (y**H)*S = w*(y**H)*P, */
3223
3224 /* where y**H denotes the conjugate tranpose of y. */
3225 /* The eigenvalues are not input to this routine, but are computed */
3226 /* directly from the diagonal blocks of S and P. */
3227
3228 /* This routine returns the matrices X and/or Y of right and left */
3229 /* eigenvectors of (S,P), or the products Z*X and/or Q*Y, */
3230 /* where Z and Q are input matrices. */
3231 /* If Q and Z are the orthogonal factors from the generalized Schur */
3232 /* factorization of a matrix pair (A,B), then Z*X and Q*Y */
3233 /* are the matrices of right and left eigenvectors of (A,B). */
3234
3235 /* Arguments */
3236 /* ========= */
3237
3238 /* SIDE (input) CHARACTER*1 */
3239 /* = 'R': compute right eigenvectors only; */
3240 /* = 'L': compute left eigenvectors only; */
3241 /* = 'B': compute both right and left eigenvectors. */
3242
3243 /* HOWMNY (input) CHARACTER*1 */
3244 /* = 'A': compute all right and/or left eigenvectors; */
3245 /* = 'B': compute all right and/or left eigenvectors, */
3246 /* backtransformed by the matrices in VR and/or VL; */
3247 /* = 'S': compute selected right and/or left eigenvectors, */
3248 /* specified by the bool array SELECT. */
3249
3250 /* SELECT (input) LOGICAL array, dimension (N) */
3251 /* If HOWMNY='S', SELECT specifies the eigenvectors to be */
3252 /* computed. If w(j) is a real eigenvalue, the corresponding */
3253 /* real eigenvector is computed if SELECT(j) is .TRUE.. */
3254 /* If w(j) and w(j+1) are the real and imaginary parts of a */
3255 /* complex eigenvalue, the corresponding complex eigenvector */
3256 /* is computed if either SELECT(j) or SELECT(j+1) is .TRUE., */
3257 /* and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is */
3258 /* set to .FALSE.. */
3259 /* Not referenced if HOWMNY = 'A' or 'B'. */
3260
3261 /* N (input) INTEGER */
3262 /* The order of the matrices S and P. N >= 0. */
3263
3264 /* S (input) DOUBLE PRECISION array, dimension (LDS,N) */
3265 /* The upper quasi-triangular matrix S from a generalized Schur */
3266 /* factorization, as computed by DHGEQZ. */
3267
3268 /* LDS (input) INTEGER */
3269 /* The leading dimension of array S. LDS >= max(1,N). */
3270
3271 /* P (input) DOUBLE PRECISION array, dimension (LDP,N) */
3272 /* The upper triangular matrix P from a generalized Schur */
3273 /* factorization, as computed by DHGEQZ. */
3274 /* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks */
3275 /* of S must be in positive diagonal form. */
3276
3277 /* LDP (input) INTEGER */
3278 /* The leading dimension of array P. LDP >= max(1,N). */
3279
3280 /* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM) */
3281 /* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */
3282 /* contain an N-by-N matrix Q (usually the orthogonal matrix Q */
3283 /* of left Schur vectors returned by DHGEQZ). */
3284 /* On exit, if SIDE = 'L' or 'B', VL contains: */
3285 /* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P); */
3286 /* if HOWMNY = 'B', the matrix Q*Y; */
3287 /* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by */
3288 /* SELECT, stored consecutively in the columns of */
3289 /* VL, in the same order as their eigenvalues. */
3290
3291 /* A complex eigenvector corresponding to a complex eigenvalue */
3292 /* is stored in two consecutive columns, the first holding the */
3293 /* real part, and the second the imaginary part. */
3294
3295 /* Not referenced if SIDE = 'R'. */
3296
3297 /* LDVL (input) INTEGER */
3298 /* The leading dimension of array VL. LDVL >= 1, and if */
3299 /* SIDE = 'L' or 'B', LDVL >= N. */
3300
3301 /* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM) */
3302 /* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */
3303 /* contain an N-by-N matrix Z (usually the orthogonal matrix Z */
3304 /* of right Schur vectors returned by DHGEQZ). */
3305
3306 /* On exit, if SIDE = 'R' or 'B', VR contains: */
3307 /* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P); */
3308 /* if HOWMNY = 'B' or 'b', the matrix Z*X; */
3309 /* if HOWMNY = 'S' or 's', the right eigenvectors of (S,P) */
3310 /* specified by SELECT, stored consecutively in the */
3311 /* columns of VR, in the same order as their */
3312 /* eigenvalues. */
3313
3314 /* A complex eigenvector corresponding to a complex eigenvalue */
3315 /* is stored in two consecutive columns, the first holding the */
3316 /* real part and the second the imaginary part. */
3317
3318 /* Not referenced if SIDE = 'L'. */
3319
3320 /* LDVR (input) INTEGER */
3321 /* The leading dimension of the array VR. LDVR >= 1, and if */
3322 /* SIDE = 'R' or 'B', LDVR >= N. */
3323
3324 /* MM (input) INTEGER */
3325 /* The number of columns in the arrays VL and/or VR. MM >= M. */
3326
3327 /* M (output) INTEGER */
3328 /* The number of columns in the arrays VL and/or VR actually */
3329 /* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M */
3330 /* is set to N. Each selected real eigenvector occupies one */
3331 /* column and each selected complex eigenvector occupies two */
3332 /* columns. */
3333
3334 /* WORK (workspace) DOUBLE PRECISION array, dimension (6*N) */
3335
3336 /* INFO (output) INTEGER */
3337 /* = 0: successful exit. */
3338 /* < 0: if INFO = -i, the i-th argument had an illegal value. */
3339 /* > 0: the 2-by-2 block (INFO:INFO+1) does not have a complex */
3340 /* eigenvalue. */
3341
3342 /* Further Details */
3343 /* =============== */
3344
3345 /* Allocation of workspace: */
3346 /* ---------- -- --------- */
3347
3348 /* WORK( j ) = 1-norm of j-th column of A, above the diagonal */
3349 /* WORK( N+j ) = 1-norm of j-th column of B, above the diagonal */
3350 /* WORK( 2*N+1:3*N ) = real part of eigenvector */
3351 /* WORK( 3*N+1:4*N ) = imaginary part of eigenvector */
3352 /* WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector */
3353 /* WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector */
3354
3355 /* Rowwise vs. columnwise solution methods: */
3356 /* ------- -- ---------- -------- ------- */
3357
3358 /* Finding a generalized eigenvector consists basically of solving the */
3359 /* singular triangular system */
3360
3361 /* (A - w B) x = 0 (for right) or: (A - w B)**H y = 0 (for left) */
3362
3363 /* Consider finding the i-th right eigenvector (assume all eigenvalues */
3364 /* are real). The equation to be solved is: */
3365 /* n i */
3366 /* 0 = sum C(j,k) v(k) = sum C(j,k) v(k) for j = i,. . .,1 */
3367 /* k=j k=j */
3368
3369 /* where C = (A - w B) (The components v(i+1:n) are 0.) */
3370
3371 /* The "rowwise" method is: */
3372
3373 /* (1) v(i) := 1 */
3374 /* for j = i-1,. . .,1: */
3375 /* i */
3376 /* (2) compute s = - sum C(j,k) v(k) and */
3377 /* k=j+1 */
3378
3379 /* (3) v(j) := s / C(j,j) */
3380
3381 /* Step 2 is sometimes called the "dot product" step, since it is an */
3382 /* inner product between the j-th row and the portion of the eigenvector */
3383 /* that has been computed so far. */
3384
3385 /* The "columnwise" method consists basically in doing the sums */
3386 /* for all the rows in parallel. As each v(j) is computed, the */
3387 /* contribution of v(j) times the j-th column of C is added to the */
3388 /* partial sums. Since FORTRAN arrays are stored columnwise, this has */
3389 /* the advantage that at each step, the elements of C that are accessed */
3390 /* are adjacent to one another, whereas with the rowwise method, the */
3391 /* elements accessed at a step are spaced LDS (and LDP) words apart. */
3392
3393 /* When finding left eigenvectors, the matrix in question is the */
3394 /* transpose of the one in storage, so the rowwise method then */
3395 /* actually accesses columns of A and B at each step, and so is the */
3396 /* preferred method. */
3397
3398 /* ===================================================================== */
3399
3400 /* .. Parameters .. */
3401 /* .. */
3402 /* .. Local Scalars .. */
3403 /* .. */
3404 /* .. Local Arrays .. */
3405 /* .. */
3406 /* .. External Functions .. */
3407 /* .. */
3408 /* .. External Subroutines .. */
3409 /* .. */
3410 /* .. Intrinsic Functions .. */
3411 /* .. */
3412 /* .. Executable Statements .. */
3413
3414 /* Decode and Test the input parameters */
3415
3416 /* Parameter adjustments */
3417 --select;
3418 s_dim1 = *lds;
3419 s_offset = 1 + s_dim1;
3420 s -= s_offset;
3421 p_dim1 = *ldp;
3422 p_offset = 1 + p_dim1;
3423 p -= p_offset;
3424 vl_dim1 = *ldvl;
3425 vl_offset = 1 + vl_dim1;
3426 vl -= vl_offset;
3427 vr_dim1 = *ldvr;
3428 vr_offset = 1 + vr_dim1;
3429 vr -= vr_offset;
3430 --work;
3431
3432 /* Function Body */
3433 if (lsame_(howmny, "A")) {
3434 ihwmny = 1;
3435 ilall = true;
3436 ilback = false;
3437 } else if (lsame_(howmny, "S")) {
3438 ihwmny = 2;
3439 ilall = false;
3440 ilback = false;
3441 } else if (lsame_(howmny, "B")) {
3442 ihwmny = 3;
3443 ilall = true;
3444 ilback = true;
3445 } else {
3446 ihwmny = -1;
3447 ilall = true;
3448 }
3449
3450 if (lsame_(side, "R")) {
3451 iside = 1;
3452 compl_x = false;
3453 compr = true;
3454 } else if (lsame_(side, "L")) {
3455 iside = 2;
3456 compl_x = true;
3457 compr = false;
3458 } else if (lsame_(side, "B")) {
3459 iside = 3;
3460 compl_x = true;
3461 compr = true;
3462 } else {
3463 iside = -1;
3464 }
3465
3466 *info = 0;
3467 if (iside < 0) {
3468 *info = -1;
3469 } else if (ihwmny < 0) {
3470 *info = -2;
3471 } else if (*n < 0) {
3472 *info = -4;
3473 } else if (*lds < std::max(1_integer,*n)) {
3474 *info = -6;
3475 } else if (*ldp < std::max(1_integer,*n)) {
3476 *info = -8;
3477 }
3478 if (*info != 0) {
3479 i__1 = -(*info);
3480 xerbla_("DTGEVC", &i__1);
3481 return 0;
3482 }
3483
3484 /* Count the number of eigenvectors to be computed */
3485
3486 if (! ilall) {
3487 im = 0;
3488 ilcplx = false;
3489 i__1 = *n;
3490 for (j = 1; j <= i__1; ++j) {
3491 if (ilcplx) {
3492 ilcplx = false;
3493 goto L10;
3494 }
3495 if (j < *n) {
3496 if (s[j + 1 + j * s_dim1] != 0.) {
3497 ilcplx = true;
3498 }
3499 }
3500 if (ilcplx) {
3501 if (select[j] || select[j + 1]) {
3502 im += 2;
3503 }
3504 } else {
3505 if (select[j]) {
3506 ++im;
3507 }
3508 }
3509 L10:
3510 ;
3511 }
3512 } else {
3513 im = *n;
3514 }
3515
3516 /* Check 2-by-2 diagonal blocks of A, B */
3517
3518 ilabad = false;
3519 ilbbad = false;
3520 i__1 = *n - 1;
3521 for (j = 1; j <= i__1; ++j) {
3522 if (s[j + 1 + j * s_dim1] != 0.) {
3523 if (p[j + j * p_dim1] == 0. || p[j + 1 + (j + 1) * p_dim1] == 0.
3524 || p[j + (j + 1) * p_dim1] != 0.) {
3525 ilbbad = true;
3526 }
3527 if (j < *n - 1) {
3528 if (s[j + 2 + (j + 1) * s_dim1] != 0.) {
3529 ilabad = true;
3530 }
3531 }
3532 }
3533 /* L20: */
3534 }
3535
3536 if (ilabad) {
3537 *info = -5;
3538 } else if (ilbbad) {
3539 *info = -7;
3540 } else if (compl_x && *ldvl < *n || *ldvl < 1) {
3541 *info = -10;
3542 } else if (compr && *ldvr < *n || *ldvr < 1) {
3543 *info = -12;
3544 } else if (*mm < im) {
3545 *info = -13;
3546 }
3547 if (*info != 0) {
3548 i__1 = -(*info);
3549 xerbla_("DTGEVC", &i__1);
3550 return 0;
3551 }
3552
3553 /* Quick return if possible */
3554
3555 *m = im;
3556 if (*n == 0) {
3557 return 0;
3558 }
3559
3560 /* Machine Constants */
3561
3562 safmin = dlamch_("Safe minimum");
3563 big = 1. / safmin;
3564 dlabad_(&safmin, &big);
3565 ulp = dlamch_("Epsilon") * dlamch_("Base");
3566 small = safmin * *n / ulp;
3567 big = 1. / small;
3568 bignum = 1. / (safmin * *n);
3569
3570 /* Compute the 1-norm of each column of the strictly upper triangular */
3571 /* part (i.e., excluding all elements belonging to the diagonal */
3572 /* blocks) of A and B to check for possible overflow in the */
3573 /* triangular solver. */
3574
3575 anorm = (d__1 = s[s_dim1 + 1], abs(d__1));
3576 if (*n > 1) {
3577 anorm += (d__1 = s[s_dim1 + 2], abs(d__1));
3578 }
3579 bnorm = (d__1 = p[p_dim1 + 1], abs(d__1));
3580 work[1] = 0.;
3581 work[*n + 1] = 0.;
3582
3583 i__1 = *n;
3584 for (j = 2; j <= i__1; ++j) {
3585 temp = 0.;
3586 temp2 = 0.;
3587 if (s[j + (j - 1) * s_dim1] == 0.) {
3588 iend = j - 1;
3589 } else {
3590 iend = j - 2;
3591 }
3592 i__2 = iend;
3593 for (i__ = 1; i__ <= i__2; ++i__) {
3594 temp += (d__1 = s[i__ + j * s_dim1], abs(d__1));
3595 temp2 += (d__1 = p[i__ + j * p_dim1], abs(d__1));
3596 /* L30: */
3597 }
3598 work[j] = temp;
3599 work[*n + j] = temp2;
3600 /* Computing MIN */
3601 i__3 = j + 1;
3602 i__2 = std::min(i__3,*n);
3603 for (i__ = iend + 1; i__ <= i__2; ++i__) {
3604 temp += (d__1 = s[i__ + j * s_dim1], abs(d__1));
3605 temp2 += (d__1 = p[i__ + j * p_dim1], abs(d__1));
3606 /* L40: */
3607 }
3608 anorm = std::max(anorm,temp);
3609 bnorm = std::max(bnorm,temp2);
3610 /* L50: */
3611 }
3612 ascale = 1. / std::max(anorm,safmin);
3613 bscale = 1. / std::max(bnorm,safmin);
3614
3615 /* Left eigenvectors */
3616
3617 if (compl_x) {
3618 ieig = 0;
3619
3620 /* Main loop over eigenvalues */
3621
3622 ilcplx = false;
3623 i__1 = *n;
3624 for (je = 1; je <= i__1; ++je) {
3625
3626 /* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or */
3627 /* (b) this would be the second of a complex pair. */
3628 /* Check for complex eigenvalue, so as to be sure of which */
3629 /* entry(-ies) of SELECT to look at. */
3630
3631 if (ilcplx) {
3632 ilcplx = false;
3633 goto L220;
3634 }
3635 nw = 1;
3636 if (je < *n) {
3637 if (s[je + 1 + je * s_dim1] != 0.) {
3638 ilcplx = true;
3639 nw = 2;
3640 }
3641 }
3642 if (ilall) {
3643 ilcomp = true;
3644 } else if (ilcplx) {
3645 ilcomp = select[je] || select[je + 1];
3646 } else {
3647 ilcomp = select[je];
3648 }
3649 if (! ilcomp) {
3650 goto L220;
3651 }
3652
3653 /* Decide if (a) singular pencil, (b) real eigenvalue, or */
3654 /* (c) complex eigenvalue. */
3655
3656 if (! ilcplx) {
3657 if ((d__1 = s[je + je * s_dim1], abs(d__1)) <= safmin && (
3658 d__2 = p[je + je * p_dim1], abs(d__2)) <= safmin) {
3659
3660 /* Singular matrix pencil -- return unit eigenvector */
3661
3662 ++ieig;
3663 i__2 = *n;
3664 for (jr = 1; jr <= i__2; ++jr) {
3665 vl[jr + ieig * vl_dim1] = 0.;
3666 /* L60: */
3667 }
3668 vl[ieig + ieig * vl_dim1] = 1.;
3669 goto L220;
3670 }
3671 }
3672
3673 /* Clear vector */
3674
3675 i__2 = nw * *n;
3676 for (jr = 1; jr <= i__2; ++jr) {
3677 work[(*n << 1) + jr] = 0.;
3678 /* L70: */
3679 }
3680 /* T */
3681 /* Compute coefficients in ( a A - b B ) y = 0 */
3682 /* a is ACOEF */
3683 /* b is BCOEFR + i*BCOEFI */
3684
3685 if (! ilcplx) {
3686
3687 /* Real eigenvalue */
3688
3689 /* Computing MAX */
3690 d__3 = (d__1 = s[je + je * s_dim1], abs(d__1)) * ascale, d__4
3691 = (d__2 = p[je + je * p_dim1], abs(d__2)) * bscale,
3692 d__3 = std::max(d__3,d__4);
3693 temp = 1. / std::max(d__3,safmin);
3694 salfar = temp * s[je + je * s_dim1] * ascale;
3695 sbeta = temp * p[je + je * p_dim1] * bscale;
3696 acoef = sbeta * ascale;
3697 bcoefr = salfar * bscale;
3698 bcoefi = 0.;
3699
3700 /* Scale to avoid underflow */
3701
3702 scale = 1.;
3703 lsa = abs(sbeta) >= safmin && abs(acoef) < small;
3704 lsb = abs(salfar) >= safmin && abs(bcoefr) < small;
3705 if (lsa) {
3706 scale = small / abs(sbeta) * std::min(anorm,big);
3707 }
3708 if (lsb) {
3709 /* Computing MAX */
3710 d__1 = scale, d__2 = small / abs(salfar) * std::min(bnorm,big);
3711 scale = std::max(d__1,d__2);
3712 }
3713 if (lsa || lsb) {
3714 /* Computing MIN */
3715 /* Computing MAX */
3716 d__3 = 1., d__4 = abs(acoef), d__3 = std::max(d__3,d__4), d__4
3717 = abs(bcoefr);
3718 d__1 = scale, d__2 = 1. / (safmin * std::max(d__3,d__4));
3719 scale = std::min(d__1,d__2);
3720 if (lsa) {
3721 acoef = ascale * (scale * sbeta);
3722 } else {
3723 acoef = scale * acoef;
3724 }
3725 if (lsb) {
3726 bcoefr = bscale * (scale * salfar);
3727 } else {
3728 bcoefr = scale * bcoefr;
3729 }
3730 }
3731 acoefa = abs(acoef);
3732 bcoefa = abs(bcoefr);
3733
3734 /* First component is 1 */
3735
3736 work[(*n << 1) + je] = 1.;
3737 xmax = 1.;
3738 } else {
3739
3740 /* Complex eigenvalue */
3741
3742 d__1 = safmin * 100.;
3743 dlag2_(&s[je + je * s_dim1], lds, &p[je + je * p_dim1], ldp, &
3744 d__1, &acoef, &temp, &bcoefr, &temp2, &bcoefi);
3745 bcoefi = -bcoefi;
3746 if (bcoefi == 0.) {
3747 *info = je;
3748 return 0;
3749 }
3750
3751 /* Scale to avoid over/underflow */
3752
3753 acoefa = abs(acoef);
3754 bcoefa = abs(bcoefr) + abs(bcoefi);
3755 scale = 1.;
3756 if (acoefa * ulp < safmin && acoefa >= safmin) {
3757 scale = safmin / ulp / acoefa;
3758 }
3759 if (bcoefa * ulp < safmin && bcoefa >= safmin) {
3760 /* Computing MAX */
3761 d__1 = scale, d__2 = safmin / ulp / bcoefa;
3762 scale = std::max(d__1,d__2);
3763 }
3764 if (safmin * acoefa > ascale) {
3765 scale = ascale / (safmin * acoefa);
3766 }
3767 if (safmin * bcoefa > bscale) {
3768 /* Computing MIN */
3769 d__1 = scale, d__2 = bscale / (safmin * bcoefa);
3770 scale = std::min(d__1,d__2);
3771 }
3772 if (scale != 1.) {
3773 acoef = scale * acoef;
3774 acoefa = abs(acoef);
3775 bcoefr = scale * bcoefr;
3776 bcoefi = scale * bcoefi;
3777 bcoefa = abs(bcoefr) + abs(bcoefi);
3778 }
3779
3780 /* Compute first two components of eigenvector */
3781
3782 temp = acoef * s[je + 1 + je * s_dim1];
3783 temp2r = acoef * s[je + je * s_dim1] - bcoefr * p[je + je *
3784 p_dim1];
3785 temp2i = -bcoefi * p[je + je * p_dim1];
3786 if (abs(temp) > abs(temp2r) + abs(temp2i)) {
3787 work[(*n << 1) + je] = 1.;
3788 work[*n * 3 + je] = 0.;
3789 work[(*n << 1) + je + 1] = -temp2r / temp;
3790 work[*n * 3 + je + 1] = -temp2i / temp;
3791 } else {
3792 work[(*n << 1) + je + 1] = 1.;
3793 work[*n * 3 + je + 1] = 0.;
3794 temp = acoef * s[je + (je + 1) * s_dim1];
3795 work[(*n << 1) + je] = (bcoefr * p[je + 1 + (je + 1) *
3796 p_dim1] - acoef * s[je + 1 + (je + 1) * s_dim1]) /
3797 temp;
3798 work[*n * 3 + je] = bcoefi * p[je + 1 + (je + 1) * p_dim1]
3799 / temp;
3800 }
3801 /* Computing MAX */
3802 d__5 = (d__1 = work[(*n << 1) + je], abs(d__1)) + (d__2 =
3803 work[*n * 3 + je], abs(d__2)), d__6 = (d__3 = work[(*
3804 n << 1) + je + 1], abs(d__3)) + (d__4 = work[*n * 3 +
3805 je + 1], abs(d__4));
3806 xmax = std::max(d__5,d__6);
3807 }
3808
3809 /* Computing MAX */
3810 d__1 = ulp * acoefa * anorm, d__2 = ulp * bcoefa * bnorm, d__1 =
3811 std::max(d__1,d__2);
3812 dmin__ = std::max(d__1,safmin);
3813
3814 /* T */
3815 /* Triangular solve of (a A - b B) y = 0 */
3816
3817 /* T */
3818 /* (rowwise in (a A - b B) , or columnwise in (a A - b B) ) */
3819
3820 il2by2 = false;
3821
3822 i__2 = *n;
3823 for (j = je + nw; j <= i__2; ++j) {
3824 if (il2by2) {
3825 il2by2 = false;
3826 goto L160;
3827 }
3828
3829 na = 1;
3830 bdiag[0] = p[j + j * p_dim1];
3831 if (j < *n) {
3832 if (s[j + 1 + j * s_dim1] != 0.) {
3833 il2by2 = true;
3834 bdiag[1] = p[j + 1 + (j + 1) * p_dim1];
3835 na = 2;
3836 }
3837 }
3838
3839 /* Check whether scaling is necessary for dot products */
3840
3841 xscale = 1. / std::max(1.,xmax);
3842 /* Computing MAX */
3843 d__1 = work[j], d__2 = work[*n + j], d__1 = std::max(d__1,d__2),
3844 d__2 = acoefa * work[j] + bcoefa * work[*n + j];
3845 temp = std::max(d__1,d__2);
3846 if (il2by2) {
3847 /* Computing MAX */
3848 d__1 = temp, d__2 = work[j + 1], d__1 = std::max(d__1,d__2),
3849 d__2 = work[*n + j + 1], d__1 = std::max(d__1,d__2),
3850 d__2 = acoefa * work[j + 1] + bcoefa * work[*n +
3851 j + 1];
3852 temp = std::max(d__1,d__2);
3853 }
3854 if (temp > bignum * xscale) {
3855 i__3 = nw - 1;
3856 for (jw = 0; jw <= i__3; ++jw) {
3857 i__4 = j - 1;
3858 for (jr = je; jr <= i__4; ++jr) {
3859 work[(jw + 2) * *n + jr] = xscale * work[(jw + 2)
3860 * *n + jr];
3861 /* L80: */
3862 }
3863 /* L90: */
3864 }
3865 xmax *= xscale;
3866 }
3867
3868 /* Compute dot products */
3869
3870 /* j-1 */
3871 /* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k) */
3872 /* k=je */
3873
3874 /* To reduce the op count, this is done as */
3875
3876 /* _ j-1 _ j-1 */
3877 /* a*conjg( sum S(k,j)*x(k) ) - b*conjg( sum P(k,j)*x(k) ) */
3878 /* k=je k=je */
3879
3880 /* which may cause underflow problems if A or B are close */
3881 /* to underflow. (E.g., less than SMALL.) */
3882
3883
3884 /* A series of compiler directives to defeat vectorization */
3885 /* for the next loop */
3886
3887 /* $PL$ CMCHAR=' ' */
3888 /* DIR$ NEXTSCALAR */
3889 /* $DIR SCALAR */
3890 /* DIR$ NEXT SCALAR */
3891 /* VD$L NOVECTOR */
3892 /* DEC$ NOVECTOR */
3893 /* VD$ NOVECTOR */
3894 /* VDIR NOVECTOR */
3895 /* VOCL LOOP,SCALAR */
3896 /* IBM PREFER SCALAR */
3897 /* $PL$ CMCHAR='*' */
3898
3899 i__3 = nw;
3900 for (jw = 1; jw <= i__3; ++jw) {
3901
3902 /* $PL$ CMCHAR=' ' */
3903 /* DIR$ NEXTSCALAR */
3904 /* $DIR SCALAR */
3905 /* DIR$ NEXT SCALAR */
3906 /* VD$L NOVECTOR */
3907 /* DEC$ NOVECTOR */
3908 /* VD$ NOVECTOR */
3909 /* VDIR NOVECTOR */
3910 /* VOCL LOOP,SCALAR */
3911 /* IBM PREFER SCALAR */
3912 /* $PL$ CMCHAR='*' */
3913
3914 i__4 = na;
3915 for (ja = 1; ja <= i__4; ++ja) {
3916 sums[ja + (jw << 1) - 3] = 0.;
3917 sump[ja + (jw << 1) - 3] = 0.;
3918
3919 i__5 = j - 1;
3920 for (jr = je; jr <= i__5; ++jr) {
3921 sums[ja + (jw << 1) - 3] += s[jr + (j + ja - 1) *
3922 s_dim1] * work[(jw + 1) * *n + jr];
3923 sump[ja + (jw << 1) - 3] += p[jr + (j + ja - 1) *
3924 p_dim1] * work[(jw + 1) * *n + jr];
3925 /* L100: */
3926 }
3927 /* L110: */
3928 }
3929 /* L120: */
3930 }
3931
3932 /* $PL$ CMCHAR=' ' */
3933 /* DIR$ NEXTSCALAR */
3934 /* $DIR SCALAR */
3935 /* DIR$ NEXT SCALAR */
3936 /* VD$L NOVECTOR */
3937 /* DEC$ NOVECTOR */
3938 /* VD$ NOVECTOR */
3939 /* VDIR NOVECTOR */
3940 /* VOCL LOOP,SCALAR */
3941 /* IBM PREFER SCALAR */
3942 /* $PL$ CMCHAR='*' */
3943
3944 i__3 = na;
3945 for (ja = 1; ja <= i__3; ++ja) {
3946 if (ilcplx) {
3947 sum[ja - 1] = -acoef * sums[ja - 1] + bcoefr * sump[
3948 ja - 1] - bcoefi * sump[ja + 1];
3949 sum[ja + 1] = -acoef * sums[ja + 1] + bcoefr * sump[
3950 ja + 1] + bcoefi * sump[ja - 1];
3951 } else {
3952 sum[ja - 1] = -acoef * sums[ja - 1] + bcoefr * sump[
3953 ja - 1];
3954 }
3955 /* L130: */
3956 }
3957
3958 /* T */
3959 /* Solve ( a A - b B ) y = SUM(,) */
3960 /* with scaling and perturbation of the denominator */
3961
3962 dlaln2_(&c_true, &na, &nw, &dmin__, &acoef, &s[j + j * s_dim1]
3963 , lds, bdiag, &bdiag[1], sum, &c__2, &bcoefr, &bcoefi,
3964 &work[(*n << 1) + j], n, &scale, &temp, &iinfo);
3965 if (scale < 1.) {
3966 i__3 = nw - 1;
3967 for (jw = 0; jw <= i__3; ++jw) {
3968 i__4 = j - 1;
3969 for (jr = je; jr <= i__4; ++jr) {
3970 work[(jw + 2) * *n + jr] = scale * work[(jw + 2) *
3971 *n + jr];
3972 /* L140: */
3973 }
3974 /* L150: */
3975 }
3976 xmax = scale * xmax;
3977 }
3978 xmax = std::max(xmax,temp);
3979 L160:
3980 ;
3981 }
3982
3983 /* Copy eigenvector to VL, back transforming if */
3984 /* HOWMNY='B'. */
3985
3986 ++ieig;
3987 if (ilback) {
3988 i__2 = nw - 1;
3989 for (jw = 0; jw <= i__2; ++jw) {
3990 i__3 = *n + 1 - je;
3991 dgemv_("N", n, &i__3, &c_b34, &vl[je * vl_dim1 + 1], ldvl,
3992 &work[(jw + 2) * *n + je], &c__1, &c_b36, &work[(
3993 jw + 4) * *n + 1], &c__1);
3994 /* L170: */
3995 }
3996 dlacpy_(" ", n, &nw, &work[(*n << 2) + 1], n, &vl[je *
3997 vl_dim1 + 1], ldvl);
3998 ibeg = 1;
3999 } else {
4000 dlacpy_(" ", n, &nw, &work[(*n << 1) + 1], n, &vl[ieig *
4001 vl_dim1 + 1], ldvl);
4002 ibeg = je;
4003 }
4004
4005 /* Scale eigenvector */
4006
4007 xmax = 0.;
4008 if (ilcplx) {
4009 i__2 = *n;
4010 for (j = ibeg; j <= i__2; ++j) {
4011 /* Computing MAX */
4012 d__3 = xmax, d__4 = (d__1 = vl[j + ieig * vl_dim1], abs(
4013 d__1)) + (d__2 = vl[j + (ieig + 1) * vl_dim1],
4014 abs(d__2));
4015 xmax = std::max(d__3,d__4);
4016 /* L180: */
4017 }
4018 } else {
4019 i__2 = *n;
4020 for (j = ibeg; j <= i__2; ++j) {
4021 /* Computing MAX */
4022 d__2 = xmax, d__3 = (d__1 = vl[j + ieig * vl_dim1], abs(
4023 d__1));
4024 xmax = std::max(d__2,d__3);
4025 /* L190: */
4026 }
4027 }
4028
4029 if (xmax > safmin) {
4030 xscale = 1. / xmax;
4031
4032 i__2 = nw - 1;
4033 for (jw = 0; jw <= i__2; ++jw) {
4034 i__3 = *n;
4035 for (jr = ibeg; jr <= i__3; ++jr) {
4036 vl[jr + (ieig + jw) * vl_dim1] = xscale * vl[jr + (
4037 ieig + jw) * vl_dim1];
4038 /* L200: */
4039 }
4040 /* L210: */
4041 }
4042 }
4043 ieig = ieig + nw - 1;
4044
4045 L220:
4046 ;
4047 }
4048 }
4049
4050 /* Right eigenvectors */
4051
4052 if (compr) {
4053 ieig = im + 1;
4054
4055 /* Main loop over eigenvalues */
4056
4057 ilcplx = false;
4058 for (je = *n; je >= 1; --je) {
4059
4060 /* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or */
4061 /* (b) this would be the second of a complex pair. */
4062 /* Check for complex eigenvalue, so as to be sure of which */
4063 /* entry(-ies) of SELECT to look at -- if complex, SELECT(JE) */
4064 /* or SELECT(JE-1). */
4065 /* If this is a complex pair, the 2-by-2 diagonal block */
4066 /* corresponding to the eigenvalue is in rows/columns JE-1:JE */
4067
4068 if (ilcplx) {
4069 ilcplx = false;
4070 goto L500;
4071 }
4072 nw = 1;
4073 if (je > 1) {
4074 if (s[je + (je - 1) * s_dim1] != 0.) {
4075 ilcplx = true;
4076 nw = 2;
4077 }
4078 }
4079 if (ilall) {
4080 ilcomp = true;
4081 } else if (ilcplx) {
4082 ilcomp = select[je] || select[je - 1];
4083 } else {
4084 ilcomp = select[je];
4085 }
4086 if (! ilcomp) {
4087 goto L500;
4088 }
4089
4090 /* Decide if (a) singular pencil, (b) real eigenvalue, or */
4091 /* (c) complex eigenvalue. */
4092
4093 if (! ilcplx) {
4094 if ((d__1 = s[je + je * s_dim1], abs(d__1)) <= safmin && (
4095 d__2 = p[je + je * p_dim1], abs(d__2)) <= safmin) {
4096
4097 /* Singular matrix pencil -- unit eigenvector */
4098
4099 --ieig;
4100 i__1 = *n;
4101 for (jr = 1; jr <= i__1; ++jr) {
4102 vr[jr + ieig * vr_dim1] = 0.;
4103 /* L230: */
4104 }
4105 vr[ieig + ieig * vr_dim1] = 1.;
4106 goto L500;
4107 }
4108 }
4109
4110 /* Clear vector */
4111
4112 i__1 = nw - 1;
4113 for (jw = 0; jw <= i__1; ++jw) {
4114 i__2 = *n;
4115 for (jr = 1; jr <= i__2; ++jr) {
4116 work[(jw + 2) * *n + jr] = 0.;
4117 /* L240: */
4118 }
4119 /* L250: */
4120 }
4121
4122 /* Compute coefficients in ( a A - b B ) x = 0 */
4123 /* a is ACOEF */
4124 /* b is BCOEFR + i*BCOEFI */
4125
4126 if (! ilcplx) {
4127
4128 /* Real eigenvalue */
4129
4130 /* Computing MAX */
4131 d__3 = (d__1 = s[je + je * s_dim1], abs(d__1)) * ascale, d__4
4132 = (d__2 = p[je + je * p_dim1], abs(d__2)) * bscale,
4133 d__3 = std::max(d__3,d__4);
4134 temp = 1. / std::max(d__3,safmin);
4135 salfar = temp * s[je + je * s_dim1] * ascale;
4136 sbeta = temp * p[je + je * p_dim1] * bscale;
4137 acoef = sbeta * ascale;
4138 bcoefr = salfar * bscale;
4139 bcoefi = 0.;
4140
4141 /* Scale to avoid underflow */
4142
4143 scale = 1.;
4144 lsa = abs(sbeta) >= safmin && abs(acoef) < small;
4145 lsb = abs(salfar) >= safmin && abs(bcoefr) < small;
4146 if (lsa) {
4147 scale = small / abs(sbeta) * std::min(anorm,big);
4148 }
4149 if (lsb) {
4150 /* Computing MAX */
4151 d__1 = scale, d__2 = small / abs(salfar) * std::min(bnorm,big);
4152 scale = std::max(d__1,d__2);
4153 }
4154 if (lsa || lsb) {
4155 /* Computing MIN */
4156 /* Computing MAX */
4157 d__3 = 1., d__4 = abs(acoef), d__3 = std::max(d__3,d__4), d__4
4158 = abs(bcoefr);
4159 d__1 = scale, d__2 = 1. / (safmin * std::max(d__3,d__4));
4160 scale = std::min(d__1,d__2);
4161 if (lsa) {
4162 acoef = ascale * (scale * sbeta);
4163 } else {
4164 acoef = scale * acoef;
4165 }
4166 if (lsb) {
4167 bcoefr = bscale * (scale * salfar);
4168 } else {
4169 bcoefr = scale * bcoefr;
4170 }
4171 }
4172 acoefa = abs(acoef);
4173 bcoefa = abs(bcoefr);
4174
4175 /* First component is 1 */
4176
4177 work[(*n << 1) + je] = 1.;
4178 xmax = 1.;
4179
4180 /* Compute contribution from column JE of A and B to sum */
4181 /* (See "Further Details", above.) */
4182
4183 i__1 = je - 1;
4184 for (jr = 1; jr <= i__1; ++jr) {
4185 work[(*n << 1) + jr] = bcoefr * p[jr + je * p_dim1] -
4186 acoef * s[jr + je * s_dim1];
4187 /* L260: */
4188 }
4189 } else {
4190
4191 /* Complex eigenvalue */
4192
4193 d__1 = safmin * 100.;
4194 dlag2_(&s[je - 1 + (je - 1) * s_dim1], lds, &p[je - 1 + (je -
4195 1) * p_dim1], ldp, &d__1, &acoef, &temp, &bcoefr, &
4196 temp2, &bcoefi);
4197 if (bcoefi == 0.) {
4198 *info = je - 1;
4199 return 0;
4200 }
4201
4202 /* Scale to avoid over/underflow */
4203
4204 acoefa = abs(acoef);
4205 bcoefa = abs(bcoefr) + abs(bcoefi);
4206 scale = 1.;
4207 if (acoefa * ulp < safmin && acoefa >= safmin) {
4208 scale = safmin / ulp / acoefa;
4209 }
4210 if (bcoefa * ulp < safmin && bcoefa >= safmin) {
4211 /* Computing MAX */
4212 d__1 = scale, d__2 = safmin / ulp / bcoefa;
4213 scale = std::max(d__1,d__2);
4214 }
4215 if (safmin * acoefa > ascale) {
4216 scale = ascale / (safmin * acoefa);
4217 }
4218 if (safmin * bcoefa > bscale) {
4219 /* Computing MIN */
4220 d__1 = scale, d__2 = bscale / (safmin * bcoefa);
4221 scale = std::min(d__1,d__2);
4222 }
4223 if (scale != 1.) {
4224 acoef = scale * acoef;
4225 acoefa = abs(acoef);
4226 bcoefr = scale * bcoefr;
4227 bcoefi = scale * bcoefi;
4228 bcoefa = abs(bcoefr) + abs(bcoefi);
4229 }
4230
4231 /* Compute first two components of eigenvector */
4232 /* and contribution to sums */
4233
4234 temp = acoef * s[je + (je - 1) * s_dim1];
4235 temp2r = acoef * s[je + je * s_dim1] - bcoefr * p[je + je *
4236 p_dim1];
4237 temp2i = -bcoefi * p[je + je * p_dim1];
4238 if (abs(temp) >= abs(temp2r) + abs(temp2i)) {
4239 work[(*n << 1) + je] = 1.;
4240 work[*n * 3 + je] = 0.;
4241 work[(*n << 1) + je - 1] = -temp2r / temp;
4242 work[*n * 3 + je - 1] = -temp2i / temp;
4243 } else {
4244 work[(*n << 1) + je - 1] = 1.;
4245 work[*n * 3 + je - 1] = 0.;
4246 temp = acoef * s[je - 1 + je * s_dim1];
4247 work[(*n << 1) + je] = (bcoefr * p[je - 1 + (je - 1) *
4248 p_dim1] - acoef * s[je - 1 + (je - 1) * s_dim1]) /
4249 temp;
4250 work[*n * 3 + je] = bcoefi * p[je - 1 + (je - 1) * p_dim1]
4251 / temp;
4252 }
4253
4254 /* Computing MAX */
4255 d__5 = (d__1 = work[(*n << 1) + je], abs(d__1)) + (d__2 =
4256 work[*n * 3 + je], abs(d__2)), d__6 = (d__3 = work[(*
4257 n << 1) + je - 1], abs(d__3)) + (d__4 = work[*n * 3 +
4258 je - 1], abs(d__4));
4259 xmax = std::max(d__5,d__6);
4260
4261 /* Compute contribution from columns JE and JE-1 */
4262 /* of A and B to the sums. */
4263
4264 creala = acoef * work[(*n << 1) + je - 1];
4265 cimaga = acoef * work[*n * 3 + je - 1];
4266 crealb = bcoefr * work[(*n << 1) + je - 1] - bcoefi * work[*n
4267 * 3 + je - 1];
4268 cimagb = bcoefi * work[(*n << 1) + je - 1] + bcoefr * work[*n
4269 * 3 + je - 1];
4270 cre2a = acoef * work[(*n << 1) + je];
4271 cim2a = acoef * work[*n * 3 + je];
4272 cre2b = bcoefr * work[(*n << 1) + je] - bcoefi * work[*n * 3
4273 + je];
4274 cim2b = bcoefi * work[(*n << 1) + je] + bcoefr * work[*n * 3
4275 + je];
4276 i__1 = je - 2;
4277 for (jr = 1; jr <= i__1; ++jr) {
4278 work[(*n << 1) + jr] = -creala * s[jr + (je - 1) * s_dim1]
4279 + crealb * p[jr + (je - 1) * p_dim1] - cre2a * s[
4280 jr + je * s_dim1] + cre2b * p[jr + je * p_dim1];
4281 work[*n * 3 + jr] = -cimaga * s[jr + (je - 1) * s_dim1] +
4282 cimagb * p[jr + (je - 1) * p_dim1] - cim2a * s[jr
4283 + je * s_dim1] + cim2b * p[jr + je * p_dim1];
4284 /* L270: */
4285 }
4286 }
4287
4288 /* Computing MAX */
4289 d__1 = ulp * acoefa * anorm, d__2 = ulp * bcoefa * bnorm, d__1 =
4290 std::max(d__1,d__2);
4291 dmin__ = std::max(d__1,safmin);
4292
4293 /* Columnwise triangular solve of (a A - b B) x = 0 */
4294
4295 il2by2 = false;
4296 for (j = je - nw; j >= 1; --j) {
4297
4298 /* If a 2-by-2 block, is in position j-1:j, wait until */
4299 /* next iteration to process it (when it will be j:j+1) */
4300
4301 if (! il2by2 && j > 1) {
4302 if (s[j + (j - 1) * s_dim1] != 0.) {
4303 il2by2 = true;
4304 goto L370;
4305 }
4306 }
4307 bdiag[0] = p[j + j * p_dim1];
4308 if (il2by2) {
4309 na = 2;
4310 bdiag[1] = p[j + 1 + (j + 1) * p_dim1];
4311 } else {
4312 na = 1;
4313 }
4314
4315 /* Compute x(j) (and x(j+1), if 2-by-2 block) */
4316
4317 dlaln2_(&c_false, &na, &nw, &dmin__, &acoef, &s[j + j *
4318 s_dim1], lds, bdiag, &bdiag[1], &work[(*n << 1) + j],
4319 n, &bcoefr, &bcoefi, sum, &c__2, &scale, &temp, &
4320 iinfo);
4321 if (scale < 1.) {
4322
4323 i__1 = nw - 1;
4324 for (jw = 0; jw <= i__1; ++jw) {
4325 i__2 = je;
4326 for (jr = 1; jr <= i__2; ++jr) {
4327 work[(jw + 2) * *n + jr] = scale * work[(jw + 2) *
4328 *n + jr];
4329 /* L280: */
4330 }
4331 /* L290: */
4332 }
4333 }
4334 /* Computing MAX */
4335 d__1 = scale * xmax;
4336 xmax = std::max(d__1,temp);
4337
4338 i__1 = nw;
4339 for (jw = 1; jw <= i__1; ++jw) {
4340 i__2 = na;
4341 for (ja = 1; ja <= i__2; ++ja) {
4342 work[(jw + 1) * *n + j + ja - 1] = sum[ja + (jw << 1)
4343 - 3];
4344 /* L300: */
4345 }
4346 /* L310: */
4347 }
4348
4349 /* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling */
4350
4351 if (j > 1) {
4352
4353 /* Check whether scaling is necessary for sum. */
4354
4355 xscale = 1. / std::max(1.,xmax);
4356 temp = acoefa * work[j] + bcoefa * work[*n + j];
4357 if (il2by2) {
4358 /* Computing MAX */
4359 d__1 = temp, d__2 = acoefa * work[j + 1] + bcoefa *
4360 work[*n + j + 1];
4361 temp = std::max(d__1,d__2);
4362 }
4363 /* Computing MAX */
4364 d__1 = std::max(temp,acoefa);
4365 temp = std::max(d__1,bcoefa);
4366 if (temp > bignum * xscale) {
4367
4368 i__1 = nw - 1;
4369 for (jw = 0; jw <= i__1; ++jw) {
4370 i__2 = je;
4371 for (jr = 1; jr <= i__2; ++jr) {
4372 work[(jw + 2) * *n + jr] = xscale * work[(jw
4373 + 2) * *n + jr];
4374 /* L320: */
4375 }
4376 /* L330: */
4377 }
4378 xmax *= xscale;
4379 }
4380
4381 /* Compute the contributions of the off-diagonals of */
4382 /* column j (and j+1, if 2-by-2 block) of A and B to the */
4383 /* sums. */
4384
4385
4386 i__1 = na;
4387 for (ja = 1; ja <= i__1; ++ja) {
4388 if (ilcplx) {
4389 creala = acoef * work[(*n << 1) + j + ja - 1];
4390 cimaga = acoef * work[*n * 3 + j + ja - 1];
4391 crealb = bcoefr * work[(*n << 1) + j + ja - 1] -
4392 bcoefi * work[*n * 3 + j + ja - 1];
4393 cimagb = bcoefi * work[(*n << 1) + j + ja - 1] +
4394 bcoefr * work[*n * 3 + j + ja - 1];
4395 i__2 = j - 1;
4396 for (jr = 1; jr <= i__2; ++jr) {
4397 work[(*n << 1) + jr] = work[(*n << 1) + jr] -
4398 creala * s[jr + (j + ja - 1) * s_dim1]
4399 + crealb * p[jr + (j + ja - 1) *
4400 p_dim1];
4401 work[*n * 3 + jr] = work[*n * 3 + jr] -
4402 cimaga * s[jr + (j + ja - 1) * s_dim1]
4403 + cimagb * p[jr + (j + ja - 1) *
4404 p_dim1];
4405 /* L340: */
4406 }
4407 } else {
4408 creala = acoef * work[(*n << 1) + j + ja - 1];
4409 crealb = bcoefr * work[(*n << 1) + j + ja - 1];
4410 i__2 = j - 1;
4411 for (jr = 1; jr <= i__2; ++jr) {
4412 work[(*n << 1) + jr] = work[(*n << 1) + jr] -
4413 creala * s[jr + (j + ja - 1) * s_dim1]
4414 + crealb * p[jr + (j + ja - 1) *
4415 p_dim1];
4416 /* L350: */
4417 }
4418 }
4419 /* L360: */
4420 }
4421 }
4422 il2by2 = false;
4423 L370:
4424 ;
4425 }
4426
4427 /* Copy eigenvector to VR, back transforming if */
4428 /* HOWMNY='B'. */
4429
4430 ieig -= nw;
4431 if (ilback) {
4432
4433 i__1 = nw - 1;
4434 for (jw = 0; jw <= i__1; ++jw) {
4435 i__2 = *n;
4436 for (jr = 1; jr <= i__2; ++jr) {
4437 work[(jw + 4) * *n + jr] = work[(jw + 2) * *n + 1] *
4438 vr[jr + vr_dim1];
4439 /* L380: */
4440 }
4441
4442 /* A series of compiler directives to defeat */
4443 /* vectorization for the next loop */
4444
4445
4446 i__2 = je;
4447 for (jc = 2; jc <= i__2; ++jc) {
4448 i__3 = *n;
4449 for (jr = 1; jr <= i__3; ++jr) {
4450 work[(jw + 4) * *n + jr] += work[(jw + 2) * *n +
4451 jc] * vr[jr + jc * vr_dim1];
4452 /* L390: */
4453 }
4454 /* L400: */
4455 }
4456 /* L410: */
4457 }
4458
4459 i__1 = nw - 1;
4460 for (jw = 0; jw <= i__1; ++jw) {
4461 i__2 = *n;
4462 for (jr = 1; jr <= i__2; ++jr) {
4463 vr[jr + (ieig + jw) * vr_dim1] = work[(jw + 4) * *n +
4464 jr];
4465 /* L420: */
4466 }
4467 /* L430: */
4468 }
4469
4470 iend = *n;
4471 } else {
4472 i__1 = nw - 1;
4473 for (jw = 0; jw <= i__1; ++jw) {
4474 i__2 = *n;
4475 for (jr = 1; jr <= i__2; ++jr) {
4476 vr[jr + (ieig + jw) * vr_dim1] = work[(jw + 2) * *n +
4477 jr];
4478 /* L440: */
4479 }
4480 /* L450: */
4481 }
4482
4483 iend = je;
4484 }
4485
4486 /* Scale eigenvector */
4487
4488 xmax = 0.;
4489 if (ilcplx) {
4490 i__1 = iend;
4491 for (j = 1; j <= i__1; ++j) {
4492 /* Computing MAX */
4493 d__3 = xmax, d__4 = (d__1 = vr[j + ieig * vr_dim1], abs(
4494 d__1)) + (d__2 = vr[j + (ieig + 1) * vr_dim1],
4495 abs(d__2));
4496 xmax = std::max(d__3,d__4);
4497 /* L460: */
4498 }
4499 } else {
4500 i__1 = iend;
4501 for (j = 1; j <= i__1; ++j) {
4502 /* Computing MAX */
4503 d__2 = xmax, d__3 = (d__1 = vr[j + ieig * vr_dim1], abs(
4504 d__1));
4505 xmax = std::max(d__2,d__3);
4506 /* L470: */
4507 }
4508 }
4509
4510 if (xmax > safmin) {
4511 xscale = 1. / xmax;
4512 i__1 = nw - 1;
4513 for (jw = 0; jw <= i__1; ++jw) {
4514 i__2 = iend;
4515 for (jr = 1; jr <= i__2; ++jr) {
4516 vr[jr + (ieig + jw) * vr_dim1] = xscale * vr[jr + (
4517 ieig + jw) * vr_dim1];
4518 /* L480: */
4519 }
4520 /* L490: */
4521 }
4522 }
4523 L500:
4524 ;
4525 }
4526 }
4527
4528 return 0;
4529
4530 /* End of DTGEVC */
4531
4532 } /* dtgevc_ */
4533
dtgex2_(bool * wantq,bool * wantz,integer * n,double * a,integer * lda,double * b,integer * ldb,double * q,integer * ldq,double * z__,integer * ldz,integer * j1,integer * n1,integer * n2,double * work,integer * lwork,integer * info)4534 /* Subroutine */ int dtgex2_(bool *wantq, bool *wantz, integer *n,
4535 double *a, integer *lda, double *b, integer *ldb, double *
4536 q, integer *ldq, double *z__, integer *ldz, integer *j1, integer *
4537 n1, integer *n2, double *work, integer *lwork, integer *info)
4538 {
4539 /* Table of constant values */
4540 static integer c__4 = 4;
4541 static double c_b5 = 0.;
4542 static integer c__1 = 1;
4543 static integer c__2 = 2;
4544 static double c_b42 = 1.;
4545 static double c_b48 = -1.;
4546 static integer c__0 = 0;
4547
4548 /* System generated locals */
4549 integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
4550 z_offset, i__1, i__2;
4551 double d__1;
4552
4553 /* Local variables */
4554 double f, g;
4555 integer i__, m;
4556 double s[16] /* was [4][4] */, t[16] /* was [4][4] */, be[2], ai[2]
4557 , ar[2], sa, sb, li[16] /* was [4][4] */, ir[16] /*
4558 was [4][4] */, ss, ws, eps;
4559 bool weak;
4560 double ddum;
4561 integer idum;
4562 double taul[4], dsum;
4563 double taur[4], scpy[16] /* was [4][4] */, tcpy[16] /* was [4][4] */;
4564 double scale, bqra21, brqa21;
4565 double licop[16] /* was [4][4] */;
4566 integer linfo;
4567 double ircop[16] /* was [4][4] */, dnorm;
4568 integer iwork[4];
4569 double dscale;
4570 bool dtrong;
4571 double thresh, smlnum;
4572
4573
4574 /* -- LAPACK auxiliary routine (version 3.1) -- */
4575 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
4576 /* November 2006 */
4577
4578 /* .. Scalar Arguments .. */
4579 /* .. */
4580 /* .. Array Arguments .. */
4581 /* .. */
4582
4583 /* Purpose */
4584 /* ======= */
4585
4586 /* DTGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22) */
4587 /* of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair */
4588 /* (A, B) by an orthogonal equivalence transformation. */
4589
4590 /* (A, B) must be in generalized real Schur canonical form (as returned */
4591 /* by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2 */
4592 /* diagonal blocks. B is upper triangular. */
4593
4594 /* Optionally, the matrices Q and Z of generalized Schur vectors are */
4595 /* updated. */
4596
4597 /* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)' */
4598 /* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)' */
4599
4600
4601 /* Arguments */
4602 /* ========= */
4603
4604 /* WANTQ (input) LOGICAL */
4605 /* .TRUE. : update the left transformation matrix Q; */
4606 /* .FALSE.: do not update Q. */
4607
4608 /* WANTZ (input) LOGICAL */
4609 /* .TRUE. : update the right transformation matrix Z; */
4610 /* .FALSE.: do not update Z. */
4611
4612 /* N (input) INTEGER */
4613 /* The order of the matrices A and B. N >= 0. */
4614
4615 /* A (input/output) DOUBLE PRECISION arrays, dimensions (LDA,N) */
4616 /* On entry, the matrix A in the pair (A, B). */
4617 /* On exit, the updated matrix A. */
4618
4619 /* LDA (input) INTEGER */
4620 /* The leading dimension of the array A. LDA >= max(1,N). */
4621
4622 /* B (input/output) DOUBLE PRECISION arrays, dimensions (LDB,N) */
4623 /* On entry, the matrix B in the pair (A, B). */
4624 /* On exit, the updated matrix B. */
4625
4626 /* LDB (input) INTEGER */
4627 /* The leading dimension of the array B. LDB >= max(1,N). */
4628
4629 /* Q (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */
4630 /* On entry, if WANTQ = .TRUE., the orthogonal matrix Q. */
4631 /* On exit, the updated matrix Q. */
4632 /* Not referenced if WANTQ = .FALSE.. */
4633
4634 /* LDQ (input) INTEGER */
4635 /* The leading dimension of the array Q. LDQ >= 1. */
4636 /* If WANTQ = .TRUE., LDQ >= N. */
4637
4638 /* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */
4639 /* On entry, if WANTZ =.TRUE., the orthogonal matrix Z. */
4640 /* On exit, the updated matrix Z. */
4641 /* Not referenced if WANTZ = .FALSE.. */
4642
4643 /* LDZ (input) INTEGER */
4644 /* The leading dimension of the array Z. LDZ >= 1. */
4645 /* If WANTZ = .TRUE., LDZ >= N. */
4646
4647 /* J1 (input) INTEGER */
4648 /* The index to the first block (A11, B11). 1 <= J1 <= N. */
4649
4650 /* N1 (input) INTEGER */
4651 /* The order of the first block (A11, B11). N1 = 0, 1 or 2. */
4652
4653 /* N2 (input) INTEGER */
4654 /* The order of the second block (A22, B22). N2 = 0, 1 or 2. */
4655
4656 /* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)). */
4657
4658 /* LWORK (input) INTEGER */
4659 /* The dimension of the array WORK. */
4660 /* LWORK >= MAX( 1, N*(N2+N1), (N2+N1)*(N2+N1)*2 ) */
4661
4662 /* INFO (output) INTEGER */
4663 /* =0: Successful exit */
4664 /* >0: If INFO = 1, the transformed matrix (A, B) would be */
4665 /* too far from generalized Schur form; the blocks are */
4666 /* not swapped and (A, B) and (Q, Z) are unchanged. */
4667 /* The problem of swapping is too ill-conditioned. */
4668 /* <0: If INFO = -16: LWORK is too small. Appropriate value */
4669 /* for LWORK is returned in WORK(1). */
4670
4671 /* Further Details */
4672 /* =============== */
4673
4674 /* Based on contributions by */
4675 /* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
4676 /* Umea University, S-901 87 Umea, Sweden. */
4677
4678 /* In the current code both weak and strong stability tests are */
4679 /* performed. The user can omit the strong stability test by changing */
4680 /* the internal logical parameter WANDS to .FALSE.. See ref. [2] for */
4681 /* details. */
4682
4683 /* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
4684 /* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
4685 /* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
4686 /* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
4687
4688 /* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
4689 /* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
4690 /* Estimation: Theory, Algorithms and Software, */
4691 /* Report UMINF - 94.04, Department of Computing Science, Umea */
4692 /* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */
4693 /* Note 87. To appear in Numerical Algorithms, 1996. */
4694
4695 /* ===================================================================== */
4696 /* Replaced various illegal calls to DCOPY by calls to DLASET, or by DO */
4697 /* loops. Sven Hammarling, 1/5/02. */
4698
4699 /* .. Parameters .. */
4700 /* .. */
4701 /* .. Local Scalars .. */
4702 /* .. */
4703 /* .. Local Arrays .. */
4704 /* .. */
4705 /* .. External Functions .. */
4706 /* .. */
4707 /* .. External Subroutines .. */
4708 /* .. */
4709 /* .. Intrinsic Functions .. */
4710 /* .. */
4711 /* .. Executable Statements .. */
4712
4713 /* Parameter adjustments */
4714 a_dim1 = *lda;
4715 a_offset = 1 + a_dim1;
4716 a -= a_offset;
4717 b_dim1 = *ldb;
4718 b_offset = 1 + b_dim1;
4719 b -= b_offset;
4720 q_dim1 = *ldq;
4721 q_offset = 1 + q_dim1;
4722 q -= q_offset;
4723 z_dim1 = *ldz;
4724 z_offset = 1 + z_dim1;
4725 z__ -= z_offset;
4726 --work;
4727
4728 /* Function Body */
4729 *info = 0;
4730
4731 /* Quick return if possible */
4732
4733 if (*n <= 1 || *n1 <= 0 || *n2 <= 0) {
4734 return 0;
4735 }
4736 if (*n1 > *n || *j1 + *n1 > *n) {
4737 return 0;
4738 }
4739 m = *n1 + *n2;
4740 /* Computing MAX */
4741 i__1 = 1, i__2 = *n * m, i__1 = std::max(i__1,i__2), i__2 = m * m << 1;
4742 if (*lwork < std::max(i__1,i__2)) {
4743 *info = -16;
4744 /* Computing MAX */
4745 i__1 = 1, i__2 = *n * m, i__1 = std::max(i__1,i__2), i__2 = m * m << 1;
4746 work[1] = (double) std::max(i__1,i__2);
4747 return 0;
4748 }
4749
4750 weak = false;
4751 dtrong = false;
4752
4753 /* Make a local copy of selected block */
4754
4755 dlaset_("Full", &c__4, &c__4, &c_b5, &c_b5, li, &c__4);
4756 dlaset_("Full", &c__4, &c__4, &c_b5, &c_b5, ir, &c__4);
4757 dlacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, s, &c__4);
4758 dlacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, t, &c__4);
4759
4760 /* Compute threshold for testing acceptance of swapping. */
4761
4762 eps = dlamch_("P");
4763 smlnum = dlamch_("S") / eps;
4764 dscale = 0.;
4765 dsum = 1.;
4766 dlacpy_("Full", &m, &m, s, &c__4, &work[1], &m);
4767 i__1 = m * m;
4768 dlassq_(&i__1, &work[1], &c__1, &dscale, &dsum);
4769 dlacpy_("Full", &m, &m, t, &c__4, &work[1], &m);
4770 i__1 = m * m;
4771 dlassq_(&i__1, &work[1], &c__1, &dscale, &dsum);
4772 dnorm = dscale * sqrt(dsum);
4773 /* Computing MAX */
4774 d__1 = eps * 10. * dnorm;
4775 thresh = std::max(d__1,smlnum);
4776
4777 if (m == 2) {
4778
4779 /* CASE 1: Swap 1-by-1 and 1-by-1 blocks. */
4780
4781 /* Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks */
4782 /* using Givens rotations and perform the swap tentatively. */
4783
4784 f = s[5] * t[0] - t[5] * s[0];
4785 g = s[5] * t[4] - t[5] * s[4];
4786 sb = abs(t[5]);
4787 sa = abs(s[5]);
4788 dlartg_(&f, &g, &ir[4], ir, &ddum);
4789 ir[1] = -ir[4];
4790 ir[5] = ir[0];
4791 drot_(&c__2, s, &c__1, &s[4], &c__1, ir, &ir[1]);
4792 drot_(&c__2, t, &c__1, &t[4], &c__1, ir, &ir[1]);
4793 if (sa >= sb) {
4794 dlartg_(s, &s[1], li, &li[1], &ddum);
4795 } else {
4796 dlartg_(t, &t[1], li, &li[1], &ddum);
4797 }
4798 drot_(&c__2, s, &c__4, &s[1], &c__4, li, &li[1]);
4799 drot_(&c__2, t, &c__4, &t[1], &c__4, li, &li[1]);
4800 li[5] = li[0];
4801 li[4] = -li[1];
4802
4803 /* Weak stability test: */
4804 /* |S21| + |T21| <= O(EPS * F-norm((S, T))) */
4805
4806 ws = abs(s[1]) + abs(t[1]);
4807 weak = ws <= thresh;
4808 if (! weak) {
4809 goto L70;
4810 }
4811
4812 if (true) {
4813
4814 /* Strong stability test: */
4815 /* F-norm((A-QL'*S*QR, B-QL'*T*QR)) <= O(EPS*F-norm((A,B))) */
4816
4817 dlacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, &work[m * m
4818 + 1], &m);
4819 dgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, &
4820 work[1], &m);
4821 dgemm_("N", "T", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, &
4822 c_b42, &work[m * m + 1], &m);
4823 dscale = 0.;
4824 dsum = 1.;
4825 i__1 = m * m;
4826 dlassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
4827
4828 dlacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, &work[m * m
4829 + 1], &m);
4830 dgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, &
4831 work[1], &m);
4832 dgemm_("N", "T", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, &
4833 c_b42, &work[m * m + 1], &m);
4834 i__1 = m * m;
4835 dlassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
4836 ss = dscale * sqrt(dsum);
4837 dtrong = ss <= thresh;
4838 if (! dtrong) {
4839 goto L70;
4840 }
4841 }
4842
4843 /* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and */
4844 /* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */
4845
4846 i__1 = *j1 + 1;
4847 drot_(&i__1, &a[*j1 * a_dim1 + 1], &c__1, &a[(*j1 + 1) * a_dim1 + 1],
4848 &c__1, ir, &ir[1]);
4849 i__1 = *j1 + 1;
4850 drot_(&i__1, &b[*j1 * b_dim1 + 1], &c__1, &b[(*j1 + 1) * b_dim1 + 1],
4851 &c__1, ir, &ir[1]);
4852 i__1 = *n - *j1 + 1;
4853 drot_(&i__1, &a[*j1 + *j1 * a_dim1], lda, &a[*j1 + 1 + *j1 * a_dim1],
4854 lda, li, &li[1]);
4855 i__1 = *n - *j1 + 1;
4856 drot_(&i__1, &b[*j1 + *j1 * b_dim1], ldb, &b[*j1 + 1 + *j1 * b_dim1],
4857 ldb, li, &li[1]);
4858
4859 /* Set N1-by-N2 (2,1) - blocks to ZERO. */
4860
4861 a[*j1 + 1 + *j1 * a_dim1] = 0.;
4862 b[*j1 + 1 + *j1 * b_dim1] = 0.;
4863
4864 /* Accumulate transformations into Q and Z if requested. */
4865
4866 if (*wantz) {
4867 drot_(n, &z__[*j1 * z_dim1 + 1], &c__1, &z__[(*j1 + 1) * z_dim1 +
4868 1], &c__1, ir, &ir[1]);
4869 }
4870 if (*wantq) {
4871 drot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[(*j1 + 1) * q_dim1 + 1],
4872 &c__1, li, &li[1]);
4873 }
4874
4875 /* Exit with INFO = 0 if swap was successfully performed. */
4876
4877 return 0;
4878
4879 } else {
4880
4881 /* CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2 */
4882 /* and 2-by-2 blocks. */
4883
4884 /* Solve the generalized Sylvester equation */
4885 /* S11 * R - L * S22 = SCALE * S12 */
4886 /* T11 * R - L * T22 = SCALE * T12 */
4887 /* for R and L. Solutions in LI and IR. */
4888
4889 dlacpy_("Full", n1, n2, &t[(*n1 + 1 << 2) - 4], &c__4, li, &c__4);
4890 dlacpy_("Full", n1, n2, &s[(*n1 + 1 << 2) - 4], &c__4, &ir[*n2 + 1 + (
4891 *n1 + 1 << 2) - 5], &c__4);
4892 dtgsy2_("N", &c__0, n1, n2, s, &c__4, &s[*n1 + 1 + (*n1 + 1 << 2) - 5]
4893 , &c__4, &ir[*n2 + 1 + (*n1 + 1 << 2) - 5], &c__4, t, &c__4, &
4894 t[*n1 + 1 + (*n1 + 1 << 2) - 5], &c__4, li, &c__4, &scale, &
4895 dsum, &dscale, iwork, &idum, &linfo);
4896
4897 /* Compute orthogonal matrix QL: */
4898
4899 /* QL' * LI = [ TL ] */
4900 /* [ 0 ] */
4901 /* where */
4902 /* LI = [ -L ] */
4903 /* [ SCALE * identity(N2) ] */
4904
4905 i__1 = *n2;
4906 for (i__ = 1; i__ <= i__1; ++i__) {
4907 dscal_(n1, &c_b48, &li[(i__ << 2) - 4], &c__1);
4908 li[*n1 + i__ + (i__ << 2) - 5] = scale;
4909 /* L10: */
4910 }
4911 dgeqr2_(&m, n2, li, &c__4, taul, &work[1], &linfo);
4912 if (linfo != 0) {
4913 goto L70;
4914 }
4915 dorg2r_(&m, &m, n2, li, &c__4, taul, &work[1], &linfo);
4916 if (linfo != 0) {
4917 goto L70;
4918 }
4919
4920 /* Compute orthogonal matrix RQ: */
4921
4922 /* IR * RQ' = [ 0 TR], */
4923
4924 /* where IR = [ SCALE * identity(N1), R ] */
4925
4926 i__1 = *n1;
4927 for (i__ = 1; i__ <= i__1; ++i__) {
4928 ir[*n2 + i__ + (i__ << 2) - 5] = scale;
4929 /* L20: */
4930 }
4931 dgerq2_(n1, &m, &ir[*n2], &c__4, taur, &work[1], &linfo);
4932 if (linfo != 0) {
4933 goto L70;
4934 }
4935 dorgr2_(&m, &m, n1, ir, &c__4, taur, &work[1], &linfo);
4936 if (linfo != 0) {
4937 goto L70;
4938 }
4939
4940 /* Perform the swapping tentatively: */
4941
4942 dgemm_("T", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, &
4943 work[1], &m);
4944 dgemm_("N", "T", &m, &m, &m, &c_b42, &work[1], &m, ir, &c__4, &c_b5,
4945 s, &c__4);
4946 dgemm_("T", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, &
4947 work[1], &m);
4948 dgemm_("N", "T", &m, &m, &m, &c_b42, &work[1], &m, ir, &c__4, &c_b5,
4949 t, &c__4);
4950 dlacpy_("F", &m, &m, s, &c__4, scpy, &c__4);
4951 dlacpy_("F", &m, &m, t, &c__4, tcpy, &c__4);
4952 dlacpy_("F", &m, &m, ir, &c__4, ircop, &c__4);
4953 dlacpy_("F", &m, &m, li, &c__4, licop, &c__4);
4954
4955 /* Triangularize the B-part by an RQ factorization. */
4956 /* Apply transformation (from left) to A-part, giving S. */
4957
4958 dgerq2_(&m, &m, t, &c__4, taur, &work[1], &linfo);
4959 if (linfo != 0) {
4960 goto L70;
4961 }
4962 dormr2_("R", "T", &m, &m, &m, t, &c__4, taur, s, &c__4, &work[1], &
4963 linfo);
4964 if (linfo != 0) {
4965 goto L70;
4966 }
4967 dormr2_("L", "N", &m, &m, &m, t, &c__4, taur, ir, &c__4, &work[1], &
4968 linfo);
4969 if (linfo != 0) {
4970 goto L70;
4971 }
4972
4973 /* Compute F-norm(S21) in BRQA21. (T21 is 0.) */
4974
4975 dscale = 0.;
4976 dsum = 1.;
4977 i__1 = *n2;
4978 for (i__ = 1; i__ <= i__1; ++i__) {
4979 dlassq_(n1, &s[*n2 + 1 + (i__ << 2) - 5], &c__1, &dscale, &dsum);
4980 /* L30: */
4981 }
4982 brqa21 = dscale * sqrt(dsum);
4983
4984 /* Triangularize the B-part by a QR factorization. */
4985 /* Apply transformation (from right) to A-part, giving S. */
4986
4987 dgeqr2_(&m, &m, tcpy, &c__4, taul, &work[1], &linfo);
4988 if (linfo != 0) {
4989 goto L70;
4990 }
4991 dorm2r_("L", "T", &m, &m, &m, tcpy, &c__4, taul, scpy, &c__4, &work[1]
4992 , info);
4993 dorm2r_("R", "N", &m, &m, &m, tcpy, &c__4, taul, licop, &c__4, &work[
4994 1], info);
4995 if (linfo != 0) {
4996 goto L70;
4997 }
4998
4999 /* Compute F-norm(S21) in BQRA21. (T21 is 0.) */
5000
5001 dscale = 0.;
5002 dsum = 1.;
5003 i__1 = *n2;
5004 for (i__ = 1; i__ <= i__1; ++i__) {
5005 dlassq_(n1, &scpy[*n2 + 1 + (i__ << 2) - 5], &c__1, &dscale, &
5006 dsum);
5007 /* L40: */
5008 }
5009 bqra21 = dscale * sqrt(dsum);
5010
5011 /* Decide which method to use. */
5012 /* Weak stability test: */
5013 /* F-norm(S21) <= O(EPS * F-norm((S, T))) */
5014
5015 if (bqra21 <= brqa21 && bqra21 <= thresh) {
5016 dlacpy_("F", &m, &m, scpy, &c__4, s, &c__4);
5017 dlacpy_("F", &m, &m, tcpy, &c__4, t, &c__4);
5018 dlacpy_("F", &m, &m, ircop, &c__4, ir, &c__4);
5019 dlacpy_("F", &m, &m, licop, &c__4, li, &c__4);
5020 } else if (brqa21 >= thresh) {
5021 goto L70;
5022 }
5023
5024 /* Set lower triangle of B-part to zero */
5025
5026 i__1 = m - 1;
5027 i__2 = m - 1;
5028 dlaset_("Lower", &i__1, &i__2, &c_b5, &c_b5, &t[1], &c__4);
5029
5030 if (true) {
5031
5032 /* Strong stability test: */
5033 /* F-norm((A-QL*S*QR', B-QL*T*QR')) <= O(EPS*F-norm((A,B))) */
5034
5035 dlacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, &work[m * m
5036 + 1], &m);
5037 dgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, &
5038 work[1], &m);
5039 dgemm_("N", "N", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, &
5040 c_b42, &work[m * m + 1], &m);
5041 dscale = 0.;
5042 dsum = 1.;
5043 i__1 = m * m;
5044 dlassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
5045
5046 dlacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, &work[m * m
5047 + 1], &m);
5048 dgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, &
5049 work[1], &m);
5050 dgemm_("N", "N", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, &
5051 c_b42, &work[m * m + 1], &m);
5052 i__1 = m * m;
5053 dlassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
5054 ss = dscale * sqrt(dsum);
5055 dtrong = ss <= thresh;
5056 if (! dtrong) {
5057 goto L70;
5058 }
5059
5060 }
5061
5062 /* If the swap is accepted ("weakly" and "strongly"), apply the */
5063 /* transformations and set N1-by-N2 (2,1)-block to zero. */
5064
5065 dlaset_("Full", n1, n2, &c_b5, &c_b5, &s[*n2], &c__4);
5066
5067 /* copy back M-by-M diagonal block starting at index J1 of (A, B) */
5068
5069 dlacpy_("F", &m, &m, s, &c__4, &a[*j1 + *j1 * a_dim1], lda)
5070 ;
5071 dlacpy_("F", &m, &m, t, &c__4, &b[*j1 + *j1 * b_dim1], ldb)
5072 ;
5073 dlaset_("Full", &c__4, &c__4, &c_b5, &c_b5, t, &c__4);
5074
5075 /* Standardize existing 2-by-2 blocks. */
5076
5077 i__1 = m * m;
5078 for (i__ = 1; i__ <= i__1; ++i__) {
5079 work[i__] = 0.;
5080 /* L50: */
5081 }
5082 work[1] = 1.;
5083 t[0] = 1.;
5084 idum = *lwork - m * m - 2;
5085 if (*n2 > 1) {
5086 dlagv2_(&a[*j1 + *j1 * a_dim1], lda, &b[*j1 + *j1 * b_dim1], ldb,
5087 ar, ai, be, &work[1], &work[2], t, &t[1]);
5088 work[m + 1] = -work[2];
5089 work[m + 2] = work[1];
5090 t[*n2 + (*n2 << 2) - 5] = t[0];
5091 t[4] = -t[1];
5092 }
5093 work[m * m] = 1.;
5094 t[m + (m << 2) - 5] = 1.;
5095
5096 if (*n1 > 1) {
5097 dlagv2_(&a[*j1 + *n2 + (*j1 + *n2) * a_dim1], lda, &b[*j1 + *n2 +
5098 (*j1 + *n2) * b_dim1], ldb, taur, taul, &work[m * m + 1],
5099 &work[*n2 * m + *n2 + 1], &work[*n2 * m + *n2 + 2], &t[*
5100 n2 + 1 + (*n2 + 1 << 2) - 5], &t[m + (m - 1 << 2) - 5]);
5101 work[m * m] = work[*n2 * m + *n2 + 1];
5102 work[m * m - 1] = -work[*n2 * m + *n2 + 2];
5103 t[m + (m << 2) - 5] = t[*n2 + 1 + (*n2 + 1 << 2) - 5];
5104 t[m - 1 + (m << 2) - 5] = -t[m + (m - 1 << 2) - 5];
5105 }
5106 dgemm_("T", "N", n2, n1, n2, &c_b42, &work[1], &m, &a[*j1 + (*j1 + *
5107 n2) * a_dim1], lda, &c_b5, &work[m * m + 1], n2);
5108 dlacpy_("Full", n2, n1, &work[m * m + 1], n2, &a[*j1 + (*j1 + *n2) *
5109 a_dim1], lda);
5110 dgemm_("T", "N", n2, n1, n2, &c_b42, &work[1], &m, &b[*j1 + (*j1 + *
5111 n2) * b_dim1], ldb, &c_b5, &work[m * m + 1], n2);
5112 dlacpy_("Full", n2, n1, &work[m * m + 1], n2, &b[*j1 + (*j1 + *n2) *
5113 b_dim1], ldb);
5114 dgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, &work[1], &m, &c_b5, &
5115 work[m * m + 1], &m);
5116 dlacpy_("Full", &m, &m, &work[m * m + 1], &m, li, &c__4);
5117 dgemm_("N", "N", n2, n1, n1, &c_b42, &a[*j1 + (*j1 + *n2) * a_dim1],
5118 lda, &t[*n2 + 1 + (*n2 + 1 << 2) - 5], &c__4, &c_b5, &work[1],
5119 n2);
5120 dlacpy_("Full", n2, n1, &work[1], n2, &a[*j1 + (*j1 + *n2) * a_dim1],
5121 lda);
5122 dgemm_("N", "N", n2, n1, n1, &c_b42, &b[*j1 + (*j1 + *n2) * b_dim1],
5123 ldb, &t[*n2 + 1 + (*n2 + 1 << 2) - 5], &c__4, &c_b5, &work[1],
5124 n2);
5125 dlacpy_("Full", n2, n1, &work[1], n2, &b[*j1 + (*j1 + *n2) * b_dim1],
5126 ldb);
5127 dgemm_("T", "N", &m, &m, &m, &c_b42, ir, &c__4, t, &c__4, &c_b5, &
5128 work[1], &m);
5129 dlacpy_("Full", &m, &m, &work[1], &m, ir, &c__4);
5130
5131 /* Accumulate transformations into Q and Z if requested. */
5132
5133 if (*wantq) {
5134 dgemm_("N", "N", n, &m, &m, &c_b42, &q[*j1 * q_dim1 + 1], ldq, li,
5135 &c__4, &c_b5, &work[1], n);
5136 dlacpy_("Full", n, &m, &work[1], n, &q[*j1 * q_dim1 + 1], ldq);
5137
5138 }
5139
5140 if (*wantz) {
5141 dgemm_("N", "N", n, &m, &m, &c_b42, &z__[*j1 * z_dim1 + 1], ldz,
5142 ir, &c__4, &c_b5, &work[1], n);
5143 dlacpy_("Full", n, &m, &work[1], n, &z__[*j1 * z_dim1 + 1], ldz);
5144
5145 }
5146
5147 /* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and */
5148 /* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */
5149
5150 i__ = *j1 + m;
5151 if (i__ <= *n) {
5152 i__1 = *n - i__ + 1;
5153 dgemm_("T", "N", &m, &i__1, &m, &c_b42, li, &c__4, &a[*j1 + i__ *
5154 a_dim1], lda, &c_b5, &work[1], &m);
5155 i__1 = *n - i__ + 1;
5156 dlacpy_("Full", &m, &i__1, &work[1], &m, &a[*j1 + i__ * a_dim1],
5157 lda);
5158 i__1 = *n - i__ + 1;
5159 dgemm_("T", "N", &m, &i__1, &m, &c_b42, li, &c__4, &b[*j1 + i__ *
5160 b_dim1], lda, &c_b5, &work[1], &m);
5161 i__1 = *n - i__ + 1;
5162 dlacpy_("Full", &m, &i__1, &work[1], &m, &b[*j1 + i__ * b_dim1],
5163 ldb);
5164 }
5165 i__ = *j1 - 1;
5166 if (i__ > 0) {
5167 dgemm_("N", "N", &i__, &m, &m, &c_b42, &a[*j1 * a_dim1 + 1], lda,
5168 ir, &c__4, &c_b5, &work[1], &i__);
5169 dlacpy_("Full", &i__, &m, &work[1], &i__, &a[*j1 * a_dim1 + 1],
5170 lda);
5171 dgemm_("N", "N", &i__, &m, &m, &c_b42, &b[*j1 * b_dim1 + 1], ldb,
5172 ir, &c__4, &c_b5, &work[1], &i__);
5173 dlacpy_("Full", &i__, &m, &work[1], &i__, &b[*j1 * b_dim1 + 1],
5174 ldb);
5175 }
5176
5177 /* Exit with INFO = 0 if swap was successfully performed. */
5178
5179 return 0;
5180
5181 }
5182
5183 /* Exit with INFO = 1 if swap was rejected. */
5184
5185 L70:
5186
5187 *info = 1;
5188 return 0;
5189
5190 /* End of DTGEX2 */
5191
5192 } /* dtgex2_ */
5193
dtgexc_(bool * wantq,bool * wantz,integer * n,double * a,integer * lda,double * b,integer * ldb,double * q,integer * ldq,double * z__,integer * ldz,integer * ifst,integer * ilst,double * work,integer * lwork,integer * info)5194 /* Subroutine */ int dtgexc_(bool *wantq, bool *wantz, integer *n,
5195 double *a, integer *lda, double *b, integer *ldb, double *
5196 q, integer *ldq, double *z__, integer *ldz, integer *ifst,
5197 integer *ilst, double *work, integer *lwork, integer *info)
5198 {
5199 /* Table of constant values */
5200 static integer c__1 = 1;
5201 static integer c__2 = 2;
5202
5203 /* System generated locals */
5204 integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
5205 z_offset, i__1;
5206
5207 /* Local variables */
5208 integer nbf, nbl, here, lwmin;
5209 integer nbnext;
5210 bool lquery;
5211
5212
5213 /* -- LAPACK routine (version 3.1) -- */
5214 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
5215 /* November 2006 */
5216
5217 /* .. Scalar Arguments .. */
5218 /* .. */
5219 /* .. Array Arguments .. */
5220 /* .. */
5221
5222 /* Purpose */
5223 /* ======= */
5224
5225 /* DTGEXC reorders the generalized real Schur decomposition of a real */
5226 /* matrix pair (A,B) using an orthogonal equivalence transformation */
5227
5228 /* (A, B) = Q * (A, B) * Z', */
5229
5230 /* so that the diagonal block of (A, B) with row index IFST is moved */
5231 /* to row ILST. */
5232
5233 /* (A, B) must be in generalized real Schur canonical form (as returned */
5234 /* by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2 */
5235 /* diagonal blocks. B is upper triangular. */
5236
5237 /* Optionally, the matrices Q and Z of generalized Schur vectors are */
5238 /* updated. */
5239
5240 /* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)' */
5241 /* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)' */
5242
5243
5244 /* Arguments */
5245 /* ========= */
5246
5247 /* WANTQ (input) LOGICAL */
5248 /* .TRUE. : update the left transformation matrix Q; */
5249 /* .FALSE.: do not update Q. */
5250
5251 /* WANTZ (input) LOGICAL */
5252 /* .TRUE. : update the right transformation matrix Z; */
5253 /* .FALSE.: do not update Z. */
5254
5255 /* N (input) INTEGER */
5256 /* The order of the matrices A and B. N >= 0. */
5257
5258 /* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
5259 /* On entry, the matrix A in generalized real Schur canonical */
5260 /* form. */
5261 /* On exit, the updated matrix A, again in generalized */
5262 /* real Schur canonical form. */
5263
5264 /* LDA (input) INTEGER */
5265 /* The leading dimension of the array A. LDA >= max(1,N). */
5266
5267 /* B (input/output) DOUBLE PRECISION array, dimension (LDB,N) */
5268 /* On entry, the matrix B in generalized real Schur canonical */
5269 /* form (A,B). */
5270 /* On exit, the updated matrix B, again in generalized */
5271 /* real Schur canonical form (A,B). */
5272
5273 /* LDB (input) INTEGER */
5274 /* The leading dimension of the array B. LDB >= max(1,N). */
5275
5276 /* Q (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */
5277 /* On entry, if WANTQ = .TRUE., the orthogonal matrix Q. */
5278 /* On exit, the updated matrix Q. */
5279 /* If WANTQ = .FALSE., Q is not referenced. */
5280
5281 /* LDQ (input) INTEGER */
5282 /* The leading dimension of the array Q. LDQ >= 1. */
5283 /* If WANTQ = .TRUE., LDQ >= N. */
5284
5285 /* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */
5286 /* On entry, if WANTZ = .TRUE., the orthogonal matrix Z. */
5287 /* On exit, the updated matrix Z. */
5288 /* If WANTZ = .FALSE., Z is not referenced. */
5289
5290 /* LDZ (input) INTEGER */
5291 /* The leading dimension of the array Z. LDZ >= 1. */
5292 /* If WANTZ = .TRUE., LDZ >= N. */
5293
5294 /* IFST (input/output) INTEGER */
5295 /* ILST (input/output) INTEGER */
5296 /* Specify the reordering of the diagonal blocks of (A, B). */
5297 /* The block with row index IFST is moved to row ILST, by a */
5298 /* sequence of swapping between adjacent blocks. */
5299 /* On exit, if IFST pointed on entry to the second row of */
5300 /* a 2-by-2 block, it is changed to point to the first row; */
5301 /* ILST always points to the first row of the block in its */
5302 /* final position (which may differ from its input value by */
5303 /* +1 or -1). 1 <= IFST, ILST <= N. */
5304
5305 /* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
5306 /* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
5307
5308 /* LWORK (input) INTEGER */
5309 /* The dimension of the array WORK. */
5310 /* LWORK >= 1 when N <= 1, otherwise LWORK >= 4*N + 16. */
5311
5312 /* If LWORK = -1, then a workspace query is assumed; the routine */
5313 /* only calculates the optimal size of the WORK array, returns */
5314 /* this value as the first entry of the WORK array, and no error */
5315 /* message related to LWORK is issued by XERBLA. */
5316
5317 /* INFO (output) INTEGER */
5318 /* =0: successful exit. */
5319 /* <0: if INFO = -i, the i-th argument had an illegal value. */
5320 /* =1: The transformed matrix pair (A, B) would be too far */
5321 /* from generalized Schur form; the problem is ill- */
5322 /* conditioned. (A, B) may have been partially reordered, */
5323 /* and ILST points to the first row of the current */
5324 /* position of the block being moved. */
5325
5326 /* Further Details */
5327 /* =============== */
5328
5329 /* Based on contributions by */
5330 /* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
5331 /* Umea University, S-901 87 Umea, Sweden. */
5332
5333 /* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
5334 /* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
5335 /* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
5336 /* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
5337
5338 /* ===================================================================== */
5339
5340 /* .. Parameters .. */
5341 /* .. */
5342 /* .. Local Scalars .. */
5343 /* .. */
5344 /* .. External Subroutines .. */
5345 /* .. */
5346 /* .. Intrinsic Functions .. */
5347 /* .. */
5348 /* .. Executable Statements .. */
5349
5350 /* Decode and test input arguments. */
5351
5352 /* Parameter adjustments */
5353 a_dim1 = *lda;
5354 a_offset = 1 + a_dim1;
5355 a -= a_offset;
5356 b_dim1 = *ldb;
5357 b_offset = 1 + b_dim1;
5358 b -= b_offset;
5359 q_dim1 = *ldq;
5360 q_offset = 1 + q_dim1;
5361 q -= q_offset;
5362 z_dim1 = *ldz;
5363 z_offset = 1 + z_dim1;
5364 z__ -= z_offset;
5365 --work;
5366
5367 /* Function Body */
5368 *info = 0;
5369 lquery = *lwork == -1;
5370 if (*n < 0) {
5371 *info = -3;
5372 } else if (*lda < std::max(1_integer,*n)) {
5373 *info = -5;
5374 } else if (*ldb < std::max(1_integer,*n)) {
5375 *info = -7;
5376 } else if (*ldq < 1 || *wantq && *ldq < std::max(1_integer,*n)) {
5377 *info = -9;
5378 } else if (*ldz < 1 || *wantz && *ldz < std::max(1_integer,*n)) {
5379 *info = -11;
5380 } else if (*ifst < 1 || *ifst > *n) {
5381 *info = -12;
5382 } else if (*ilst < 1 || *ilst > *n) {
5383 *info = -13;
5384 }
5385
5386 if (*info == 0) {
5387 if (*n <= 1) {
5388 lwmin = 1;
5389 } else {
5390 lwmin = (*n << 2) + 16;
5391 }
5392 work[1] = (double) lwmin;
5393
5394 if (*lwork < lwmin && ! lquery) {
5395 *info = -15;
5396 }
5397 }
5398
5399 if (*info != 0) {
5400 i__1 = -(*info);
5401 xerbla_("DTGEXC", &i__1);
5402 return 0;
5403 } else if (lquery) {
5404 return 0;
5405 }
5406
5407 /* Quick return if possible */
5408
5409 if (*n <= 1) {
5410 return 0;
5411 }
5412
5413 /* Determine the first row of the specified block and find out */
5414 /* if it is 1-by-1 or 2-by-2. */
5415
5416 if (*ifst > 1) {
5417 if (a[*ifst + (*ifst - 1) * a_dim1] != 0.) {
5418 --(*ifst);
5419 }
5420 }
5421 nbf = 1;
5422 if (*ifst < *n) {
5423 if (a[*ifst + 1 + *ifst * a_dim1] != 0.) {
5424 nbf = 2;
5425 }
5426 }
5427
5428 /* Determine the first row of the final block */
5429 /* and find out if it is 1-by-1 or 2-by-2. */
5430
5431 if (*ilst > 1) {
5432 if (a[*ilst + (*ilst - 1) * a_dim1] != 0.) {
5433 --(*ilst);
5434 }
5435 }
5436 nbl = 1;
5437 if (*ilst < *n) {
5438 if (a[*ilst + 1 + *ilst * a_dim1] != 0.) {
5439 nbl = 2;
5440 }
5441 }
5442 if (*ifst == *ilst) {
5443 return 0;
5444 }
5445
5446 if (*ifst < *ilst) {
5447
5448 /* Update ILST. */
5449
5450 if (nbf == 2 && nbl == 1) {
5451 --(*ilst);
5452 }
5453 if (nbf == 1 && nbl == 2) {
5454 ++(*ilst);
5455 }
5456
5457 here = *ifst;
5458
5459 L10:
5460
5461 /* Swap with next one below. */
5462
5463 if (nbf == 1 || nbf == 2) {
5464
5465 /* Current block either 1-by-1 or 2-by-2. */
5466
5467 nbnext = 1;
5468 if (here + nbf + 1 <= *n) {
5469 if (a[here + nbf + 1 + (here + nbf) * a_dim1] != 0.) {
5470 nbnext = 2;
5471 }
5472 }
5473 dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[
5474 q_offset], ldq, &z__[z_offset], ldz, &here, &nbf, &nbnext,
5475 &work[1], lwork, info);
5476 if (*info != 0) {
5477 *ilst = here;
5478 return 0;
5479 }
5480 here += nbnext;
5481
5482 /* Test if 2-by-2 block breaks into two 1-by-1 blocks. */
5483
5484 if (nbf == 2) {
5485 if (a[here + 1 + here * a_dim1] == 0.) {
5486 nbf = 3;
5487 }
5488 }
5489
5490 } else {
5491
5492 /* Current block consists of two 1-by-1 blocks, each of which */
5493 /* must be swapped individually. */
5494
5495 nbnext = 1;
5496 if (here + 3 <= *n) {
5497 if (a[here + 3 + (here + 2) * a_dim1] != 0.) {
5498 nbnext = 2;
5499 }
5500 }
5501 i__1 = here + 1;
5502 dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[
5503 q_offset], ldq, &z__[z_offset], ldz, &i__1, &c__1, &
5504 nbnext, &work[1], lwork, info);
5505 if (*info != 0) {
5506 *ilst = here;
5507 return 0;
5508 }
5509 if (nbnext == 1) {
5510
5511 /* Swap two 1-by-1 blocks. */
5512
5513 dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb,
5514 &q[q_offset], ldq, &z__[z_offset], ldz, &here, &c__1,
5515 &c__1, &work[1], lwork, info);
5516 if (*info != 0) {
5517 *ilst = here;
5518 return 0;
5519 }
5520 ++here;
5521
5522 } else {
5523
5524 /* Recompute NBNEXT in case of 2-by-2 split. */
5525
5526 if (a[here + 2 + (here + 1) * a_dim1] == 0.) {
5527 nbnext = 1;
5528 }
5529 if (nbnext == 2) {
5530
5531 /* 2-by-2 block did not split. */
5532
5533 dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset],
5534 ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &
5535 here, &c__1, &nbnext, &work[1], lwork, info);
5536 if (*info != 0) {
5537 *ilst = here;
5538 return 0;
5539 }
5540 here += 2;
5541 } else {
5542
5543 /* 2-by-2 block did split. */
5544
5545 dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset],
5546 ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &
5547 here, &c__1, &c__1, &work[1], lwork, info);
5548 if (*info != 0) {
5549 *ilst = here;
5550 return 0;
5551 }
5552 ++here;
5553 dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset],
5554 ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &
5555 here, &c__1, &c__1, &work[1], lwork, info);
5556 if (*info != 0) {
5557 *ilst = here;
5558 return 0;
5559 }
5560 ++here;
5561 }
5562
5563 }
5564 }
5565 if (here < *ilst) {
5566 goto L10;
5567 }
5568 } else {
5569 here = *ifst;
5570
5571 L20:
5572
5573 /* Swap with next one below. */
5574
5575 if (nbf == 1 || nbf == 2) {
5576
5577 /* Current block either 1-by-1 or 2-by-2. */
5578
5579 nbnext = 1;
5580 if (here >= 3) {
5581 if (a[here - 1 + (here - 2) * a_dim1] != 0.) {
5582 nbnext = 2;
5583 }
5584 }
5585 i__1 = here - nbnext;
5586 dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[
5587 q_offset], ldq, &z__[z_offset], ldz, &i__1, &nbnext, &nbf,
5588 &work[1], lwork, info);
5589 if (*info != 0) {
5590 *ilst = here;
5591 return 0;
5592 }
5593 here -= nbnext;
5594
5595 /* Test if 2-by-2 block breaks into two 1-by-1 blocks. */
5596
5597 if (nbf == 2) {
5598 if (a[here + 1 + here * a_dim1] == 0.) {
5599 nbf = 3;
5600 }
5601 }
5602
5603 } else {
5604
5605 /* Current block consists of two 1-by-1 blocks, each of which */
5606 /* must be swapped individually. */
5607
5608 nbnext = 1;
5609 if (here >= 3) {
5610 if (a[here - 1 + (here - 2) * a_dim1] != 0.) {
5611 nbnext = 2;
5612 }
5613 }
5614 i__1 = here - nbnext;
5615 dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[
5616 q_offset], ldq, &z__[z_offset], ldz, &i__1, &nbnext, &
5617 c__1, &work[1], lwork, info);
5618 if (*info != 0) {
5619 *ilst = here;
5620 return 0;
5621 }
5622 if (nbnext == 1) {
5623
5624 /* Swap two 1-by-1 blocks. */
5625
5626 dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb,
5627 &q[q_offset], ldq, &z__[z_offset], ldz, &here, &
5628 nbnext, &c__1, &work[1], lwork, info);
5629 if (*info != 0) {
5630 *ilst = here;
5631 return 0;
5632 }
5633 --here;
5634 } else {
5635
5636 /* Recompute NBNEXT in case of 2-by-2 split. */
5637
5638 if (a[here + (here - 1) * a_dim1] == 0.) {
5639 nbnext = 1;
5640 }
5641 if (nbnext == 2) {
5642
5643 /* 2-by-2 block did not split. */
5644
5645 i__1 = here - 1;
5646 dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset],
5647 ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &
5648 i__1, &c__2, &c__1, &work[1], lwork, info);
5649 if (*info != 0) {
5650 *ilst = here;
5651 return 0;
5652 }
5653 here += -2;
5654 } else {
5655
5656 /* 2-by-2 block did split. */
5657
5658 dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset],
5659 ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &
5660 here, &c__1, &c__1, &work[1], lwork, info);
5661 if (*info != 0) {
5662 *ilst = here;
5663 return 0;
5664 }
5665 --here;
5666 dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset],
5667 ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &
5668 here, &c__1, &c__1, &work[1], lwork, info);
5669 if (*info != 0) {
5670 *ilst = here;
5671 return 0;
5672 }
5673 --here;
5674 }
5675 }
5676 }
5677 if (here > *ilst) {
5678 goto L20;
5679 }
5680 }
5681 *ilst = here;
5682 work[1] = (double) lwmin;
5683 return 0;
5684
5685 /* End of DTGEXC */
5686
5687 } /* dtgexc_ */
5688
dtgsen_(integer * ijob,bool * wantq,bool * wantz,bool * select,integer * n,double * a,integer * lda,double * b,integer * ldb,double * alphar,double * alphai,double * beta,double * q,integer * ldq,double * z__,integer * ldz,integer * m,double * pl,double * pr,double * dif,double * work,integer * lwork,integer * iwork,integer * liwork,integer * info)5689 /* Subroutine */ int dtgsen_(integer *ijob, bool *wantq, bool *wantz,
5690 bool *select, integer *n, double *a, integer *lda, double *
5691 b, integer *ldb, double *alphar, double *alphai, double *
5692 beta, double *q, integer *ldq, double *z__, integer *ldz,
5693 integer *m, double *pl, double *pr, double *dif,
5694 double *work, integer *lwork, integer *iwork, integer *liwork,
5695 integer *info)
5696 {
5697 /* Table of constant values */
5698 static integer c__1 = 1;
5699 static integer c__2 = 2;
5700 static double c_b28 = 1.;
5701
5702 /* System generated locals */
5703 integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
5704 z_offset, i__1, i__2;
5705 double d__1;
5706
5707 /* Local variables */
5708 integer i__, k, n1, n2, kk, ks, mn2, ijb;
5709 double eps;
5710 integer kase;
5711 bool pair;
5712 integer ierr;
5713 double dsum;
5714 bool swap;
5715 integer isave[3];
5716 bool wantd;
5717 integer lwmin;
5718 bool wantp;
5719 bool wantd1, wantd2;
5720 double dscale, rdscal;
5721 integer liwmin;
5722 double smlnum;
5723 bool lquery;
5724
5725
5726 /* -- LAPACK routine (version 3.1.1) -- */
5727 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
5728 /* January 2007 */
5729
5730 /* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
5731
5732 /* .. Scalar Arguments .. */
5733 /* .. */
5734 /* .. Array Arguments .. */
5735 /* .. */
5736
5737 /* Purpose */
5738 /* ======= */
5739
5740 /* DTGSEN reorders the generalized real Schur decomposition of a real */
5741 /* matrix pair (A, B) (in terms of an orthonormal equivalence trans- */
5742 /* formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues */
5743 /* appears in the leading diagonal blocks of the upper quasi-triangular */
5744 /* matrix A and the upper triangular B. The leading columns of Q and */
5745 /* Z form orthonormal bases of the corresponding left and right eigen- */
5746 /* spaces (deflating subspaces). (A, B) must be in generalized real */
5747 /* Schur canonical form (as returned by DGGES), i.e. A is block upper */
5748 /* triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper */
5749 /* triangular. */
5750
5751 /* DTGSEN also computes the generalized eigenvalues */
5752
5753 /* w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j) */
5754
5755 /* of the reordered matrix pair (A, B). */
5756
5757 /* Optionally, DTGSEN computes the estimates of reciprocal condition */
5758 /* numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11), */
5759 /* (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s) */
5760 /* between the matrix pairs (A11, B11) and (A22,B22) that correspond to */
5761 /* the selected cluster and the eigenvalues outside the cluster, resp., */
5762 /* and norms of "projections" onto left and right eigenspaces w.r.t. */
5763 /* the selected cluster in the (1,1)-block. */
5764
5765 /* Arguments */
5766 /* ========= */
5767
5768 /* IJOB (input) INTEGER */
5769 /* Specifies whether condition numbers are required for the */
5770 /* cluster of eigenvalues (PL and PR) or the deflating subspaces */
5771 /* (Difu and Difl): */
5772 /* =0: Only reorder w.r.t. SELECT. No extras. */
5773 /* =1: Reciprocal of norms of "projections" onto left and right */
5774 /* eigenspaces w.r.t. the selected cluster (PL and PR). */
5775 /* =2: Upper bounds on Difu and Difl. F-norm-based estimate */
5776 /* (DIF(1:2)). */
5777 /* =3: Estimate of Difu and Difl. 1-norm-based estimate */
5778 /* (DIF(1:2)). */
5779 /* About 5 times as expensive as IJOB = 2. */
5780 /* =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic */
5781 /* version to get it all. */
5782 /* =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above) */
5783
5784 /* WANTQ (input) LOGICAL */
5785 /* .TRUE. : update the left transformation matrix Q; */
5786 /* .FALSE.: do not update Q. */
5787
5788 /* WANTZ (input) LOGICAL */
5789 /* .TRUE. : update the right transformation matrix Z; */
5790 /* .FALSE.: do not update Z. */
5791
5792 /* SELECT (input) LOGICAL array, dimension (N) */
5793 /* SELECT specifies the eigenvalues in the selected cluster. */
5794 /* To select a real eigenvalue w(j), SELECT(j) must be set to */
5795 /* .TRUE.. To select a complex conjugate pair of eigenvalues */
5796 /* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, */
5797 /* either SELECT(j) or SELECT(j+1) or both must be set to */
5798 /* .TRUE.; a complex conjugate pair of eigenvalues must be */
5799 /* either both included in the cluster or both excluded. */
5800
5801 /* N (input) INTEGER */
5802 /* The order of the matrices A and B. N >= 0. */
5803
5804 /* A (input/output) DOUBLE PRECISION array, dimension(LDA,N) */
5805 /* On entry, the upper quasi-triangular matrix A, with (A, B) in */
5806 /* generalized real Schur canonical form. */
5807 /* On exit, A is overwritten by the reordered matrix A. */
5808
5809 /* LDA (input) INTEGER */
5810 /* The leading dimension of the array A. LDA >= max(1,N). */
5811
5812 /* B (input/output) DOUBLE PRECISION array, dimension(LDB,N) */
5813 /* On entry, the upper triangular matrix B, with (A, B) in */
5814 /* generalized real Schur canonical form. */
5815 /* On exit, B is overwritten by the reordered matrix B. */
5816
5817 /* LDB (input) INTEGER */
5818 /* The leading dimension of the array B. LDB >= max(1,N). */
5819
5820 /* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */
5821 /* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */
5822 /* BETA (output) DOUBLE PRECISION array, dimension (N) */
5823 /* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */
5824 /* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i */
5825 /* and BETA(j),j=1,...,N are the diagonals of the complex Schur */
5826 /* form (S,T) that would result if the 2-by-2 diagonal blocks of */
5827 /* the real generalized Schur form of (A,B) were further reduced */
5828 /* to triangular form using complex unitary transformations. */
5829 /* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if */
5830 /* positive, then the j-th and (j+1)-st eigenvalues are a */
5831 /* complex conjugate pair, with ALPHAI(j+1) negative. */
5832
5833 /* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */
5834 /* On entry, if WANTQ = .TRUE., Q is an N-by-N matrix. */
5835 /* On exit, Q has been postmultiplied by the left orthogonal */
5836 /* transformation matrix which reorder (A, B); The leading M */
5837 /* columns of Q form orthonormal bases for the specified pair of */
5838 /* left eigenspaces (deflating subspaces). */
5839 /* If WANTQ = .FALSE., Q is not referenced. */
5840
5841 /* LDQ (input) INTEGER */
5842 /* The leading dimension of the array Q. LDQ >= 1; */
5843 /* and if WANTQ = .TRUE., LDQ >= N. */
5844
5845 /* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */
5846 /* On entry, if WANTZ = .TRUE., Z is an N-by-N matrix. */
5847 /* On exit, Z has been postmultiplied by the left orthogonal */
5848 /* transformation matrix which reorder (A, B); The leading M */
5849 /* columns of Z form orthonormal bases for the specified pair of */
5850 /* left eigenspaces (deflating subspaces). */
5851 /* If WANTZ = .FALSE., Z is not referenced. */
5852
5853 /* LDZ (input) INTEGER */
5854 /* The leading dimension of the array Z. LDZ >= 1; */
5855 /* If WANTZ = .TRUE., LDZ >= N. */
5856
5857 /* M (output) INTEGER */
5858 /* The dimension of the specified pair of left and right eigen- */
5859 /* spaces (deflating subspaces). 0 <= M <= N. */
5860
5861 /* PL (output) DOUBLE PRECISION */
5862 /* PR (output) DOUBLE PRECISION */
5863 /* If IJOB = 1, 4 or 5, PL, PR are lower bounds on the */
5864 /* reciprocal of the norm of "projections" onto left and right */
5865 /* eigenspaces with respect to the selected cluster. */
5866 /* 0 < PL, PR <= 1. */
5867 /* If M = 0 or M = N, PL = PR = 1. */
5868 /* If IJOB = 0, 2 or 3, PL and PR are not referenced. */
5869
5870 /* DIF (output) DOUBLE PRECISION array, dimension (2). */
5871 /* If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl. */
5872 /* If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on */
5873 /* Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based */
5874 /* estimates of Difu and Difl. */
5875 /* If M = 0 or N, DIF(1:2) = F-norm([A, B]). */
5876 /* If IJOB = 0 or 1, DIF is not referenced. */
5877
5878 /* WORK (workspace/output) DOUBLE PRECISION array, */
5879 /* dimension (MAX(1,LWORK)) */
5880 /* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
5881
5882 /* LWORK (input) INTEGER */
5883 /* The dimension of the array WORK. LWORK >= 4*N+16. */
5884 /* If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)). */
5885 /* If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)). */
5886
5887 /* If LWORK = -1, then a workspace query is assumed; the routine */
5888 /* only calculates the optimal size of the WORK array, returns */
5889 /* this value as the first entry of the WORK array, and no error */
5890 /* message related to LWORK is issued by XERBLA. */
5891
5892 /* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
5893 /* IF IJOB = 0, IWORK is not referenced. Otherwise, */
5894 /* on exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
5895
5896 /* LIWORK (input) INTEGER */
5897 /* The dimension of the array IWORK. LIWORK >= 1. */
5898 /* If IJOB = 1, 2 or 4, LIWORK >= N+6. */
5899 /* If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6). */
5900
5901 /* If LIWORK = -1, then a workspace query is assumed; the */
5902 /* routine only calculates the optimal size of the IWORK array, */
5903 /* returns this value as the first entry of the IWORK array, and */
5904 /* no error message related to LIWORK is issued by XERBLA. */
5905
5906 /* INFO (output) INTEGER */
5907 /* =0: Successful exit. */
5908 /* <0: If INFO = -i, the i-th argument had an illegal value. */
5909 /* =1: Reordering of (A, B) failed because the transformed */
5910 /* matrix pair (A, B) would be too far from generalized */
5911 /* Schur form; the problem is very ill-conditioned. */
5912 /* (A, B) may have been partially reordered. */
5913 /* If requested, 0 is returned in DIF(*), PL and PR. */
5914
5915 /* Further Details */
5916 /* =============== */
5917
5918 /* DTGSEN first collects the selected eigenvalues by computing */
5919 /* orthogonal U and W that move them to the top left corner of (A, B). */
5920 /* In other words, the selected eigenvalues are the eigenvalues of */
5921 /* (A11, B11) in: */
5922
5923 /* U'*(A, B)*W = (A11 A12) (B11 B12) n1 */
5924 /* ( 0 A22),( 0 B22) n2 */
5925 /* n1 n2 n1 n2 */
5926
5927 /* where N = n1+n2 and U' means the transpose of U. The first n1 columns */
5928 /* of U and W span the specified pair of left and right eigenspaces */
5929 /* (deflating subspaces) of (A, B). */
5930
5931 /* If (A, B) has been obtained from the generalized real Schur */
5932 /* decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the */
5933 /* reordered generalized real Schur form of (C, D) is given by */
5934
5935 /* (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)', */
5936
5937 /* and the first n1 columns of Q*U and Z*W span the corresponding */
5938 /* deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.). */
5939
5940 /* Note that if the selected eigenvalue is sufficiently ill-conditioned, */
5941 /* then its value may differ significantly from its value before */
5942 /* reordering. */
5943
5944 /* The reciprocal condition numbers of the left and right eigenspaces */
5945 /* spanned by the first n1 columns of U and W (or Q*U and Z*W) may */
5946 /* be returned in DIF(1:2), corresponding to Difu and Difl, resp. */
5947
5948 /* The Difu and Difl are defined as: */
5949
5950 /* Difu[(A11, B11), (A22, B22)] = sigma-min( Zu ) */
5951 /* and */
5952 /* Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)], */
5953
5954 /* where sigma-min(Zu) is the smallest singular value of the */
5955 /* (2*n1*n2)-by-(2*n1*n2) matrix */
5956
5957 /* Zu = [ kron(In2, A11) -kron(A22', In1) ] */
5958 /* [ kron(In2, B11) -kron(B22', In1) ]. */
5959
5960 /* Here, Inx is the identity matrix of size nx and A22' is the */
5961 /* transpose of A22. kron(X, Y) is the Kronecker product between */
5962 /* the matrices X and Y. */
5963
5964 /* When DIF(2) is small, small changes in (A, B) can cause large changes */
5965 /* in the deflating subspace. An approximate (asymptotic) bound on the */
5966 /* maximum angular error in the computed deflating subspaces is */
5967
5968 /* EPS * norm((A, B)) / DIF(2), */
5969
5970 /* where EPS is the machine precision. */
5971
5972 /* The reciprocal norm of the projectors on the left and right */
5973 /* eigenspaces associated with (A11, B11) may be returned in PL and PR. */
5974 /* They are computed as follows. First we compute L and R so that */
5975 /* P*(A, B)*Q is block diagonal, where */
5976
5977 /* P = ( I -L ) n1 Q = ( I R ) n1 */
5978 /* ( 0 I ) n2 and ( 0 I ) n2 */
5979 /* n1 n2 n1 n2 */
5980
5981 /* and (L, R) is the solution to the generalized Sylvester equation */
5982
5983 /* A11*R - L*A22 = -A12 */
5984 /* B11*R - L*B22 = -B12 */
5985
5986 /* Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2). */
5987 /* An approximate (asymptotic) bound on the average absolute error of */
5988 /* the selected eigenvalues is */
5989
5990 /* EPS * norm((A, B)) / PL. */
5991
5992 /* There are also global error bounds which valid for perturbations up */
5993 /* to a certain restriction: A lower bound (x) on the smallest */
5994 /* F-norm(E,F) for which an eigenvalue of (A11, B11) may move and */
5995 /* coalesce with an eigenvalue of (A22, B22) under perturbation (E,F), */
5996 /* (i.e. (A + E, B + F), is */
5997
5998 /* x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)). */
5999
6000 /* An approximate bound on x can be computed from DIF(1:2), PL and PR. */
6001
6002 /* If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed */
6003 /* (L', R') and unperturbed (L, R) left and right deflating subspaces */
6004 /* associated with the selected cluster in the (1,1)-blocks can be */
6005 /* bounded as */
6006
6007 /* max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2)) */
6008 /* max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2)) */
6009
6010 /* See LAPACK User's Guide section 4.11 or the following references */
6011 /* for more information. */
6012
6013 /* Note that if the default method for computing the Frobenius-norm- */
6014 /* based estimate DIF is not wanted (see DLATDF), then the parameter */
6015 /* IDIFJB (see below) should be changed from 3 to 4 (routine DLATDF */
6016 /* (IJOB = 2 will be used)). See DTGSYL for more details. */
6017
6018 /* Based on contributions by */
6019 /* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
6020 /* Umea University, S-901 87 Umea, Sweden. */
6021
6022 /* References */
6023 /* ========== */
6024
6025 /* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
6026 /* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
6027 /* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
6028 /* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
6029
6030 /* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
6031 /* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
6032 /* Estimation: Theory, Algorithms and Software, */
6033 /* Report UMINF - 94.04, Department of Computing Science, Umea */
6034 /* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */
6035 /* Note 87. To appear in Numerical Algorithms, 1996. */
6036
6037 /* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */
6038 /* for Solving the Generalized Sylvester Equation and Estimating the */
6039 /* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */
6040 /* Department of Computing Science, Umea University, S-901 87 Umea, */
6041 /* Sweden, December 1993, Revised April 1994, Also as LAPACK Working */
6042 /* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, */
6043 /* 1996. */
6044
6045 /* ===================================================================== */
6046
6047 /* .. Parameters .. */
6048 /* .. */
6049 /* .. Local Scalars .. */
6050 /* .. */
6051 /* .. Local Arrays .. */
6052 /* .. */
6053 /* .. External Subroutines .. */
6054 /* .. */
6055 /* .. External Functions .. */
6056 /* .. */
6057 /* .. Intrinsic Functions .. */
6058 /* .. */
6059 /* .. Executable Statements .. */
6060
6061 /* Decode and test the input parameters */
6062
6063 /* Parameter adjustments */
6064 --select;
6065 a_dim1 = *lda;
6066 a_offset = 1 + a_dim1;
6067 a -= a_offset;
6068 b_dim1 = *ldb;
6069 b_offset = 1 + b_dim1;
6070 b -= b_offset;
6071 --alphar;
6072 --alphai;
6073 --beta;
6074 q_dim1 = *ldq;
6075 q_offset = 1 + q_dim1;
6076 q -= q_offset;
6077 z_dim1 = *ldz;
6078 z_offset = 1 + z_dim1;
6079 z__ -= z_offset;
6080 --dif;
6081 --work;
6082 --iwork;
6083
6084 /* Function Body */
6085 *info = 0;
6086 lquery = *lwork == -1 || *liwork == -1;
6087
6088 if (*ijob < 0 || *ijob > 5) {
6089 *info = -1;
6090 } else if (*n < 0) {
6091 *info = -5;
6092 } else if (*lda < std::max(1_integer,*n)) {
6093 *info = -7;
6094 } else if (*ldb < std::max(1_integer,*n)) {
6095 *info = -9;
6096 } else if (*ldq < 1 || *wantq && *ldq < *n) {
6097 *info = -14;
6098 } else if (*ldz < 1 || *wantz && *ldz < *n) {
6099 *info = -16;
6100 }
6101
6102 if (*info != 0) {
6103 i__1 = -(*info);
6104 xerbla_("DTGSEN", &i__1);
6105 return 0;
6106 }
6107
6108 /* Get machine constants */
6109
6110 eps = dlamch_("P");
6111 smlnum = dlamch_("S") / eps;
6112 ierr = 0;
6113
6114 wantp = *ijob == 1 || *ijob >= 4;
6115 wantd1 = *ijob == 2 || *ijob == 4;
6116 wantd2 = *ijob == 3 || *ijob == 5;
6117 wantd = wantd1 || wantd2;
6118
6119 /* Set M to the dimension of the specified pair of deflating */
6120 /* subspaces. */
6121
6122 *m = 0;
6123 pair = false;
6124 i__1 = *n;
6125 for (k = 1; k <= i__1; ++k) {
6126 if (pair) {
6127 pair = false;
6128 } else {
6129 if (k < *n) {
6130 if (a[k + 1 + k * a_dim1] == 0.) {
6131 if (select[k]) {
6132 ++(*m);
6133 }
6134 } else {
6135 pair = true;
6136 if (select[k] || select[k + 1]) {
6137 *m += 2;
6138 }
6139 }
6140 } else {
6141 if (select[*n]) {
6142 ++(*m);
6143 }
6144 }
6145 }
6146 /* L10: */
6147 }
6148
6149 if (*ijob == 1 || *ijob == 2 || *ijob == 4) {
6150 /* Computing MAX */
6151 i__1 = 1, i__2 = (*n << 2) + 16, i__1 = std::max(i__1,i__2), i__2 = (*m <<
6152 1) * (*n - *m);
6153 lwmin = std::max(i__1,i__2);
6154 /* Computing MAX */
6155 i__1 = 1, i__2 = *n + 6;
6156 liwmin = std::max(i__1,i__2);
6157 } else if (*ijob == 3 || *ijob == 5) {
6158 /* Computing MAX */
6159 i__1 = 1, i__2 = (*n << 2) + 16, i__1 = std::max(i__1,i__2), i__2 = (*m <<
6160 2) * (*n - *m);
6161 lwmin = std::max(i__1,i__2);
6162 /* Computing MAX */
6163 i__1 = 1, i__2 = (*m << 1) * (*n - *m), i__1 = std::max(i__1,i__2), i__2 =
6164 *n + 6;
6165 liwmin = std::max(i__1,i__2);
6166 } else {
6167 /* Computing MAX */
6168 i__1 = 1, i__2 = (*n << 2) + 16;
6169 lwmin = std::max(i__1,i__2);
6170 liwmin = 1;
6171 }
6172
6173 work[1] = (double) lwmin;
6174 iwork[1] = liwmin;
6175
6176 if (*lwork < lwmin && ! lquery) {
6177 *info = -22;
6178 } else if (*liwork < liwmin && ! lquery) {
6179 *info = -24;
6180 }
6181
6182 if (*info != 0) {
6183 i__1 = -(*info);
6184 xerbla_("DTGSEN", &i__1);
6185 return 0;
6186 } else if (lquery) {
6187 return 0;
6188 }
6189
6190 /* Quick return if possible. */
6191
6192 if (*m == *n || *m == 0) {
6193 if (wantp) {
6194 *pl = 1.;
6195 *pr = 1.;
6196 }
6197 if (wantd) {
6198 dscale = 0.;
6199 dsum = 1.;
6200 i__1 = *n;
6201 for (i__ = 1; i__ <= i__1; ++i__) {
6202 dlassq_(n, &a[i__ * a_dim1 + 1], &c__1, &dscale, &dsum);
6203 dlassq_(n, &b[i__ * b_dim1 + 1], &c__1, &dscale, &dsum);
6204 /* L20: */
6205 }
6206 dif[1] = dscale * sqrt(dsum);
6207 dif[2] = dif[1];
6208 }
6209 goto L60;
6210 }
6211
6212 /* Collect the selected blocks at the top-left corner of (A, B). */
6213
6214 ks = 0;
6215 pair = false;
6216 i__1 = *n;
6217 for (k = 1; k <= i__1; ++k) {
6218 if (pair) {
6219 pair = false;
6220 } else {
6221
6222 swap = select[k];
6223 if (k < *n) {
6224 if (a[k + 1 + k * a_dim1] != 0.) {
6225 pair = true;
6226 swap = swap || select[k + 1];
6227 }
6228 }
6229
6230 if (swap) {
6231 ++ks;
6232
6233 /* Swap the K-th block to position KS. */
6234 /* Perform the reordering of diagonal blocks in (A, B) */
6235 /* by orthogonal transformation matrices and update */
6236 /* Q and Z accordingly (if requested): */
6237
6238 kk = k;
6239 if (k != ks) {
6240 dtgexc_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset],
6241 ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &kk,
6242 &ks, &work[1], lwork, &ierr);
6243 }
6244
6245 if (ierr > 0) {
6246
6247 /* Swap is rejected: exit. */
6248
6249 *info = 1;
6250 if (wantp) {
6251 *pl = 0.;
6252 *pr = 0.;
6253 }
6254 if (wantd) {
6255 dif[1] = 0.;
6256 dif[2] = 0.;
6257 }
6258 goto L60;
6259 }
6260
6261 if (pair) {
6262 ++ks;
6263 }
6264 }
6265 }
6266 /* L30: */
6267 }
6268 if (wantp) {
6269
6270 /* Solve generalized Sylvester equation for R and L */
6271 /* and compute PL and PR. */
6272
6273 n1 = *m;
6274 n2 = *n - *m;
6275 i__ = n1 + 1;
6276 ijb = 0;
6277 dlacpy_("Full", &n1, &n2, &a[i__ * a_dim1 + 1], lda, &work[1], &n1);
6278 dlacpy_("Full", &n1, &n2, &b[i__ * b_dim1 + 1], ldb, &work[n1 * n2 +
6279 1], &n1);
6280 i__1 = *lwork - (n1 << 1) * n2;
6281 dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ * a_dim1]
6282 , lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ + i__ *
6283 b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, &dif[1], &
6284 work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], &ierr);
6285
6286 /* Estimate the reciprocal of norms of "projections" onto left */
6287 /* and right eigenspaces. */
6288
6289 rdscal = 0.;
6290 dsum = 1.;
6291 i__1 = n1 * n2;
6292 dlassq_(&i__1, &work[1], &c__1, &rdscal, &dsum);
6293 *pl = rdscal * sqrt(dsum);
6294 if (*pl == 0.) {
6295 *pl = 1.;
6296 } else {
6297 *pl = dscale / (sqrt(dscale * dscale / *pl + *pl) * sqrt(*pl));
6298 }
6299 rdscal = 0.;
6300 dsum = 1.;
6301 i__1 = n1 * n2;
6302 dlassq_(&i__1, &work[n1 * n2 + 1], &c__1, &rdscal, &dsum);
6303 *pr = rdscal * sqrt(dsum);
6304 if (*pr == 0.) {
6305 *pr = 1.;
6306 } else {
6307 *pr = dscale / (sqrt(dscale * dscale / *pr + *pr) * sqrt(*pr));
6308 }
6309 }
6310
6311 if (wantd) {
6312
6313 /* Compute estimates of Difu and Difl. */
6314
6315 if (wantd1) {
6316 n1 = *m;
6317 n2 = *n - *m;
6318 i__ = n1 + 1;
6319 ijb = 3;
6320
6321 /* Frobenius norm-based Difu-estimate. */
6322
6323 i__1 = *lwork - (n1 << 1) * n2;
6324 dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ *
6325 a_dim1], lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ +
6326 i__ * b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, &
6327 dif[1], &work[(n1 << 1) * n2 + 1], &i__1, &iwork[1], &
6328 ierr);
6329
6330 /* Frobenius norm-based Difl-estimate. */
6331
6332 i__1 = *lwork - (n1 << 1) * n2;
6333 dtgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda, &a[
6334 a_offset], lda, &work[1], &n2, &b[i__ + i__ * b_dim1],
6335 ldb, &b[b_offset], ldb, &work[n1 * n2 + 1], &n2, &dscale,
6336 &dif[2], &work[(n1 << 1) * n2 + 1], &i__1, &iwork[1], &
6337 ierr);
6338 } else {
6339
6340
6341 /* Compute 1-norm-based estimates of Difu and Difl using */
6342 /* reversed communication with DLACN2. In each step a */
6343 /* generalized Sylvester equation or a transposed variant */
6344 /* is solved. */
6345
6346 kase = 0;
6347 n1 = *m;
6348 n2 = *n - *m;
6349 i__ = n1 + 1;
6350 ijb = 0;
6351 mn2 = (n1 << 1) * n2;
6352
6353 /* 1-norm-based estimate of Difu. */
6354
6355 L40:
6356 dlacn2_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[1], &kase,
6357 isave);
6358 if (kase != 0) {
6359 if (kase == 1) {
6360
6361 /* Solve generalized Sylvester equation. */
6362
6363 i__1 = *lwork - (n1 << 1) * n2;
6364 dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ +
6365 i__ * a_dim1], lda, &work[1], &n1, &b[b_offset],
6366 ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 +
6367 1], &n1, &dscale, &dif[1], &work[(n1 << 1) * n2 +
6368 1], &i__1, &iwork[1], &ierr);
6369 } else {
6370
6371 /* Solve the transposed variant. */
6372
6373 i__1 = *lwork - (n1 << 1) * n2;
6374 dtgsyl_("T", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ +
6375 i__ * a_dim1], lda, &work[1], &n1, &b[b_offset],
6376 ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 +
6377 1], &n1, &dscale, &dif[1], &work[(n1 << 1) * n2 +
6378 1], &i__1, &iwork[1], &ierr);
6379 }
6380 goto L40;
6381 }
6382 dif[1] = dscale / dif[1];
6383
6384 /* 1-norm-based estimate of Difl. */
6385
6386 L50:
6387 dlacn2_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[2], &kase,
6388 isave);
6389 if (kase != 0) {
6390 if (kase == 1) {
6391
6392 /* Solve generalized Sylvester equation. */
6393
6394 i__1 = *lwork - (n1 << 1) * n2;
6395 dtgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda,
6396 &a[a_offset], lda, &work[1], &n2, &b[i__ + i__ *
6397 b_dim1], ldb, &b[b_offset], ldb, &work[n1 * n2 +
6398 1], &n2, &dscale, &dif[2], &work[(n1 << 1) * n2 +
6399 1], &i__1, &iwork[1], &ierr);
6400 } else {
6401
6402 /* Solve the transposed variant. */
6403
6404 i__1 = *lwork - (n1 << 1) * n2;
6405 dtgsyl_("T", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda,
6406 &a[a_offset], lda, &work[1], &n2, &b[i__ + i__ *
6407 b_dim1], ldb, &b[b_offset], ldb, &work[n1 * n2 +
6408 1], &n2, &dscale, &dif[2], &work[(n1 << 1) * n2 +
6409 1], &i__1, &iwork[1], &ierr);
6410 }
6411 goto L50;
6412 }
6413 dif[2] = dscale / dif[2];
6414
6415 }
6416 }
6417
6418 L60:
6419
6420 /* Compute generalized eigenvalues of reordered pair (A, B) and */
6421 /* normalize the generalized Schur form. */
6422
6423 pair = false;
6424 i__1 = *n;
6425 for (k = 1; k <= i__1; ++k) {
6426 if (pair) {
6427 pair = false;
6428 } else {
6429
6430 if (k < *n) {
6431 if (a[k + 1 + k * a_dim1] != 0.) {
6432 pair = true;
6433 }
6434 }
6435
6436 if (pair) {
6437
6438 /* Compute the eigenvalue(s) at position K. */
6439
6440 work[1] = a[k + k * a_dim1];
6441 work[2] = a[k + 1 + k * a_dim1];
6442 work[3] = a[k + (k + 1) * a_dim1];
6443 work[4] = a[k + 1 + (k + 1) * a_dim1];
6444 work[5] = b[k + k * b_dim1];
6445 work[6] = b[k + 1 + k * b_dim1];
6446 work[7] = b[k + (k + 1) * b_dim1];
6447 work[8] = b[k + 1 + (k + 1) * b_dim1];
6448 d__1 = smlnum * eps;
6449 dlag2_(&work[1], &c__2, &work[5], &c__2, &d__1, &beta[k], &
6450 beta[k + 1], &alphar[k], &alphar[k + 1], &alphai[k]);
6451 alphai[k + 1] = -alphai[k];
6452
6453 } else {
6454
6455 if (d_sign(&c_b28, &b[k + k * b_dim1]) < 0.) {
6456
6457 /* If B(K,K) is negative, make it positive */
6458
6459 i__2 = *n;
6460 for (i__ = 1; i__ <= i__2; ++i__) {
6461 a[k + i__ * a_dim1] = -a[k + i__ * a_dim1];
6462 b[k + i__ * b_dim1] = -b[k + i__ * b_dim1];
6463 q[i__ + k * q_dim1] = -q[i__ + k * q_dim1];
6464 /* L70: */
6465 }
6466 }
6467
6468 alphar[k] = a[k + k * a_dim1];
6469 alphai[k] = 0.;
6470 beta[k] = b[k + k * b_dim1];
6471
6472 }
6473 }
6474 /* L80: */
6475 }
6476
6477 work[1] = (double) lwmin;
6478 iwork[1] = liwmin;
6479
6480 return 0;
6481
6482 /* End of DTGSEN */
6483
6484 } /* dtgsen_ */
6485
dtgsja_(const char * jobu,const char * jobv,const char * jobq,integer * m,integer * p,integer * n,integer * k,integer * l,double * a,integer * lda,double * b,integer * ldb,double * tola,double * tolb,double * alpha,double * beta,double * u,integer * ldu,double * v,integer * ldv,double * q,integer * ldq,double * work,integer * ncycle,integer * info)6486 /* Subroutine */ int dtgsja_(const char *jobu, const char *jobv, const char *jobq, integer *m,
6487 integer *p, integer *n, integer *k, integer *l, double *a,
6488 integer *lda, double *b, integer *ldb, double *tola,
6489 double *tolb, double *alpha, double *beta, double *u,
6490 integer *ldu, double *v, integer *ldv, double *q, integer *
6491 ldq, double *work, integer *ncycle, integer *info)
6492 {
6493 /* Table of constant values */
6494 static double c_b13 = 0.;
6495 static double c_b14 = 1.;
6496 static integer c__1 = 1;
6497 static double c_b43 = -1.;
6498
6499 /* System generated locals */
6500 integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1,
6501 u_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4;
6502 double d__1;
6503
6504 /* Local variables */
6505 integer i__, j;
6506 double a1, a2, a3, b1, b2, b3, csq, csu, csv, snq, rwk, snu, snv;
6507 double gamma;
6508 bool initq, initu, initv, wantq, upper;
6509 double error, ssmin;
6510 bool wantu, wantv;
6511 integer kcycle;
6512
6513 /* -- LAPACK routine (version 3.1) -- */
6514 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
6515 /* November 2006 */
6516
6517 /* .. Scalar Arguments .. */
6518 /* .. */
6519 /* .. Array Arguments .. */
6520 /* .. */
6521
6522 /* Purpose */
6523 /* ======= */
6524
6525 /* DTGSJA computes the generalized singular value decomposition (GSVD) */
6526 /* of two real upper triangular (or trapezoidal) matrices A and B. */
6527
6528 /* On entry, it is assumed that matrices A and B have the following */
6529 /* forms, which may be obtained by the preprocessing subroutine DGGSVP */
6530 /* from a general M-by-N matrix A and P-by-N matrix B: */
6531
6532 /* N-K-L K L */
6533 /* A = K ( 0 A12 A13 ) if M-K-L >= 0; */
6534 /* L ( 0 0 A23 ) */
6535 /* M-K-L ( 0 0 0 ) */
6536
6537 /* N-K-L K L */
6538 /* A = K ( 0 A12 A13 ) if M-K-L < 0; */
6539 /* M-K ( 0 0 A23 ) */
6540
6541 /* N-K-L K L */
6542 /* B = L ( 0 0 B13 ) */
6543 /* P-L ( 0 0 0 ) */
6544
6545 /* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */
6546 /* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */
6547 /* otherwise A23 is (M-K)-by-L upper trapezoidal. */
6548
6549 /* On exit, */
6550
6551 /* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ), */
6552
6553 /* where U, V and Q are orthogonal matrices, Z' denotes the transpose */
6554 /* of Z, R is a nonsingular upper triangular matrix, and D1 and D2 are */
6555 /* ``diagonal'' matrices, which are of the following structures: */
6556
6557 /* If M-K-L >= 0, */
6558
6559 /* K L */
6560 /* D1 = K ( I 0 ) */
6561 /* L ( 0 C ) */
6562 /* M-K-L ( 0 0 ) */
6563
6564 /* K L */
6565 /* D2 = L ( 0 S ) */
6566 /* P-L ( 0 0 ) */
6567
6568 /* N-K-L K L */
6569 /* ( 0 R ) = K ( 0 R11 R12 ) K */
6570 /* L ( 0 0 R22 ) L */
6571
6572 /* where */
6573
6574 /* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */
6575 /* S = diag( BETA(K+1), ... , BETA(K+L) ), */
6576 /* C**2 + S**2 = I. */
6577
6578 /* R is stored in A(1:K+L,N-K-L+1:N) on exit. */
6579
6580 /* If M-K-L < 0, */
6581
6582 /* K M-K K+L-M */
6583 /* D1 = K ( I 0 0 ) */
6584 /* M-K ( 0 C 0 ) */
6585
6586 /* K M-K K+L-M */
6587 /* D2 = M-K ( 0 S 0 ) */
6588 /* K+L-M ( 0 0 I ) */
6589 /* P-L ( 0 0 0 ) */
6590
6591 /* N-K-L K M-K K+L-M */
6592 /* ( 0 R ) = K ( 0 R11 R12 R13 ) */
6593 /* M-K ( 0 0 R22 R23 ) */
6594 /* K+L-M ( 0 0 0 R33 ) */
6595
6596 /* where */
6597 /* C = diag( ALPHA(K+1), ... , ALPHA(M) ), */
6598 /* S = diag( BETA(K+1), ... , BETA(M) ), */
6599 /* C**2 + S**2 = I. */
6600
6601 /* R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored */
6602 /* ( 0 R22 R23 ) */
6603 /* in B(M-K+1:L,N+M-K-L+1:N) on exit. */
6604
6605 /* The computation of the orthogonal transformation matrices U, V or Q */
6606 /* is optional. These matrices may either be formed explicitly, or they */
6607 /* may be postmultiplied into input matrices U1, V1, or Q1. */
6608
6609 /* Arguments */
6610 /* ========= */
6611
6612 /* JOBU (input) CHARACTER*1 */
6613 /* = 'U': U must contain an orthogonal matrix U1 on entry, and */
6614 /* the product U1*U is returned; */
6615 /* = 'I': U is initialized to the unit matrix, and the */
6616 /* orthogonal matrix U is returned; */
6617 /* = 'N': U is not computed. */
6618
6619 /* JOBV (input) CHARACTER*1 */
6620 /* = 'V': V must contain an orthogonal matrix V1 on entry, and */
6621 /* the product V1*V is returned; */
6622 /* = 'I': V is initialized to the unit matrix, and the */
6623 /* orthogonal matrix V is returned; */
6624 /* = 'N': V is not computed. */
6625
6626 /* JOBQ (input) CHARACTER*1 */
6627 /* = 'Q': Q must contain an orthogonal matrix Q1 on entry, and */
6628 /* the product Q1*Q is returned; */
6629 /* = 'I': Q is initialized to the unit matrix, and the */
6630 /* orthogonal matrix Q is returned; */
6631 /* = 'N': Q is not computed. */
6632
6633 /* M (input) INTEGER */
6634 /* The number of rows of the matrix A. M >= 0. */
6635
6636 /* P (input) INTEGER */
6637 /* The number of rows of the matrix B. P >= 0. */
6638
6639 /* N (input) INTEGER */
6640 /* The number of columns of the matrices A and B. N >= 0. */
6641
6642 /* K (input) INTEGER */
6643 /* L (input) INTEGER */
6644 /* K and L specify the subblocks in the input matrices A and B: */
6645 /* A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N) */
6646 /* of A and B, whose GSVD is going to be computed by DTGSJA. */
6647 /* See Further details. */
6648
6649 /* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
6650 /* On entry, the M-by-N matrix A. */
6651 /* On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular */
6652 /* matrix R or part of R. See Purpose for details. */
6653
6654 /* LDA (input) INTEGER */
6655 /* The leading dimension of the array A. LDA >= max(1,M). */
6656
6657 /* B (input/output) DOUBLE PRECISION array, dimension (LDB,N) */
6658 /* On entry, the P-by-N matrix B. */
6659 /* On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains */
6660 /* a part of R. See Purpose for details. */
6661
6662 /* LDB (input) INTEGER */
6663 /* The leading dimension of the array B. LDB >= max(1,P). */
6664
6665 /* TOLA (input) DOUBLE PRECISION */
6666 /* TOLB (input) DOUBLE PRECISION */
6667 /* TOLA and TOLB are the convergence criteria for the Jacobi- */
6668 /* Kogbetliantz iteration procedure. Generally, they are the */
6669 /* same as used in the preprocessing step, say */
6670 /* TOLA = max(M,N)*norm(A)*MAZHEPS, */
6671 /* TOLB = max(P,N)*norm(B)*MAZHEPS. */
6672
6673 /* ALPHA (output) DOUBLE PRECISION array, dimension (N) */
6674 /* BETA (output) DOUBLE PRECISION array, dimension (N) */
6675 /* On exit, ALPHA and BETA contain the generalized singular */
6676 /* value pairs of A and B; */
6677 /* ALPHA(1:K) = 1, */
6678 /* BETA(1:K) = 0, */
6679 /* and if M-K-L >= 0, */
6680 /* ALPHA(K+1:K+L) = diag(C), */
6681 /* BETA(K+1:K+L) = diag(S), */
6682 /* or if M-K-L < 0, */
6683 /* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0 */
6684 /* BETA(K+1:M) = S, BETA(M+1:K+L) = 1. */
6685 /* Furthermore, if K+L < N, */
6686 /* ALPHA(K+L+1:N) = 0 and */
6687 /* BETA(K+L+1:N) = 0. */
6688
6689 /* U (input/output) DOUBLE PRECISION array, dimension (LDU,M) */
6690 /* On entry, if JOBU = 'U', U must contain a matrix U1 (usually */
6691 /* the orthogonal matrix returned by DGGSVP). */
6692 /* On exit, */
6693 /* if JOBU = 'I', U contains the orthogonal matrix U; */
6694 /* if JOBU = 'U', U contains the product U1*U. */
6695 /* If JOBU = 'N', U is not referenced. */
6696
6697 /* LDU (input) INTEGER */
6698 /* The leading dimension of the array U. LDU >= max(1,M) if */
6699 /* JOBU = 'U'; LDU >= 1 otherwise. */
6700
6701 /* V (input/output) DOUBLE PRECISION array, dimension (LDV,P) */
6702 /* On entry, if JOBV = 'V', V must contain a matrix V1 (usually */
6703 /* the orthogonal matrix returned by DGGSVP). */
6704 /* On exit, */
6705 /* if JOBV = 'I', V contains the orthogonal matrix V; */
6706 /* if JOBV = 'V', V contains the product V1*V. */
6707 /* If JOBV = 'N', V is not referenced. */
6708
6709 /* LDV (input) INTEGER */
6710 /* The leading dimension of the array V. LDV >= max(1,P) if */
6711 /* JOBV = 'V'; LDV >= 1 otherwise. */
6712
6713 /* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */
6714 /* On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually */
6715 /* the orthogonal matrix returned by DGGSVP). */
6716 /* On exit, */
6717 /* if JOBQ = 'I', Q contains the orthogonal matrix Q; */
6718 /* if JOBQ = 'Q', Q contains the product Q1*Q. */
6719 /* If JOBQ = 'N', Q is not referenced. */
6720
6721 /* LDQ (input) INTEGER */
6722 /* The leading dimension of the array Q. LDQ >= max(1,N) if */
6723 /* JOBQ = 'Q'; LDQ >= 1 otherwise. */
6724
6725 /* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
6726
6727 /* NCYCLE (output) INTEGER */
6728 /* The number of cycles required for convergence. */
6729
6730 /* INFO (output) INTEGER */
6731 /* = 0: successful exit */
6732 /* < 0: if INFO = -i, the i-th argument had an illegal value. */
6733 /* = 1: the procedure does not converge after MAXIT cycles. */
6734
6735 /* Internal Parameters */
6736 /* =================== */
6737
6738 /* MAXIT INTEGER */
6739 /* MAXIT specifies the total loops that the iterative procedure */
6740 /* may take. If after MAXIT cycles, the routine fails to */
6741 /* converge, we return INFO = 1. */
6742
6743 /* Further Details */
6744 /* =============== */
6745
6746 /* DTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce */
6747 /* min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L */
6748 /* matrix B13 to the form: */
6749
6750 /* U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1, */
6751
6752 /* where U1, V1 and Q1 are orthogonal matrix, and Z' is the transpose */
6753 /* of Z. C1 and S1 are diagonal matrices satisfying */
6754
6755 /* C1**2 + S1**2 = I, */
6756
6757 /* and R1 is an L-by-L nonsingular upper triangular matrix. */
6758
6759 /* ===================================================================== */
6760
6761 /* .. Parameters .. */
6762 /* .. */
6763 /* .. Local Scalars .. */
6764
6765 /* .. */
6766 /* .. External Functions .. */
6767 /* .. */
6768 /* .. External Subroutines .. */
6769 /* .. */
6770 /* .. Intrinsic Functions .. */
6771 /* .. */
6772 /* .. Executable Statements .. */
6773
6774 /* Decode and test the input parameters */
6775
6776 /* Parameter adjustments */
6777 a_dim1 = *lda;
6778 a_offset = 1 + a_dim1;
6779 a -= a_offset;
6780 b_dim1 = *ldb;
6781 b_offset = 1 + b_dim1;
6782 b -= b_offset;
6783 --alpha;
6784 --beta;
6785 u_dim1 = *ldu;
6786 u_offset = 1 + u_dim1;
6787 u -= u_offset;
6788 v_dim1 = *ldv;
6789 v_offset = 1 + v_dim1;
6790 v -= v_offset;
6791 q_dim1 = *ldq;
6792 q_offset = 1 + q_dim1;
6793 q -= q_offset;
6794 --work;
6795
6796 /* Function Body */
6797 initu = lsame_(jobu, "I");
6798 wantu = initu || lsame_(jobu, "U");
6799
6800 initv = lsame_(jobv, "I");
6801 wantv = initv || lsame_(jobv, "V");
6802
6803 initq = lsame_(jobq, "I");
6804 wantq = initq || lsame_(jobq, "Q");
6805
6806 *info = 0;
6807 if (! (initu || wantu || lsame_(jobu, "N"))) {
6808 *info = -1;
6809 } else if (! (initv || wantv || lsame_(jobv, "N")))
6810 {
6811 *info = -2;
6812 } else if (! (initq || wantq || lsame_(jobq, "N")))
6813 {
6814 *info = -3;
6815 } else if (*m < 0) {
6816 *info = -4;
6817 } else if (*p < 0) {
6818 *info = -5;
6819 } else if (*n < 0) {
6820 *info = -6;
6821 } else if (*lda < std::max(1_integer,*m)) {
6822 *info = -10;
6823 } else if (*ldb < std::max(1_integer,*p)) {
6824 *info = -12;
6825 } else if (*ldu < 1 || wantu && *ldu < *m) {
6826 *info = -18;
6827 } else if (*ldv < 1 || wantv && *ldv < *p) {
6828 *info = -20;
6829 } else if (*ldq < 1 || wantq && *ldq < *n) {
6830 *info = -22;
6831 }
6832 if (*info != 0) {
6833 i__1 = -(*info);
6834 xerbla_("DTGSJA", &i__1);
6835 return 0;
6836 }
6837
6838 /* Initialize U, V and Q, if necessary */
6839
6840 if (initu) {
6841 dlaset_("Full", m, m, &c_b13, &c_b14, &u[u_offset], ldu);
6842 }
6843 if (initv) {
6844 dlaset_("Full", p, p, &c_b13, &c_b14, &v[v_offset], ldv);
6845 }
6846 if (initq) {
6847 dlaset_("Full", n, n, &c_b13, &c_b14, &q[q_offset], ldq);
6848 }
6849
6850 /* Loop until convergence */
6851
6852 upper = false;
6853 for (kcycle = 1; kcycle <= 40; ++kcycle) {
6854
6855 upper = ! upper;
6856
6857 i__1 = *l - 1;
6858 for (i__ = 1; i__ <= i__1; ++i__) {
6859 i__2 = *l;
6860 for (j = i__ + 1; j <= i__2; ++j) {
6861
6862 a1 = 0.;
6863 a2 = 0.;
6864 a3 = 0.;
6865 if (*k + i__ <= *m) {
6866 a1 = a[*k + i__ + (*n - *l + i__) * a_dim1];
6867 }
6868 if (*k + j <= *m) {
6869 a3 = a[*k + j + (*n - *l + j) * a_dim1];
6870 }
6871
6872 b1 = b[i__ + (*n - *l + i__) * b_dim1];
6873 b3 = b[j + (*n - *l + j) * b_dim1];
6874
6875 if (upper) {
6876 if (*k + i__ <= *m) {
6877 a2 = a[*k + i__ + (*n - *l + j) * a_dim1];
6878 }
6879 b2 = b[i__ + (*n - *l + j) * b_dim1];
6880 } else {
6881 if (*k + j <= *m) {
6882 a2 = a[*k + j + (*n - *l + i__) * a_dim1];
6883 }
6884 b2 = b[j + (*n - *l + i__) * b_dim1];
6885 }
6886
6887 dlags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, &
6888 csv, &snv, &csq, &snq);
6889
6890 /* Update (K+I)-th and (K+J)-th rows of matrix A: U'*A */
6891
6892 if (*k + j <= *m) {
6893 drot_(l, &a[*k + j + (*n - *l + 1) * a_dim1], lda, &a[*k
6894 + i__ + (*n - *l + 1) * a_dim1], lda, &csu, &snu);
6895 }
6896
6897 /* Update I-th and J-th rows of matrix B: V'*B */
6898
6899 drot_(l, &b[j + (*n - *l + 1) * b_dim1], ldb, &b[i__ + (*n - *
6900 l + 1) * b_dim1], ldb, &csv, &snv);
6901
6902 /* Update (N-L+I)-th and (N-L+J)-th columns of matrices */
6903 /* A and B: A*Q and B*Q */
6904
6905 /* Computing MIN */
6906 i__4 = *k + *l;
6907 i__3 = std::min(i__4,*m);
6908 drot_(&i__3, &a[(*n - *l + j) * a_dim1 + 1], &c__1, &a[(*n - *
6909 l + i__) * a_dim1 + 1], &c__1, &csq, &snq);
6910
6911 drot_(l, &b[(*n - *l + j) * b_dim1 + 1], &c__1, &b[(*n - *l +
6912 i__) * b_dim1 + 1], &c__1, &csq, &snq);
6913
6914 if (upper) {
6915 if (*k + i__ <= *m) {
6916 a[*k + i__ + (*n - *l + j) * a_dim1] = 0.;
6917 }
6918 b[i__ + (*n - *l + j) * b_dim1] = 0.;
6919 } else {
6920 if (*k + j <= *m) {
6921 a[*k + j + (*n - *l + i__) * a_dim1] = 0.;
6922 }
6923 b[j + (*n - *l + i__) * b_dim1] = 0.;
6924 }
6925
6926 /* Update orthogonal matrices U, V, Q, if desired. */
6927
6928 if (wantu && *k + j <= *m) {
6929 drot_(m, &u[(*k + j) * u_dim1 + 1], &c__1, &u[(*k + i__) *
6930 u_dim1 + 1], &c__1, &csu, &snu);
6931 }
6932
6933 if (wantv) {
6934 drot_(p, &v[j * v_dim1 + 1], &c__1, &v[i__ * v_dim1 + 1],
6935 &c__1, &csv, &snv);
6936 }
6937
6938 if (wantq) {
6939 drot_(n, &q[(*n - *l + j) * q_dim1 + 1], &c__1, &q[(*n - *
6940 l + i__) * q_dim1 + 1], &c__1, &csq, &snq);
6941 }
6942
6943 /* L10: */
6944 }
6945 /* L20: */
6946 }
6947
6948 if (! upper) {
6949
6950 /* The matrices A13 and B13 were lower triangular at the start */
6951 /* of the cycle, and are now upper triangular. */
6952
6953 /* Convergence test: test the parallelism of the corresponding */
6954 /* rows of A and B. */
6955
6956 error = 0.;
6957 /* Computing MIN */
6958 i__2 = *l, i__3 = *m - *k;
6959 i__1 = std::min(i__2,i__3);
6960 for (i__ = 1; i__ <= i__1; ++i__) {
6961 i__2 = *l - i__ + 1;
6962 dcopy_(&i__2, &a[*k + i__ + (*n - *l + i__) * a_dim1], lda, &
6963 work[1], &c__1);
6964 i__2 = *l - i__ + 1;
6965 dcopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &work[*
6966 l + 1], &c__1);
6967 i__2 = *l - i__ + 1;
6968 dlapll_(&i__2, &work[1], &c__1, &work[*l + 1], &c__1, &ssmin);
6969 error = std::max(error,ssmin);
6970 /* L30: */
6971 }
6972
6973 if (abs(error) <= std::min(*tola,*tolb)) {
6974 goto L50;
6975 }
6976 }
6977
6978 /* End of cycle loop */
6979
6980 /* L40: */
6981 }
6982
6983 /* The algorithm has not converged after MAXIT cycles. */
6984
6985 *info = 1;
6986 goto L100;
6987
6988 L50:
6989
6990 /* If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged. */
6991 /* Compute the generalized singular value pairs (ALPHA, BETA), and */
6992 /* set the triangular matrix R to array A. */
6993
6994 i__1 = *k;
6995 for (i__ = 1; i__ <= i__1; ++i__) {
6996 alpha[i__] = 1.;
6997 beta[i__] = 0.;
6998 /* L60: */
6999 }
7000
7001 /* Computing MIN */
7002 i__2 = *l, i__3 = *m - *k;
7003 i__1 = std::min(i__2,i__3);
7004 for (i__ = 1; i__ <= i__1; ++i__) {
7005
7006 a1 = a[*k + i__ + (*n - *l + i__) * a_dim1];
7007 b1 = b[i__ + (*n - *l + i__) * b_dim1];
7008
7009 if (a1 != 0.) {
7010 gamma = b1 / a1;
7011
7012 /* change sign if necessary */
7013
7014 if (gamma < 0.) {
7015 i__2 = *l - i__ + 1;
7016 dscal_(&i__2, &c_b43, &b[i__ + (*n - *l + i__) * b_dim1], ldb)
7017 ;
7018 if (wantv) {
7019 dscal_(p, &c_b43, &v[i__ * v_dim1 + 1], &c__1);
7020 }
7021 }
7022
7023 d__1 = abs(gamma);
7024 dlartg_(&d__1, &c_b14, &beta[*k + i__], &alpha[*k + i__], &rwk);
7025
7026 if (alpha[*k + i__] >= beta[*k + i__]) {
7027 i__2 = *l - i__ + 1;
7028 d__1 = 1. / alpha[*k + i__];
7029 dscal_(&i__2, &d__1, &a[*k + i__ + (*n - *l + i__) * a_dim1],
7030 lda);
7031 } else {
7032 i__2 = *l - i__ + 1;
7033 d__1 = 1. / beta[*k + i__];
7034 dscal_(&i__2, &d__1, &b[i__ + (*n - *l + i__) * b_dim1], ldb);
7035 i__2 = *l - i__ + 1;
7036 dcopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k
7037 + i__ + (*n - *l + i__) * a_dim1], lda);
7038 }
7039
7040 } else {
7041
7042 alpha[*k + i__] = 0.;
7043 beta[*k + i__] = 1.;
7044 i__2 = *l - i__ + 1;
7045 dcopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k +
7046 i__ + (*n - *l + i__) * a_dim1], lda);
7047
7048 }
7049
7050 /* L70: */
7051 }
7052
7053 /* Post-assignment */
7054
7055 i__1 = *k + *l;
7056 for (i__ = *m + 1; i__ <= i__1; ++i__) {
7057 alpha[i__] = 0.;
7058 beta[i__] = 1.;
7059 /* L80: */
7060 }
7061
7062 if (*k + *l < *n) {
7063 i__1 = *n;
7064 for (i__ = *k + *l + 1; i__ <= i__1; ++i__) {
7065 alpha[i__] = 0.;
7066 beta[i__] = 0.;
7067 /* L90: */
7068 }
7069 }
7070
7071 L100:
7072 *ncycle = kcycle;
7073 return 0;
7074
7075 /* End of DTGSJA */
7076
7077 } /* dtgsja_ */
7078
dtgsna_(const char * job,const char * howmny,bool * select,integer * n,double * a,integer * lda,double * b,integer * ldb,double * vl,integer * ldvl,double * vr,integer * ldvr,double * s,double * dif,integer * mm,integer * m,double * work,integer * lwork,integer * iwork,integer * info)7079 /* Subroutine */ int dtgsna_(const char *job, const char *howmny, bool *select,
7080 integer *n, double *a, integer *lda, double *b, integer *ldb,
7081 double *vl, integer *ldvl, double *vr, integer *ldvr,
7082 double *s, double *dif, integer *mm, integer *m, double *
7083 work, integer *lwork, integer *iwork, integer *info)
7084 {
7085 /* Table of constant values */
7086 static integer c__1 = 1;
7087 static double c_b19 = 1.;
7088 static double c_b21 = 0.;
7089 static integer c__2 = 2;
7090 static bool c_false = false;
7091 static integer c__3 = 3;
7092
7093 /* System generated locals */
7094 integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
7095 vr_offset, i__1, i__2;
7096 double d__1, d__2;
7097
7098 /* Local variables */
7099 integer i__, k;
7100 double c1, c2;
7101 integer n1, n2, ks, iz;
7102 double eps, beta, cond;
7103 bool pair;
7104 integer ierr;
7105 double uhav, uhbv;
7106 integer ifst;
7107 double lnrm;
7108 integer ilst;
7109 double rnrm;
7110 double root1, root2, scale;
7111 double uhavi, uhbvi, tmpii;
7112 integer lwmin;
7113 bool wants;
7114 double tmpir, tmpri, dummy[1], tmprr;
7115 double dummy1[1];
7116 double alphai, alphar;
7117 bool wantbh, wantdf, somcon;
7118 double alprqt;
7119 double smlnum;
7120 bool lquery;
7121
7122
7123 /* -- LAPACK routine (version 3.1) -- */
7124 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
7125 /* November 2006 */
7126
7127 /* .. Scalar Arguments .. */
7128 /* .. */
7129 /* .. Array Arguments .. */
7130 /* .. */
7131
7132 /* Purpose */
7133 /* ======= */
7134
7135 /* DTGSNA estimates reciprocal condition numbers for specified */
7136 /* eigenvalues and/or eigenvectors of a matrix pair (A, B) in */
7137 /* generalized real Schur canonical form (or of any matrix pair */
7138 /* (Q*A*Z', Q*B*Z') with orthogonal matrices Q and Z, where */
7139 /* Z' denotes the transpose of Z. */
7140
7141 /* (A, B) must be in generalized real Schur form (as returned by DGGES), */
7142 /* i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal */
7143 /* blocks. B is upper triangular. */
7144
7145
7146 /* Arguments */
7147 /* ========= */
7148
7149 /* JOB (input) CHARACTER*1 */
7150 /* Specifies whether condition numbers are required for */
7151 /* eigenvalues (S) or eigenvectors (DIF): */
7152 /* = 'E': for eigenvalues only (S); */
7153 /* = 'V': for eigenvectors only (DIF); */
7154 /* = 'B': for both eigenvalues and eigenvectors (S and DIF). */
7155
7156 /* HOWMNY (input) CHARACTER*1 */
7157 /* = 'A': compute condition numbers for all eigenpairs; */
7158 /* = 'S': compute condition numbers for selected eigenpairs */
7159 /* specified by the array SELECT. */
7160
7161 /* SELECT (input) LOGICAL array, dimension (N) */
7162 /* If HOWMNY = 'S', SELECT specifies the eigenpairs for which */
7163 /* condition numbers are required. To select condition numbers */
7164 /* for the eigenpair corresponding to a real eigenvalue w(j), */
7165 /* SELECT(j) must be set to .TRUE.. To select condition numbers */
7166 /* corresponding to a complex conjugate pair of eigenvalues w(j) */
7167 /* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be */
7168 /* set to .TRUE.. */
7169 /* If HOWMNY = 'A', SELECT is not referenced. */
7170
7171 /* N (input) INTEGER */
7172 /* The order of the square matrix pair (A, B). N >= 0. */
7173
7174 /* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
7175 /* The upper quasi-triangular matrix A in the pair (A,B). */
7176
7177 /* LDA (input) INTEGER */
7178 /* The leading dimension of the array A. LDA >= max(1,N). */
7179
7180 /* B (input) DOUBLE PRECISION array, dimension (LDB,N) */
7181 /* The upper triangular matrix B in the pair (A,B). */
7182
7183 /* LDB (input) INTEGER */
7184 /* The leading dimension of the array B. LDB >= max(1,N). */
7185
7186 /* VL (input) DOUBLE PRECISION array, dimension (LDVL,M) */
7187 /* If JOB = 'E' or 'B', VL must contain left eigenvectors of */
7188 /* (A, B), corresponding to the eigenpairs specified by HOWMNY */
7189 /* and SELECT. The eigenvectors must be stored in consecutive */
7190 /* columns of VL, as returned by DTGEVC. */
7191 /* If JOB = 'V', VL is not referenced. */
7192
7193 /* LDVL (input) INTEGER */
7194 /* The leading dimension of the array VL. LDVL >= 1. */
7195 /* If JOB = 'E' or 'B', LDVL >= N. */
7196
7197 /* VR (input) DOUBLE PRECISION array, dimension (LDVR,M) */
7198 /* If JOB = 'E' or 'B', VR must contain right eigenvectors of */
7199 /* (A, B), corresponding to the eigenpairs specified by HOWMNY */
7200 /* and SELECT. The eigenvectors must be stored in consecutive */
7201 /* columns ov VR, as returned by DTGEVC. */
7202 /* If JOB = 'V', VR is not referenced. */
7203
7204 /* LDVR (input) INTEGER */
7205 /* The leading dimension of the array VR. LDVR >= 1. */
7206 /* If JOB = 'E' or 'B', LDVR >= N. */
7207
7208 /* S (output) DOUBLE PRECISION array, dimension (MM) */
7209 /* If JOB = 'E' or 'B', the reciprocal condition numbers of the */
7210 /* selected eigenvalues, stored in consecutive elements of the */
7211 /* array. For a complex conjugate pair of eigenvalues two */
7212 /* consecutive elements of S are set to the same value. Thus */
7213 /* S(j), DIF(j), and the j-th columns of VL and VR all */
7214 /* correspond to the same eigenpair (but not in general the */
7215 /* j-th eigenpair, unless all eigenpairs are selected). */
7216 /* If JOB = 'V', S is not referenced. */
7217
7218 /* DIF (output) DOUBLE PRECISION array, dimension (MM) */
7219 /* If JOB = 'V' or 'B', the estimated reciprocal condition */
7220 /* numbers of the selected eigenvectors, stored in consecutive */
7221 /* elements of the array. For a complex eigenvector two */
7222 /* consecutive elements of DIF are set to the same value. If */
7223 /* the eigenvalues cannot be reordered to compute DIF(j), DIF(j) */
7224 /* is set to 0; this can only occur when the true value would be */
7225 /* very small anyway. */
7226 /* If JOB = 'E', DIF is not referenced. */
7227
7228 /* MM (input) INTEGER */
7229 /* The number of elements in the arrays S and DIF. MM >= M. */
7230
7231 /* M (output) INTEGER */
7232 /* The number of elements of the arrays S and DIF used to store */
7233 /* the specified condition numbers; for each selected real */
7234 /* eigenvalue one element is used, and for each selected complex */
7235 /* conjugate pair of eigenvalues, two elements are used. */
7236 /* If HOWMNY = 'A', M is set to N. */
7237
7238 /* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
7239 /* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
7240
7241 /* LWORK (input) INTEGER */
7242 /* The dimension of the array WORK. LWORK >= max(1,N). */
7243 /* If JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16. */
7244
7245 /* If LWORK = -1, then a workspace query is assumed; the routine */
7246 /* only calculates the optimal size of the WORK array, returns */
7247 /* this value as the first entry of the WORK array, and no error */
7248 /* message related to LWORK is issued by XERBLA. */
7249
7250 /* IWORK (workspace) INTEGER array, dimension (N + 6) */
7251 /* If JOB = 'E', IWORK is not referenced. */
7252
7253 /* INFO (output) INTEGER */
7254 /* =0: Successful exit */
7255 /* <0: If INFO = -i, the i-th argument had an illegal value */
7256
7257
7258 /* Further Details */
7259 /* =============== */
7260
7261 /* The reciprocal of the condition number of a generalized eigenvalue */
7262 /* w = (a, b) is defined as */
7263
7264 /* S(w) = (|u'Av|**2 + |u'Bv|**2)**(1/2) / (norm(u)*norm(v)) */
7265
7266 /* where u and v are the left and right eigenvectors of (A, B) */
7267 /* corresponding to w; |z| denotes the absolute value of the complex */
7268 /* number, and norm(u) denotes the 2-norm of the vector u. */
7269 /* The pair (a, b) corresponds to an eigenvalue w = a/b (= u'Av/u'Bv) */
7270 /* of the matrix pair (A, B). If both a and b equal zero, then (A B) is */
7271 /* singular and S(I) = -1 is returned. */
7272
7273 /* An approximate error bound on the chordal distance between the i-th */
7274 /* computed generalized eigenvalue w and the corresponding exact */
7275 /* eigenvalue lambda is */
7276
7277 /* chord(w, lambda) <= EPS * norm(A, B) / S(I) */
7278
7279 /* where EPS is the machine precision. */
7280
7281 /* The reciprocal of the condition number DIF(i) of right eigenvector u */
7282 /* and left eigenvector v corresponding to the generalized eigenvalue w */
7283 /* is defined as follows: */
7284
7285 /* a) If the i-th eigenvalue w = (a,b) is real */
7286
7287 /* Suppose U and V are orthogonal transformations such that */
7288
7289 /* U'*(A, B)*V = (S, T) = ( a * ) ( b * ) 1 */
7290 /* ( 0 S22 ),( 0 T22 ) n-1 */
7291 /* 1 n-1 1 n-1 */
7292
7293 /* Then the reciprocal condition number DIF(i) is */
7294
7295 /* Difl((a, b), (S22, T22)) = sigma-min( Zl ), */
7296
7297 /* where sigma-min(Zl) denotes the smallest singular value of the */
7298 /* 2(n-1)-by-2(n-1) matrix */
7299
7300 /* Zl = [ kron(a, In-1) -kron(1, S22) ] */
7301 /* [ kron(b, In-1) -kron(1, T22) ] . */
7302
7303 /* Here In-1 is the identity matrix of size n-1. kron(X, Y) is the */
7304 /* Kronecker product between the matrices X and Y. */
7305
7306 /* Note that if the default method for computing DIF(i) is wanted */
7307 /* (see DLATDF), then the parameter DIFDRI (see below) should be */
7308 /* changed from 3 to 4 (routine DLATDF(IJOB = 2 will be used)). */
7309 /* See DTGSYL for more details. */
7310
7311 /* b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair, */
7312
7313 /* Suppose U and V are orthogonal transformations such that */
7314
7315 /* U'*(A, B)*V = (S, T) = ( S11 * ) ( T11 * ) 2 */
7316 /* ( 0 S22 ),( 0 T22) n-2 */
7317 /* 2 n-2 2 n-2 */
7318
7319 /* and (S11, T11) corresponds to the complex conjugate eigenvalue */
7320 /* pair (w, conjg(w)). There exist unitary matrices U1 and V1 such */
7321 /* that */
7322
7323 /* U1'*S11*V1 = ( s11 s12 ) and U1'*T11*V1 = ( t11 t12 ) */
7324 /* ( 0 s22 ) ( 0 t22 ) */
7325
7326 /* where the generalized eigenvalues w = s11/t11 and */
7327 /* conjg(w) = s22/t22. */
7328
7329 /* Then the reciprocal condition number DIF(i) is bounded by */
7330
7331 /* min( d1, max( 1, |real(s11)/real(s22)| )*d2 ) */
7332
7333 /* where, d1 = Difl((s11, t11), (s22, t22)) = sigma-min(Z1), where */
7334 /* Z1 is the complex 2-by-2 matrix */
7335
7336 /* Z1 = [ s11 -s22 ] */
7337 /* [ t11 -t22 ], */
7338
7339 /* This is done by computing (using real arithmetic) the */
7340 /* roots of the characteristical polynomial det(Z1' * Z1 - lambda I), */
7341 /* where Z1' denotes the conjugate transpose of Z1 and det(X) denotes */
7342 /* the determinant of X. */
7343
7344 /* and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an */
7345 /* upper bound on sigma-min(Z2), where Z2 is (2n-2)-by-(2n-2) */
7346
7347 /* Z2 = [ kron(S11', In-2) -kron(I2, S22) ] */
7348 /* [ kron(T11', In-2) -kron(I2, T22) ] */
7349
7350 /* Note that if the default method for computing DIF is wanted (see */
7351 /* DLATDF), then the parameter DIFDRI (see below) should be changed */
7352 /* from 3 to 4 (routine DLATDF(IJOB = 2 will be used)). See DTGSYL */
7353 /* for more details. */
7354
7355 /* For each eigenvalue/vector specified by SELECT, DIF stores a */
7356 /* Frobenius norm-based estimate of Difl. */
7357
7358 /* An approximate error bound for the i-th computed eigenvector VL(i) or */
7359 /* VR(i) is given by */
7360
7361 /* EPS * norm(A, B) / DIF(i). */
7362
7363 /* See ref. [2-3] for more details and further references. */
7364
7365 /* Based on contributions by */
7366 /* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
7367 /* Umea University, S-901 87 Umea, Sweden. */
7368
7369 /* References */
7370 /* ========== */
7371
7372 /* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
7373 /* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
7374 /* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
7375 /* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
7376
7377 /* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
7378 /* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
7379 /* Estimation: Theory, Algorithms and Software, */
7380 /* Report UMINF - 94.04, Department of Computing Science, Umea */
7381 /* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */
7382 /* Note 87. To appear in Numerical Algorithms, 1996. */
7383
7384 /* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */
7385 /* for Solving the Generalized Sylvester Equation and Estimating the */
7386 /* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */
7387 /* Department of Computing Science, Umea University, S-901 87 Umea, */
7388 /* Sweden, December 1993, Revised April 1994, Also as LAPACK Working */
7389 /* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, */
7390 /* No 1, 1996. */
7391
7392 /* ===================================================================== */
7393
7394 /* .. Parameters .. */
7395 /* .. */
7396 /* .. Local Scalars .. */
7397 /* .. */
7398 /* .. Local Arrays .. */
7399 /* .. */
7400 /* .. External Functions .. */
7401 /* .. */
7402 /* .. External Subroutines .. */
7403 /* .. */
7404 /* .. Intrinsic Functions .. */
7405 /* .. */
7406 /* .. Executable Statements .. */
7407
7408 /* Decode and test the input parameters */
7409
7410 /* Parameter adjustments */
7411 --select;
7412 a_dim1 = *lda;
7413 a_offset = 1 + a_dim1;
7414 a -= a_offset;
7415 b_dim1 = *ldb;
7416 b_offset = 1 + b_dim1;
7417 b -= b_offset;
7418 vl_dim1 = *ldvl;
7419 vl_offset = 1 + vl_dim1;
7420 vl -= vl_offset;
7421 vr_dim1 = *ldvr;
7422 vr_offset = 1 + vr_dim1;
7423 vr -= vr_offset;
7424 --s;
7425 --dif;
7426 --work;
7427 --iwork;
7428
7429 /* Function Body */
7430 wantbh = lsame_(job, "B");
7431 wants = lsame_(job, "E") || wantbh;
7432 wantdf = lsame_(job, "V") || wantbh;
7433
7434 somcon = lsame_(howmny, "S");
7435
7436 *info = 0;
7437 lquery = *lwork == -1;
7438
7439 if (! wants && ! wantdf) {
7440 *info = -1;
7441 } else if (! lsame_(howmny, "A") && ! somcon) {
7442 *info = -2;
7443 } else if (*n < 0) {
7444 *info = -4;
7445 } else if (*lda < std::max(1_integer,*n)) {
7446 *info = -6;
7447 } else if (*ldb < std::max(1_integer,*n)) {
7448 *info = -8;
7449 } else if (wants && *ldvl < *n) {
7450 *info = -10;
7451 } else if (wants && *ldvr < *n) {
7452 *info = -12;
7453 } else {
7454
7455 /* Set M to the number of eigenpairs for which condition numbers */
7456 /* are required, and test MM. */
7457
7458 if (somcon) {
7459 *m = 0;
7460 pair = false;
7461 i__1 = *n;
7462 for (k = 1; k <= i__1; ++k) {
7463 if (pair) {
7464 pair = false;
7465 } else {
7466 if (k < *n) {
7467 if (a[k + 1 + k * a_dim1] == 0.) {
7468 if (select[k]) {
7469 ++(*m);
7470 }
7471 } else {
7472 pair = true;
7473 if (select[k] || select[k + 1]) {
7474 *m += 2;
7475 }
7476 }
7477 } else {
7478 if (select[*n]) {
7479 ++(*m);
7480 }
7481 }
7482 }
7483 /* L10: */
7484 }
7485 } else {
7486 *m = *n;
7487 }
7488
7489 if (*n == 0) {
7490 lwmin = 1;
7491 } else if (lsame_(job, "V") || lsame_(job,
7492 "B")) {
7493 lwmin = (*n << 1) * (*n + 2) + 16;
7494 } else {
7495 lwmin = *n;
7496 }
7497 work[1] = (double) lwmin;
7498
7499 if (*mm < *m) {
7500 *info = -15;
7501 } else if (*lwork < lwmin && ! lquery) {
7502 *info = -18;
7503 }
7504 }
7505
7506 if (*info != 0) {
7507 i__1 = -(*info);
7508 xerbla_("DTGSNA", &i__1);
7509 return 0;
7510 } else if (lquery) {
7511 return 0;
7512 }
7513
7514 /* Quick return if possible */
7515
7516 if (*n == 0) {
7517 return 0;
7518 }
7519
7520 /* Get machine constants */
7521
7522 eps = dlamch_("P");
7523 smlnum = dlamch_("S") / eps;
7524 ks = 0;
7525 pair = false;
7526
7527 i__1 = *n;
7528 for (k = 1; k <= i__1; ++k) {
7529
7530 /* Determine whether A(k,k) begins a 1-by-1 or 2-by-2 block. */
7531
7532 if (pair) {
7533 pair = false;
7534 goto L20;
7535 } else {
7536 if (k < *n) {
7537 pair = a[k + 1 + k * a_dim1] != 0.;
7538 }
7539 }
7540
7541 /* Determine whether condition numbers are required for the k-th */
7542 /* eigenpair. */
7543
7544 if (somcon) {
7545 if (pair) {
7546 if (! select[k] && ! select[k + 1]) {
7547 goto L20;
7548 }
7549 } else {
7550 if (! select[k]) {
7551 goto L20;
7552 }
7553 }
7554 }
7555
7556 ++ks;
7557
7558 if (wants) {
7559
7560 /* Compute the reciprocal condition number of the k-th */
7561 /* eigenvalue. */
7562
7563 if (pair) {
7564
7565 /* Complex eigenvalue pair. */
7566
7567 d__1 = dnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1);
7568 d__2 = dnrm2_(n, &vr[(ks + 1) * vr_dim1 + 1], &c__1);
7569 rnrm = dlapy2_(&d__1, &d__2);
7570 d__1 = dnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1);
7571 d__2 = dnrm2_(n, &vl[(ks + 1) * vl_dim1 + 1], &c__1);
7572 lnrm = dlapy2_(&d__1, &d__2);
7573 dgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr[ks * vr_dim1
7574 + 1], &c__1, &c_b21, &work[1], &c__1);
7575 tmprr = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &
7576 c__1);
7577 tmpri = ddot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1],
7578 &c__1);
7579 dgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr[(ks + 1) *
7580 vr_dim1 + 1], &c__1, &c_b21, &work[1], &c__1);
7581 tmpii = ddot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1],
7582 &c__1);
7583 tmpir = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &
7584 c__1);
7585 uhav = tmprr + tmpii;
7586 uhavi = tmpir - tmpri;
7587 dgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr[ks * vr_dim1
7588 + 1], &c__1, &c_b21, &work[1], &c__1);
7589 tmprr = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &
7590 c__1);
7591 tmpri = ddot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1],
7592 &c__1);
7593 dgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr[(ks + 1) *
7594 vr_dim1 + 1], &c__1, &c_b21, &work[1], &c__1);
7595 tmpii = ddot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1],
7596 &c__1);
7597 tmpir = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &
7598 c__1);
7599 uhbv = tmprr + tmpii;
7600 uhbvi = tmpir - tmpri;
7601 uhav = dlapy2_(&uhav, &uhavi);
7602 uhbv = dlapy2_(&uhbv, &uhbvi);
7603 cond = dlapy2_(&uhav, &uhbv);
7604 s[ks] = cond / (rnrm * lnrm);
7605 s[ks + 1] = s[ks];
7606
7607 } else {
7608
7609 /* Real eigenvalue. */
7610
7611 rnrm = dnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1);
7612 lnrm = dnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1);
7613 dgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr[ks * vr_dim1
7614 + 1], &c__1, &c_b21, &work[1], &c__1);
7615 uhav = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &c__1)
7616 ;
7617 dgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr[ks * vr_dim1
7618 + 1], &c__1, &c_b21, &work[1], &c__1);
7619 uhbv = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &c__1)
7620 ;
7621 cond = dlapy2_(&uhav, &uhbv);
7622 if (cond == 0.) {
7623 s[ks] = -1.;
7624 } else {
7625 s[ks] = cond / (rnrm * lnrm);
7626 }
7627 }
7628 }
7629
7630 if (wantdf) {
7631 if (*n == 1) {
7632 dif[ks] = dlapy2_(&a[a_dim1 + 1], &b[b_dim1 + 1]);
7633 goto L20;
7634 }
7635
7636 /* Estimate the reciprocal condition number of the k-th */
7637 /* eigenvectors. */
7638 if (pair) {
7639
7640 /* Copy the 2-by 2 pencil beginning at (A(k,k), B(k, k)). */
7641 /* Compute the eigenvalue(s) at position K. */
7642
7643 work[1] = a[k + k * a_dim1];
7644 work[2] = a[k + 1 + k * a_dim1];
7645 work[3] = a[k + (k + 1) * a_dim1];
7646 work[4] = a[k + 1 + (k + 1) * a_dim1];
7647 work[5] = b[k + k * b_dim1];
7648 work[6] = b[k + 1 + k * b_dim1];
7649 work[7] = b[k + (k + 1) * b_dim1];
7650 work[8] = b[k + 1 + (k + 1) * b_dim1];
7651 d__1 = smlnum * eps;
7652 dlag2_(&work[1], &c__2, &work[5], &c__2, &d__1, &beta, dummy1,
7653 &alphar, dummy, &alphai);
7654 alprqt = 1.;
7655 c1 = (alphar * alphar + alphai * alphai + beta * beta) * 2.;
7656 c2 = beta * 4. * beta * alphai * alphai;
7657 root1 = c1 + sqrt(c1 * c1 - c2 * 4.);
7658 root2 = c2 / root1;
7659 root1 /= 2.;
7660 /* Computing MIN */
7661 d__1 = sqrt(root1), d__2 = sqrt(root2);
7662 cond = std::min(d__1,d__2);
7663 }
7664
7665 /* Copy the matrix (A, B) to the array WORK and swap the */
7666 /* diagonal block beginning at A(k,k) to the (1,1) position. */
7667
7668 dlacpy_("Full", n, n, &a[a_offset], lda, &work[1], n);
7669 dlacpy_("Full", n, n, &b[b_offset], ldb, &work[*n * *n + 1], n);
7670 ifst = k;
7671 ilst = 1;
7672
7673 i__2 = *lwork - (*n << 1) * *n;
7674 dtgexc_(&c_false, &c_false, n, &work[1], n, &work[*n * *n + 1], n,
7675 dummy, &c__1, dummy1, &c__1, &ifst, &ilst, &work[(*n * *
7676 n << 1) + 1], &i__2, &ierr);
7677
7678 if (ierr > 0) {
7679
7680 /* Ill-conditioned problem - swap rejected. */
7681
7682 dif[ks] = 0.;
7683 } else {
7684
7685 /* Reordering successful, solve generalized Sylvester */
7686 /* equation for R and L, */
7687 /* A22 * R - L * A11 = A12 */
7688 /* B22 * R - L * B11 = B12, */
7689 /* and compute estimate of Difl((A11,B11), (A22, B22)). */
7690
7691 n1 = 1;
7692 if (work[2] != 0.) {
7693 n1 = 2;
7694 }
7695 n2 = *n - n1;
7696 if (n2 == 0) {
7697 dif[ks] = cond;
7698 } else {
7699 i__ = *n * *n + 1;
7700 iz = (*n << 1) * *n + 1;
7701 i__2 = *lwork - (*n << 1) * *n;
7702 dtgsyl_("N", &c__3, &n2, &n1, &work[*n * n1 + n1 + 1], n,
7703 &work[1], n, &work[n1 + 1], n, &work[*n * n1 + n1
7704 + i__], n, &work[i__], n, &work[n1 + i__], n, &
7705 scale, &dif[ks], &work[iz + 1], &i__2, &iwork[1],
7706 &ierr);
7707
7708 if (pair) {
7709 /* Computing MIN */
7710 d__1 = std::max(1.,alprqt) * dif[ks];
7711 dif[ks] = std::min(d__1,cond);
7712 }
7713 }
7714 }
7715 if (pair) {
7716 dif[ks + 1] = dif[ks];
7717 }
7718 }
7719 if (pair) {
7720 ++ks;
7721 }
7722
7723 L20:
7724 ;
7725 }
7726 work[1] = (double) lwmin;
7727 return 0;
7728
7729 /* End of DTGSNA */
7730
7731 } /* dtgsna_ */
7732
dtgsy2_(const char * trans,integer * ijob,integer * m,integer * n,double * a,integer * lda,double * b,integer * ldb,double * c__,integer * ldc,double * d__,integer * ldd,double * e,integer * lde,double * f,integer * ldf,double * scale,double * rdsum,double * rdscal,integer * iwork,integer * pq,integer * info)7733 /* Subroutine */ int dtgsy2_(const char *trans, integer *ijob, integer *m, integer *
7734 n, double *a, integer *lda, double *b, integer *ldb,
7735 double *c__, integer *ldc, double *d__, integer *ldd,
7736 double *e, integer *lde, double *f, integer *ldf, double *
7737 scale, double *rdsum, double *rdscal, integer *iwork, integer
7738 *pq, integer *info)
7739 {
7740 /* Table of constant values */
7741 static integer c__8 = 8;
7742 static integer c__1 = 1;
7743 static double c_b27 = -1.;
7744 static double c_b42 = 1.;
7745 static double c_b56 = 0.;
7746
7747 /* System generated locals */
7748 integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1,
7749 d_offset, e_dim1, e_offset, f_dim1, f_offset, i__1, i__2, i__3;
7750
7751 /* Local variables */
7752 integer i__, j, k, p, q;
7753 double z__[64] /* was [8][8] */;
7754 integer ie, je, mb, nb, ii, jj, is, js;
7755 double rhs[8];
7756 integer isp1, jsp1;
7757 integer ierr, zdim, ipiv[8], jpiv[8];
7758 double alpha;
7759 double scaloc;
7760 bool notran;
7761
7762
7763 /* -- LAPACK auxiliary routine (version 3.1.1) -- */
7764 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
7765 /* January 2007 */
7766
7767 /* .. Scalar Arguments .. */
7768 /* .. */
7769 /* .. Array Arguments .. */
7770 /* .. */
7771
7772 /* Purpose */
7773 /* ======= */
7774
7775 /* DTGSY2 solves the generalized Sylvester equation: */
7776
7777 /* A * R - L * B = scale * C (1) */
7778 /* D * R - L * E = scale * F, */
7779
7780 /* using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices, */
7781 /* (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M, */
7782 /* N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E) */
7783 /* must be in generalized Schur canonical form, i.e. A, B are upper */
7784 /* quasi triangular and D, E are upper triangular. The solution (R, L) */
7785 /* overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor */
7786 /* chosen to avoid overflow. */
7787
7788 /* In matrix notation solving equation (1) corresponds to solve */
7789 /* Z*x = scale*b, where Z is defined as */
7790
7791 /* Z = [ kron(In, A) -kron(B', Im) ] (2) */
7792 /* [ kron(In, D) -kron(E', Im) ], */
7793
7794 /* Ik is the identity matrix of size k and X' is the transpose of X. */
7795 /* kron(X, Y) is the Kronecker product between the matrices X and Y. */
7796 /* In the process of solving (1), we solve a number of such systems */
7797 /* where Dim(In), Dim(In) = 1 or 2. */
7798
7799 /* If TRANS = 'T', solve the transposed system Z'*y = scale*b for y, */
7800 /* which is equivalent to solve for R and L in */
7801
7802 /* A' * R + D' * L = scale * C (3) */
7803 /* R * B' + L * E' = scale * -F */
7804
7805 /* This case is used to compute an estimate of Dif[(A, D), (B, E)] = */
7806 /* sigma_min(Z) using reverse communicaton with DLACON. */
7807
7808 /* DTGSY2 also (IJOB >= 1) contributes to the computation in DTGSYL */
7809 /* of an upper bound on the separation between to matrix pairs. Then */
7810 /* the input (A, D), (B, E) are sub-pencils of the matrix pair in */
7811 /* DTGSYL. See DTGSYL for details. */
7812
7813 /* Arguments */
7814 /* ========= */
7815
7816 /* TRANS (input) CHARACTER*1 */
7817 /* = 'N', solve the generalized Sylvester equation (1). */
7818 /* = 'T': solve the 'transposed' system (3). */
7819
7820 /* IJOB (input) INTEGER */
7821 /* Specifies what kind of functionality to be performed. */
7822 /* = 0: solve (1) only. */
7823 /* = 1: A contribution from this subsystem to a Frobenius */
7824 /* norm-based estimate of the separation between two matrix */
7825 /* pairs is computed. (look ahead strategy is used). */
7826 /* = 2: A contribution from this subsystem to a Frobenius */
7827 /* norm-based estimate of the separation between two matrix */
7828 /* pairs is computed. (DGECON on sub-systems is used.) */
7829 /* Not referenced if TRANS = 'T'. */
7830
7831 /* M (input) INTEGER */
7832 /* On entry, M specifies the order of A and D, and the row */
7833 /* dimension of C, F, R and L. */
7834
7835 /* N (input) INTEGER */
7836 /* On entry, N specifies the order of B and E, and the column */
7837 /* dimension of C, F, R and L. */
7838
7839 /* A (input) DOUBLE PRECISION array, dimension (LDA, M) */
7840 /* On entry, A contains an upper quasi triangular matrix. */
7841
7842 /* LDA (input) INTEGER */
7843 /* The leading dimension of the matrix A. LDA >= max(1, M). */
7844
7845 /* B (input) DOUBLE PRECISION array, dimension (LDB, N) */
7846 /* On entry, B contains an upper quasi triangular matrix. */
7847
7848 /* LDB (input) INTEGER */
7849 /* The leading dimension of the matrix B. LDB >= max(1, N). */
7850
7851 /* C (input/output) DOUBLE PRECISION array, dimension (LDC, N) */
7852 /* On entry, C contains the right-hand-side of the first matrix */
7853 /* equation in (1). */
7854 /* On exit, if IJOB = 0, C has been overwritten by the */
7855 /* solution R. */
7856
7857 /* LDC (input) INTEGER */
7858 /* The leading dimension of the matrix C. LDC >= max(1, M). */
7859
7860 /* D (input) DOUBLE PRECISION array, dimension (LDD, M) */
7861 /* On entry, D contains an upper triangular matrix. */
7862
7863 /* LDD (input) INTEGER */
7864 /* The leading dimension of the matrix D. LDD >= max(1, M). */
7865
7866 /* E (input) DOUBLE PRECISION array, dimension (LDE, N) */
7867 /* On entry, E contains an upper triangular matrix. */
7868
7869 /* LDE (input) INTEGER */
7870 /* The leading dimension of the matrix E. LDE >= max(1, N). */
7871
7872 /* F (input/output) DOUBLE PRECISION array, dimension (LDF, N) */
7873 /* On entry, F contains the right-hand-side of the second matrix */
7874 /* equation in (1). */
7875 /* On exit, if IJOB = 0, F has been overwritten by the */
7876 /* solution L. */
7877
7878 /* LDF (input) INTEGER */
7879 /* The leading dimension of the matrix F. LDF >= max(1, M). */
7880
7881 /* SCALE (output) DOUBLE PRECISION */
7882 /* On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions */
7883 /* R and L (C and F on entry) will hold the solutions to a */
7884 /* slightly perturbed system but the input matrices A, B, D and */
7885 /* E have not been changed. If SCALE = 0, R and L will hold the */
7886 /* solutions to the homogeneous system with C = F = 0. Normally, */
7887 /* SCALE = 1. */
7888
7889 /* RDSUM (input/output) DOUBLE PRECISION */
7890 /* On entry, the sum of squares of computed contributions to */
7891 /* the Dif-estimate under computation by DTGSYL, where the */
7892 /* scaling factor RDSCAL (see below) has been factored out. */
7893 /* On exit, the corresponding sum of squares updated with the */
7894 /* contributions from the current sub-system. */
7895 /* If TRANS = 'T' RDSUM is not touched. */
7896 /* NOTE: RDSUM only makes sense when DTGSY2 is called by DTGSYL. */
7897
7898 /* RDSCAL (input/output) DOUBLE PRECISION */
7899 /* On entry, scaling factor used to prevent overflow in RDSUM. */
7900 /* On exit, RDSCAL is updated w.r.t. the current contributions */
7901 /* in RDSUM. */
7902 /* If TRANS = 'T', RDSCAL is not touched. */
7903 /* NOTE: RDSCAL only makes sense when DTGSY2 is called by */
7904 /* DTGSYL. */
7905
7906 /* IWORK (workspace) INTEGER array, dimension (M+N+2) */
7907
7908 /* PQ (output) INTEGER */
7909 /* On exit, the number of subsystems (of size 2-by-2, 4-by-4 and */
7910 /* 8-by-8) solved by this routine. */
7911
7912 /* INFO (output) INTEGER */
7913 /* On exit, if INFO is set to */
7914 /* =0: Successful exit */
7915 /* <0: If INFO = -i, the i-th argument had an illegal value. */
7916 /* >0: The matrix pairs (A, D) and (B, E) have common or very */
7917 /* close eigenvalues. */
7918
7919 /* Further Details */
7920 /* =============== */
7921
7922 /* Based on contributions by */
7923 /* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
7924 /* Umea University, S-901 87 Umea, Sweden. */
7925
7926 /* ===================================================================== */
7927 /* Replaced various illegal calls to DCOPY by calls to DLASET. */
7928 /* Sven Hammarling, 27/5/02. */
7929
7930 /* .. Parameters .. */
7931 /* .. */
7932 /* .. Local Scalars .. */
7933 /* .. */
7934 /* .. Local Arrays .. */
7935 /* .. */
7936 /* .. External Functions .. */
7937 /* .. */
7938 /* .. External Subroutines .. */
7939 /* .. */
7940 /* .. Intrinsic Functions .. */
7941 /* .. */
7942 /* .. Executable Statements .. */
7943
7944 /* Decode and test input parameters */
7945
7946 /* Parameter adjustments */
7947 a_dim1 = *lda;
7948 a_offset = 1 + a_dim1;
7949 a -= a_offset;
7950 b_dim1 = *ldb;
7951 b_offset = 1 + b_dim1;
7952 b -= b_offset;
7953 c_dim1 = *ldc;
7954 c_offset = 1 + c_dim1;
7955 c__ -= c_offset;
7956 d_dim1 = *ldd;
7957 d_offset = 1 + d_dim1;
7958 d__ -= d_offset;
7959 e_dim1 = *lde;
7960 e_offset = 1 + e_dim1;
7961 e -= e_offset;
7962 f_dim1 = *ldf;
7963 f_offset = 1 + f_dim1;
7964 f -= f_offset;
7965 --iwork;
7966
7967 /* Function Body */
7968 *info = 0;
7969 ierr = 0;
7970 notran = lsame_(trans, "N");
7971 if (! notran && ! lsame_(trans, "T")) {
7972 *info = -1;
7973 } else if (notran) {
7974 if (*ijob < 0 || *ijob > 2) {
7975 *info = -2;
7976 }
7977 }
7978 if (*info == 0) {
7979 if (*m <= 0) {
7980 *info = -3;
7981 } else if (*n <= 0) {
7982 *info = -4;
7983 } else if (*lda < std::max(1_integer,*m)) {
7984 *info = -5;
7985 } else if (*ldb < std::max(1_integer,*n)) {
7986 *info = -8;
7987 } else if (*ldc < std::max(1_integer,*m)) {
7988 *info = -10;
7989 } else if (*ldd < std::max(1_integer,*m)) {
7990 *info = -12;
7991 } else if (*lde < std::max(1_integer,*n)) {
7992 *info = -14;
7993 } else if (*ldf < std::max(1_integer,*m)) {
7994 *info = -16;
7995 }
7996 }
7997 if (*info != 0) {
7998 i__1 = -(*info);
7999 xerbla_("DTGSY2", &i__1);
8000 return 0;
8001 }
8002
8003 /* Determine block structure of A */
8004
8005 *pq = 0;
8006 p = 0;
8007 i__ = 1;
8008 L10:
8009 if (i__ > *m) {
8010 goto L20;
8011 }
8012 ++p;
8013 iwork[p] = i__;
8014 if (i__ == *m) {
8015 goto L20;
8016 }
8017 if (a[i__ + 1 + i__ * a_dim1] != 0.) {
8018 i__ += 2;
8019 } else {
8020 ++i__;
8021 }
8022 goto L10;
8023 L20:
8024 iwork[p + 1] = *m + 1;
8025
8026 /* Determine block structure of B */
8027
8028 q = p + 1;
8029 j = 1;
8030 L30:
8031 if (j > *n) {
8032 goto L40;
8033 }
8034 ++q;
8035 iwork[q] = j;
8036 if (j == *n) {
8037 goto L40;
8038 }
8039 if (b[j + 1 + j * b_dim1] != 0.) {
8040 j += 2;
8041 } else {
8042 ++j;
8043 }
8044 goto L30;
8045 L40:
8046 iwork[q + 1] = *n + 1;
8047 *pq = p * (q - p - 1);
8048
8049 if (notran) {
8050
8051 /* Solve (I, J) - subsystem */
8052 /* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) */
8053 /* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) */
8054 /* for I = P, P - 1, ..., 1; J = 1, 2, ..., Q */
8055
8056 *scale = 1.;
8057 scaloc = 1.;
8058 i__1 = q;
8059 for (j = p + 2; j <= i__1; ++j) {
8060 js = iwork[j];
8061 jsp1 = js + 1;
8062 je = iwork[j + 1] - 1;
8063 nb = je - js + 1;
8064 for (i__ = p; i__ >= 1; --i__) {
8065
8066 is = iwork[i__];
8067 isp1 = is + 1;
8068 ie = iwork[i__ + 1] - 1;
8069 mb = ie - is + 1;
8070 zdim = mb * nb << 1;
8071
8072 if (mb == 1 && nb == 1) {
8073
8074 /* Build a 2-by-2 system Z * x = RHS */
8075
8076 z__[0] = a[is + is * a_dim1];
8077 z__[1] = d__[is + is * d_dim1];
8078 z__[8] = -b[js + js * b_dim1];
8079 z__[9] = -e[js + js * e_dim1];
8080
8081 /* Set up right hand side(s) */
8082
8083 rhs[0] = c__[is + js * c_dim1];
8084 rhs[1] = f[is + js * f_dim1];
8085
8086 /* Solve Z * x = RHS */
8087
8088 dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr);
8089 if (ierr > 0) {
8090 *info = ierr;
8091 }
8092
8093 if (*ijob == 0) {
8094 dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc);
8095 if (scaloc != 1.) {
8096 i__2 = *n;
8097 for (k = 1; k <= i__2; ++k) {
8098 dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &
8099 c__1);
8100 dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
8101 /* L50: */
8102 }
8103 *scale *= scaloc;
8104 }
8105 } else {
8106 dlatdf_(ijob, &zdim, z__, &c__8, rhs, rdsum, rdscal,
8107 ipiv, jpiv);
8108 }
8109
8110 /* Unpack solution vector(s) */
8111
8112 c__[is + js * c_dim1] = rhs[0];
8113 f[is + js * f_dim1] = rhs[1];
8114
8115 /* Substitute R(I, J) and L(I, J) into remaining */
8116 /* equation. */
8117
8118 if (i__ > 1) {
8119 alpha = -rhs[0];
8120 i__2 = is - 1;
8121 daxpy_(&i__2, &alpha, &a[is * a_dim1 + 1], &c__1, &
8122 c__[js * c_dim1 + 1], &c__1);
8123 i__2 = is - 1;
8124 daxpy_(&i__2, &alpha, &d__[is * d_dim1 + 1], &c__1, &
8125 f[js * f_dim1 + 1], &c__1);
8126 }
8127 if (j < q) {
8128 i__2 = *n - je;
8129 daxpy_(&i__2, &rhs[1], &b[js + (je + 1) * b_dim1],
8130 ldb, &c__[is + (je + 1) * c_dim1], ldc);
8131 i__2 = *n - je;
8132 daxpy_(&i__2, &rhs[1], &e[js + (je + 1) * e_dim1],
8133 lde, &f[is + (je + 1) * f_dim1], ldf);
8134 }
8135
8136 } else if (mb == 1 && nb == 2) {
8137
8138 /* Build a 4-by-4 system Z * x = RHS */
8139
8140 z__[0] = a[is + is * a_dim1];
8141 z__[1] = 0.;
8142 z__[2] = d__[is + is * d_dim1];
8143 z__[3] = 0.;
8144
8145 z__[8] = 0.;
8146 z__[9] = a[is + is * a_dim1];
8147 z__[10] = 0.;
8148 z__[11] = d__[is + is * d_dim1];
8149
8150 z__[16] = -b[js + js * b_dim1];
8151 z__[17] = -b[js + jsp1 * b_dim1];
8152 z__[18] = -e[js + js * e_dim1];
8153 z__[19] = -e[js + jsp1 * e_dim1];
8154
8155 z__[24] = -b[jsp1 + js * b_dim1];
8156 z__[25] = -b[jsp1 + jsp1 * b_dim1];
8157 z__[26] = 0.;
8158 z__[27] = -e[jsp1 + jsp1 * e_dim1];
8159
8160 /* Set up right hand side(s) */
8161
8162 rhs[0] = c__[is + js * c_dim1];
8163 rhs[1] = c__[is + jsp1 * c_dim1];
8164 rhs[2] = f[is + js * f_dim1];
8165 rhs[3] = f[is + jsp1 * f_dim1];
8166
8167 /* Solve Z * x = RHS */
8168
8169 dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr);
8170 if (ierr > 0) {
8171 *info = ierr;
8172 }
8173
8174 if (*ijob == 0) {
8175 dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc);
8176 if (scaloc != 1.) {
8177 i__2 = *n;
8178 for (k = 1; k <= i__2; ++k) {
8179 dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &
8180 c__1);
8181 dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
8182 /* L60: */
8183 }
8184 *scale *= scaloc;
8185 }
8186 } else {
8187 dlatdf_(ijob, &zdim, z__, &c__8, rhs, rdsum, rdscal,
8188 ipiv, jpiv);
8189 }
8190
8191 /* Unpack solution vector(s) */
8192
8193 c__[is + js * c_dim1] = rhs[0];
8194 c__[is + jsp1 * c_dim1] = rhs[1];
8195 f[is + js * f_dim1] = rhs[2];
8196 f[is + jsp1 * f_dim1] = rhs[3];
8197
8198 /* Substitute R(I, J) and L(I, J) into remaining */
8199 /* equation. */
8200
8201 if (i__ > 1) {
8202 i__2 = is - 1;
8203 dger_(&i__2, &nb, &c_b27, &a[is * a_dim1 + 1], &c__1,
8204 rhs, &c__1, &c__[js * c_dim1 + 1], ldc);
8205 i__2 = is - 1;
8206 dger_(&i__2, &nb, &c_b27, &d__[is * d_dim1 + 1], &
8207 c__1, rhs, &c__1, &f[js * f_dim1 + 1], ldf);
8208 }
8209 if (j < q) {
8210 i__2 = *n - je;
8211 daxpy_(&i__2, &rhs[2], &b[js + (je + 1) * b_dim1],
8212 ldb, &c__[is + (je + 1) * c_dim1], ldc);
8213 i__2 = *n - je;
8214 daxpy_(&i__2, &rhs[2], &e[js + (je + 1) * e_dim1],
8215 lde, &f[is + (je + 1) * f_dim1], ldf);
8216 i__2 = *n - je;
8217 daxpy_(&i__2, &rhs[3], &b[jsp1 + (je + 1) * b_dim1],
8218 ldb, &c__[is + (je + 1) * c_dim1], ldc);
8219 i__2 = *n - je;
8220 daxpy_(&i__2, &rhs[3], &e[jsp1 + (je + 1) * e_dim1],
8221 lde, &f[is + (je + 1) * f_dim1], ldf);
8222 }
8223
8224 } else if (mb == 2 && nb == 1) {
8225
8226 /* Build a 4-by-4 system Z * x = RHS */
8227
8228 z__[0] = a[is + is * a_dim1];
8229 z__[1] = a[isp1 + is * a_dim1];
8230 z__[2] = d__[is + is * d_dim1];
8231 z__[3] = 0.;
8232
8233 z__[8] = a[is + isp1 * a_dim1];
8234 z__[9] = a[isp1 + isp1 * a_dim1];
8235 z__[10] = d__[is + isp1 * d_dim1];
8236 z__[11] = d__[isp1 + isp1 * d_dim1];
8237
8238 z__[16] = -b[js + js * b_dim1];
8239 z__[17] = 0.;
8240 z__[18] = -e[js + js * e_dim1];
8241 z__[19] = 0.;
8242
8243 z__[24] = 0.;
8244 z__[25] = -b[js + js * b_dim1];
8245 z__[26] = 0.;
8246 z__[27] = -e[js + js * e_dim1];
8247
8248 /* Set up right hand side(s) */
8249
8250 rhs[0] = c__[is + js * c_dim1];
8251 rhs[1] = c__[isp1 + js * c_dim1];
8252 rhs[2] = f[is + js * f_dim1];
8253 rhs[3] = f[isp1 + js * f_dim1];
8254
8255 /* Solve Z * x = RHS */
8256
8257 dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr);
8258 if (ierr > 0) {
8259 *info = ierr;
8260 }
8261 if (*ijob == 0) {
8262 dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc);
8263 if (scaloc != 1.) {
8264 i__2 = *n;
8265 for (k = 1; k <= i__2; ++k) {
8266 dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &
8267 c__1);
8268 dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
8269 /* L70: */
8270 }
8271 *scale *= scaloc;
8272 }
8273 } else {
8274 dlatdf_(ijob, &zdim, z__, &c__8, rhs, rdsum, rdscal,
8275 ipiv, jpiv);
8276 }
8277
8278 /* Unpack solution vector(s) */
8279
8280 c__[is + js * c_dim1] = rhs[0];
8281 c__[isp1 + js * c_dim1] = rhs[1];
8282 f[is + js * f_dim1] = rhs[2];
8283 f[isp1 + js * f_dim1] = rhs[3];
8284
8285 /* Substitute R(I, J) and L(I, J) into remaining */
8286 /* equation. */
8287
8288 if (i__ > 1) {
8289 i__2 = is - 1;
8290 dgemv_("N", &i__2, &mb, &c_b27, &a[is * a_dim1 + 1],
8291 lda, rhs, &c__1, &c_b42, &c__[js * c_dim1 + 1]
8292 , &c__1);
8293 i__2 = is - 1;
8294 dgemv_("N", &i__2, &mb, &c_b27, &d__[is * d_dim1 + 1],
8295 ldd, rhs, &c__1, &c_b42, &f[js * f_dim1 + 1],
8296 &c__1);
8297 }
8298 if (j < q) {
8299 i__2 = *n - je;
8300 dger_(&mb, &i__2, &c_b42, &rhs[2], &c__1, &b[js + (je
8301 + 1) * b_dim1], ldb, &c__[is + (je + 1) *
8302 c_dim1], ldc);
8303 i__2 = *n - je;
8304 dger_(&mb, &i__2, &c_b42, &rhs[2], &c__1, &e[js + (je
8305 + 1) * e_dim1], lde, &f[is + (je + 1) *
8306 f_dim1], ldf);
8307 }
8308
8309 } else if (mb == 2 && nb == 2) {
8310
8311 /* Build an 8-by-8 system Z * x = RHS */
8312
8313 dlaset_("F", &c__8, &c__8, &c_b56, &c_b56, z__, &c__8);
8314
8315 z__[0] = a[is + is * a_dim1];
8316 z__[1] = a[isp1 + is * a_dim1];
8317 z__[4] = d__[is + is * d_dim1];
8318
8319 z__[8] = a[is + isp1 * a_dim1];
8320 z__[9] = a[isp1 + isp1 * a_dim1];
8321 z__[12] = d__[is + isp1 * d_dim1];
8322 z__[13] = d__[isp1 + isp1 * d_dim1];
8323
8324 z__[18] = a[is + is * a_dim1];
8325 z__[19] = a[isp1 + is * a_dim1];
8326 z__[22] = d__[is + is * d_dim1];
8327
8328 z__[26] = a[is + isp1 * a_dim1];
8329 z__[27] = a[isp1 + isp1 * a_dim1];
8330 z__[30] = d__[is + isp1 * d_dim1];
8331 z__[31] = d__[isp1 + isp1 * d_dim1];
8332
8333 z__[32] = -b[js + js * b_dim1];
8334 z__[34] = -b[js + jsp1 * b_dim1];
8335 z__[36] = -e[js + js * e_dim1];
8336 z__[38] = -e[js + jsp1 * e_dim1];
8337
8338 z__[41] = -b[js + js * b_dim1];
8339 z__[43] = -b[js + jsp1 * b_dim1];
8340 z__[45] = -e[js + js * e_dim1];
8341 z__[47] = -e[js + jsp1 * e_dim1];
8342
8343 z__[48] = -b[jsp1 + js * b_dim1];
8344 z__[50] = -b[jsp1 + jsp1 * b_dim1];
8345 z__[54] = -e[jsp1 + jsp1 * e_dim1];
8346
8347 z__[57] = -b[jsp1 + js * b_dim1];
8348 z__[59] = -b[jsp1 + jsp1 * b_dim1];
8349 z__[63] = -e[jsp1 + jsp1 * e_dim1];
8350
8351 /* Set up right hand side(s) */
8352
8353 k = 1;
8354 ii = mb * nb + 1;
8355 i__2 = nb - 1;
8356 for (jj = 0; jj <= i__2; ++jj) {
8357 dcopy_(&mb, &c__[is + (js + jj) * c_dim1], &c__1, &
8358 rhs[k - 1], &c__1);
8359 dcopy_(&mb, &f[is + (js + jj) * f_dim1], &c__1, &rhs[
8360 ii - 1], &c__1);
8361 k += mb;
8362 ii += mb;
8363 /* L80: */
8364 }
8365
8366 /* Solve Z * x = RHS */
8367
8368 dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr);
8369 if (ierr > 0) {
8370 *info = ierr;
8371 }
8372 if (*ijob == 0) {
8373 dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc);
8374 if (scaloc != 1.) {
8375 i__2 = *n;
8376 for (k = 1; k <= i__2; ++k) {
8377 dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &
8378 c__1);
8379 dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
8380 /* L90: */
8381 }
8382 *scale *= scaloc;
8383 }
8384 } else {
8385 dlatdf_(ijob, &zdim, z__, &c__8, rhs, rdsum, rdscal,
8386 ipiv, jpiv);
8387 }
8388
8389 /* Unpack solution vector(s) */
8390
8391 k = 1;
8392 ii = mb * nb + 1;
8393 i__2 = nb - 1;
8394 for (jj = 0; jj <= i__2; ++jj) {
8395 dcopy_(&mb, &rhs[k - 1], &c__1, &c__[is + (js + jj) *
8396 c_dim1], &c__1);
8397 dcopy_(&mb, &rhs[ii - 1], &c__1, &f[is + (js + jj) *
8398 f_dim1], &c__1);
8399 k += mb;
8400 ii += mb;
8401 /* L100: */
8402 }
8403
8404 /* Substitute R(I, J) and L(I, J) into remaining */
8405 /* equation. */
8406
8407 if (i__ > 1) {
8408 i__2 = is - 1;
8409 dgemm_("N", "N", &i__2, &nb, &mb, &c_b27, &a[is *
8410 a_dim1 + 1], lda, rhs, &mb, &c_b42, &c__[js *
8411 c_dim1 + 1], ldc);
8412 i__2 = is - 1;
8413 dgemm_("N", "N", &i__2, &nb, &mb, &c_b27, &d__[is *
8414 d_dim1 + 1], ldd, rhs, &mb, &c_b42, &f[js *
8415 f_dim1 + 1], ldf);
8416 }
8417 if (j < q) {
8418 k = mb * nb + 1;
8419 i__2 = *n - je;
8420 dgemm_("N", "N", &mb, &i__2, &nb, &c_b42, &rhs[k - 1],
8421 &mb, &b[js + (je + 1) * b_dim1], ldb, &c_b42,
8422 &c__[is + (je + 1) * c_dim1], ldc);
8423 i__2 = *n - je;
8424 dgemm_("N", "N", &mb, &i__2, &nb, &c_b42, &rhs[k - 1],
8425 &mb, &e[js + (je + 1) * e_dim1], lde, &c_b42,
8426 &f[is + (je + 1) * f_dim1], ldf);
8427 }
8428
8429 }
8430
8431 /* L110: */
8432 }
8433 /* L120: */
8434 }
8435 } else {
8436
8437 /* Solve (I, J) - subsystem */
8438 /* A(I, I)' * R(I, J) + D(I, I)' * L(J, J) = C(I, J) */
8439 /* R(I, I) * B(J, J) + L(I, J) * E(J, J) = -F(I, J) */
8440 /* for I = 1, 2, ..., P, J = Q, Q - 1, ..., 1 */
8441
8442 *scale = 1.;
8443 scaloc = 1.;
8444 i__1 = p;
8445 for (i__ = 1; i__ <= i__1; ++i__) {
8446
8447 is = iwork[i__];
8448 isp1 = is + 1;
8449 ie = i__;
8450 mb = ie - is + 1;
8451 i__2 = p + 2;
8452 for (j = q; j >= i__2; --j) {
8453
8454 js = iwork[j];
8455 jsp1 = js + 1;
8456 je = iwork[j + 1] - 1;
8457 nb = je - js + 1;
8458 zdim = mb * nb << 1;
8459 if (mb == 1 && nb == 1) {
8460
8461 /* Build a 2-by-2 system Z' * x = RHS */
8462
8463 z__[0] = a[is + is * a_dim1];
8464 z__[1] = -b[js + js * b_dim1];
8465 z__[8] = d__[is + is * d_dim1];
8466 z__[9] = -e[js + js * e_dim1];
8467
8468 /* Set up right hand side(s) */
8469
8470 rhs[0] = c__[is + js * c_dim1];
8471 rhs[1] = f[is + js * f_dim1];
8472
8473 /* Solve Z' * x = RHS */
8474
8475 dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr);
8476 if (ierr > 0) {
8477 *info = ierr;
8478 }
8479
8480 dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc);
8481 if (scaloc != 1.) {
8482 i__3 = *n;
8483 for (k = 1; k <= i__3; ++k) {
8484 dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1);
8485 dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
8486 /* L130: */
8487 }
8488 *scale *= scaloc;
8489 }
8490
8491 /* Unpack solution vector(s) */
8492
8493 c__[is + js * c_dim1] = rhs[0];
8494 f[is + js * f_dim1] = rhs[1];
8495
8496 /* Substitute R(I, J) and L(I, J) into remaining */
8497 /* equation. */
8498
8499 if (j > p + 2) {
8500 alpha = rhs[0];
8501 i__3 = js - 1;
8502 daxpy_(&i__3, &alpha, &b[js * b_dim1 + 1], &c__1, &f[
8503 is + f_dim1], ldf);
8504 alpha = rhs[1];
8505 i__3 = js - 1;
8506 daxpy_(&i__3, &alpha, &e[js * e_dim1 + 1], &c__1, &f[
8507 is + f_dim1], ldf);
8508 }
8509 if (i__ < p) {
8510 alpha = -rhs[0];
8511 i__3 = *m - ie;
8512 daxpy_(&i__3, &alpha, &a[is + (ie + 1) * a_dim1], lda,
8513 &c__[ie + 1 + js * c_dim1], &c__1);
8514 alpha = -rhs[1];
8515 i__3 = *m - ie;
8516 daxpy_(&i__3, &alpha, &d__[is + (ie + 1) * d_dim1],
8517 ldd, &c__[ie + 1 + js * c_dim1], &c__1);
8518 }
8519
8520 } else if (mb == 1 && nb == 2) {
8521
8522 /* Build a 4-by-4 system Z' * x = RHS */
8523
8524 z__[0] = a[is + is * a_dim1];
8525 z__[1] = 0.;
8526 z__[2] = -b[js + js * b_dim1];
8527 z__[3] = -b[jsp1 + js * b_dim1];
8528
8529 z__[8] = 0.;
8530 z__[9] = a[is + is * a_dim1];
8531 z__[10] = -b[js + jsp1 * b_dim1];
8532 z__[11] = -b[jsp1 + jsp1 * b_dim1];
8533
8534 z__[16] = d__[is + is * d_dim1];
8535 z__[17] = 0.;
8536 z__[18] = -e[js + js * e_dim1];
8537 z__[19] = 0.;
8538
8539 z__[24] = 0.;
8540 z__[25] = d__[is + is * d_dim1];
8541 z__[26] = -e[js + jsp1 * e_dim1];
8542 z__[27] = -e[jsp1 + jsp1 * e_dim1];
8543
8544 /* Set up right hand side(s) */
8545
8546 rhs[0] = c__[is + js * c_dim1];
8547 rhs[1] = c__[is + jsp1 * c_dim1];
8548 rhs[2] = f[is + js * f_dim1];
8549 rhs[3] = f[is + jsp1 * f_dim1];
8550
8551 /* Solve Z' * x = RHS */
8552
8553 dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr);
8554 if (ierr > 0) {
8555 *info = ierr;
8556 }
8557 dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc);
8558 if (scaloc != 1.) {
8559 i__3 = *n;
8560 for (k = 1; k <= i__3; ++k) {
8561 dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1);
8562 dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
8563 /* L140: */
8564 }
8565 *scale *= scaloc;
8566 }
8567
8568 /* Unpack solution vector(s) */
8569
8570 c__[is + js * c_dim1] = rhs[0];
8571 c__[is + jsp1 * c_dim1] = rhs[1];
8572 f[is + js * f_dim1] = rhs[2];
8573 f[is + jsp1 * f_dim1] = rhs[3];
8574
8575 /* Substitute R(I, J) and L(I, J) into remaining */
8576 /* equation. */
8577
8578 if (j > p + 2) {
8579 i__3 = js - 1;
8580 daxpy_(&i__3, rhs, &b[js * b_dim1 + 1], &c__1, &f[is
8581 + f_dim1], ldf);
8582 i__3 = js - 1;
8583 daxpy_(&i__3, &rhs[1], &b[jsp1 * b_dim1 + 1], &c__1, &
8584 f[is + f_dim1], ldf);
8585 i__3 = js - 1;
8586 daxpy_(&i__3, &rhs[2], &e[js * e_dim1 + 1], &c__1, &f[
8587 is + f_dim1], ldf);
8588 i__3 = js - 1;
8589 daxpy_(&i__3, &rhs[3], &e[jsp1 * e_dim1 + 1], &c__1, &
8590 f[is + f_dim1], ldf);
8591 }
8592 if (i__ < p) {
8593 i__3 = *m - ie;
8594 dger_(&i__3, &nb, &c_b27, &a[is + (ie + 1) * a_dim1],
8595 lda, rhs, &c__1, &c__[ie + 1 + js * c_dim1],
8596 ldc);
8597 i__3 = *m - ie;
8598 dger_(&i__3, &nb, &c_b27, &d__[is + (ie + 1) * d_dim1]
8599 , ldd, &rhs[2], &c__1, &c__[ie + 1 + js *
8600 c_dim1], ldc);
8601 }
8602
8603 } else if (mb == 2 && nb == 1) {
8604
8605 /* Build a 4-by-4 system Z' * x = RHS */
8606
8607 z__[0] = a[is + is * a_dim1];
8608 z__[1] = a[is + isp1 * a_dim1];
8609 z__[2] = -b[js + js * b_dim1];
8610 z__[3] = 0.;
8611
8612 z__[8] = a[isp1 + is * a_dim1];
8613 z__[9] = a[isp1 + isp1 * a_dim1];
8614 z__[10] = 0.;
8615 z__[11] = -b[js + js * b_dim1];
8616
8617 z__[16] = d__[is + is * d_dim1];
8618 z__[17] = d__[is + isp1 * d_dim1];
8619 z__[18] = -e[js + js * e_dim1];
8620 z__[19] = 0.;
8621
8622 z__[24] = 0.;
8623 z__[25] = d__[isp1 + isp1 * d_dim1];
8624 z__[26] = 0.;
8625 z__[27] = -e[js + js * e_dim1];
8626
8627 /* Set up right hand side(s) */
8628
8629 rhs[0] = c__[is + js * c_dim1];
8630 rhs[1] = c__[isp1 + js * c_dim1];
8631 rhs[2] = f[is + js * f_dim1];
8632 rhs[3] = f[isp1 + js * f_dim1];
8633
8634 /* Solve Z' * x = RHS */
8635
8636 dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr);
8637 if (ierr > 0) {
8638 *info = ierr;
8639 }
8640
8641 dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc);
8642 if (scaloc != 1.) {
8643 i__3 = *n;
8644 for (k = 1; k <= i__3; ++k) {
8645 dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1);
8646 dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
8647 /* L150: */
8648 }
8649 *scale *= scaloc;
8650 }
8651
8652 /* Unpack solution vector(s) */
8653
8654 c__[is + js * c_dim1] = rhs[0];
8655 c__[isp1 + js * c_dim1] = rhs[1];
8656 f[is + js * f_dim1] = rhs[2];
8657 f[isp1 + js * f_dim1] = rhs[3];
8658
8659 /* Substitute R(I, J) and L(I, J) into remaining */
8660 /* equation. */
8661
8662 if (j > p + 2) {
8663 i__3 = js - 1;
8664 dger_(&mb, &i__3, &c_b42, rhs, &c__1, &b[js * b_dim1
8665 + 1], &c__1, &f[is + f_dim1], ldf);
8666 i__3 = js - 1;
8667 dger_(&mb, &i__3, &c_b42, &rhs[2], &c__1, &e[js *
8668 e_dim1 + 1], &c__1, &f[is + f_dim1], ldf);
8669 }
8670 if (i__ < p) {
8671 i__3 = *m - ie;
8672 dgemv_("T", &mb, &i__3, &c_b27, &a[is + (ie + 1) *
8673 a_dim1], lda, rhs, &c__1, &c_b42, &c__[ie + 1
8674 + js * c_dim1], &c__1);
8675 i__3 = *m - ie;
8676 dgemv_("T", &mb, &i__3, &c_b27, &d__[is + (ie + 1) *
8677 d_dim1], ldd, &rhs[2], &c__1, &c_b42, &c__[ie
8678 + 1 + js * c_dim1], &c__1);
8679 }
8680
8681 } else if (mb == 2 && nb == 2) {
8682
8683 /* Build an 8-by-8 system Z' * x = RHS */
8684
8685 dlaset_("F", &c__8, &c__8, &c_b56, &c_b56, z__, &c__8);
8686
8687 z__[0] = a[is + is * a_dim1];
8688 z__[1] = a[is + isp1 * a_dim1];
8689 z__[4] = -b[js + js * b_dim1];
8690 z__[6] = -b[jsp1 + js * b_dim1];
8691
8692 z__[8] = a[isp1 + is * a_dim1];
8693 z__[9] = a[isp1 + isp1 * a_dim1];
8694 z__[13] = -b[js + js * b_dim1];
8695 z__[15] = -b[jsp1 + js * b_dim1];
8696
8697 z__[18] = a[is + is * a_dim1];
8698 z__[19] = a[is + isp1 * a_dim1];
8699 z__[20] = -b[js + jsp1 * b_dim1];
8700 z__[22] = -b[jsp1 + jsp1 * b_dim1];
8701
8702 z__[26] = a[isp1 + is * a_dim1];
8703 z__[27] = a[isp1 + isp1 * a_dim1];
8704 z__[29] = -b[js + jsp1 * b_dim1];
8705 z__[31] = -b[jsp1 + jsp1 * b_dim1];
8706
8707 z__[32] = d__[is + is * d_dim1];
8708 z__[33] = d__[is + isp1 * d_dim1];
8709 z__[36] = -e[js + js * e_dim1];
8710
8711 z__[41] = d__[isp1 + isp1 * d_dim1];
8712 z__[45] = -e[js + js * e_dim1];
8713
8714 z__[50] = d__[is + is * d_dim1];
8715 z__[51] = d__[is + isp1 * d_dim1];
8716 z__[52] = -e[js + jsp1 * e_dim1];
8717 z__[54] = -e[jsp1 + jsp1 * e_dim1];
8718
8719 z__[59] = d__[isp1 + isp1 * d_dim1];
8720 z__[61] = -e[js + jsp1 * e_dim1];
8721 z__[63] = -e[jsp1 + jsp1 * e_dim1];
8722
8723 /* Set up right hand side(s) */
8724
8725 k = 1;
8726 ii = mb * nb + 1;
8727 i__3 = nb - 1;
8728 for (jj = 0; jj <= i__3; ++jj) {
8729 dcopy_(&mb, &c__[is + (js + jj) * c_dim1], &c__1, &
8730 rhs[k - 1], &c__1);
8731 dcopy_(&mb, &f[is + (js + jj) * f_dim1], &c__1, &rhs[
8732 ii - 1], &c__1);
8733 k += mb;
8734 ii += mb;
8735 /* L160: */
8736 }
8737
8738
8739 /* Solve Z' * x = RHS */
8740
8741 dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr);
8742 if (ierr > 0) {
8743 *info = ierr;
8744 }
8745
8746 dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc);
8747 if (scaloc != 1.) {
8748 i__3 = *n;
8749 for (k = 1; k <= i__3; ++k) {
8750 dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1);
8751 dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
8752 /* L170: */
8753 }
8754 *scale *= scaloc;
8755 }
8756
8757 /* Unpack solution vector(s) */
8758
8759 k = 1;
8760 ii = mb * nb + 1;
8761 i__3 = nb - 1;
8762 for (jj = 0; jj <= i__3; ++jj) {
8763 dcopy_(&mb, &rhs[k - 1], &c__1, &c__[is + (js + jj) *
8764 c_dim1], &c__1);
8765 dcopy_(&mb, &rhs[ii - 1], &c__1, &f[is + (js + jj) *
8766 f_dim1], &c__1);
8767 k += mb;
8768 ii += mb;
8769 /* L180: */
8770 }
8771
8772 /* Substitute R(I, J) and L(I, J) into remaining */
8773 /* equation. */
8774
8775 if (j > p + 2) {
8776 i__3 = js - 1;
8777 dgemm_("N", "T", &mb, &i__3, &nb, &c_b42, &c__[is +
8778 js * c_dim1], ldc, &b[js * b_dim1 + 1], ldb, &
8779 c_b42, &f[is + f_dim1], ldf);
8780 i__3 = js - 1;
8781 dgemm_("N", "T", &mb, &i__3, &nb, &c_b42, &f[is + js *
8782 f_dim1], ldf, &e[js * e_dim1 + 1], lde, &
8783 c_b42, &f[is + f_dim1], ldf);
8784 }
8785 if (i__ < p) {
8786 i__3 = *m - ie;
8787 dgemm_("T", "N", &i__3, &nb, &mb, &c_b27, &a[is + (ie
8788 + 1) * a_dim1], lda, &c__[is + js * c_dim1],
8789 ldc, &c_b42, &c__[ie + 1 + js * c_dim1], ldc);
8790 i__3 = *m - ie;
8791 dgemm_("T", "N", &i__3, &nb, &mb, &c_b27, &d__[is + (
8792 ie + 1) * d_dim1], ldd, &f[is + js * f_dim1],
8793 ldf, &c_b42, &c__[ie + 1 + js * c_dim1], ldc);
8794 }
8795
8796 }
8797
8798 /* L190: */
8799 }
8800 /* L200: */
8801 }
8802
8803 }
8804 return 0;
8805
8806 /* End of DTGSY2 */
8807
8808 } /* dtgsy2_ */
8809
dtgsyl_(const char * trans,integer * ijob,integer * m,integer * n,double * a,integer * lda,double * b,integer * ldb,double * c__,integer * ldc,double * d__,integer * ldd,double * e,integer * lde,double * f,integer * ldf,double * scale,double * dif,double * work,integer * lwork,integer * iwork,integer * info)8810 /* Subroutine */ int dtgsyl_(const char *trans, integer *ijob, integer *m, integer *
8811 n, double *a, integer *lda, double *b, integer *ldb,
8812 double *c__, integer *ldc, double *d__, integer *ldd,
8813 double *e, integer *lde, double *f, integer *ldf, double *
8814 scale, double *dif, double *work, integer *lwork, integer *
8815 iwork, integer *info)
8816 {
8817 /* Table of constant values */
8818
8819 static integer c__2 = 2;
8820 static integer c_n1 = -1;
8821 static integer c__5 = 5;
8822 static double c_b14 = 0.;
8823 static integer c__1 = 1;
8824 static double c_b51 = -1.;
8825 static double c_b52 = 1.;
8826
8827 /* System generated locals */
8828 integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1,
8829 d_offset, e_dim1, e_offset, f_dim1, f_offset, i__1, i__2, i__3,
8830 i__4;
8831
8832 /* Local variables */
8833 integer i__, j, k, p, q, ie, je, mb, nb, is, js, pq;
8834 double dsum;
8835 integer ppqq;
8836 integer ifunc, linfo, lwmin;
8837 double scale2;
8838 double dscale, scaloc;
8839 integer iround;
8840 bool notran;
8841 integer isolve;
8842 bool lquery;
8843
8844
8845 /* -- LAPACK routine (version 3.1) -- */
8846 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
8847 /* November 2006 */
8848
8849 /* .. Scalar Arguments .. */
8850 /* .. */
8851 /* .. Array Arguments .. */
8852 /* .. */
8853
8854 /* Purpose */
8855 /* ======= */
8856
8857 /* DTGSYL solves the generalized Sylvester equation: */
8858
8859 /* A * R - L * B = scale * C (1) */
8860 /* D * R - L * E = scale * F */
8861
8862 /* where R and L are unknown m-by-n matrices, (A, D), (B, E) and */
8863 /* (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n, */
8864 /* respectively, with real entries. (A, D) and (B, E) must be in */
8865 /* generalized (real) Schur canonical form, i.e. A, B are upper quasi */
8866 /* triangular and D, E are upper triangular. */
8867
8868 /* The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output */
8869 /* scaling factor chosen to avoid overflow. */
8870
8871 /* In matrix notation (1) is equivalent to solve Zx = scale b, where */
8872 /* Z is defined as */
8873
8874 /* Z = [ kron(In, A) -kron(B', Im) ] (2) */
8875 /* [ kron(In, D) -kron(E', Im) ]. */
8876
8877 /* Here Ik is the identity matrix of size k and X' is the transpose of */
8878 /* X. kron(X, Y) is the Kronecker product between the matrices X and Y. */
8879
8880 /* If TRANS = 'T', DTGSYL solves the transposed system Z'*y = scale*b, */
8881 /* which is equivalent to solve for R and L in */
8882
8883 /* A' * R + D' * L = scale * C (3) */
8884 /* R * B' + L * E' = scale * (-F) */
8885
8886 /* This case (TRANS = 'T') is used to compute an one-norm-based estimate */
8887 /* of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D) */
8888 /* and (B,E), using DLACON. */
8889
8890 /* If IJOB >= 1, DTGSYL computes a Frobenius norm-based estimate */
8891 /* of Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the */
8892 /* reciprocal of the smallest singular value of Z. See [1-2] for more */
8893 /* information. */
8894
8895 /* This is a level 3 BLAS algorithm. */
8896
8897 /* Arguments */
8898 /* ========= */
8899
8900 /* TRANS (input) CHARACTER*1 */
8901 /* = 'N', solve the generalized Sylvester equation (1). */
8902 /* = 'T', solve the 'transposed' system (3). */
8903
8904 /* IJOB (input) INTEGER */
8905 /* Specifies what kind of functionality to be performed. */
8906 /* =0: solve (1) only. */
8907 /* =1: The functionality of 0 and 3. */
8908 /* =2: The functionality of 0 and 4. */
8909 /* =3: Only an estimate of Dif[(A,D), (B,E)] is computed. */
8910 /* (look ahead strategy IJOB = 1 is used). */
8911 /* =4: Only an estimate of Dif[(A,D), (B,E)] is computed. */
8912 /* ( DGECON on sub-systems is used ). */
8913 /* Not referenced if TRANS = 'T'. */
8914
8915 /* M (input) INTEGER */
8916 /* The order of the matrices A and D, and the row dimension of */
8917 /* the matrices C, F, R and L. */
8918
8919 /* N (input) INTEGER */
8920 /* The order of the matrices B and E, and the column dimension */
8921 /* of the matrices C, F, R and L. */
8922
8923 /* A (input) DOUBLE PRECISION array, dimension (LDA, M) */
8924 /* The upper quasi triangular matrix A. */
8925
8926 /* LDA (input) INTEGER */
8927 /* The leading dimension of the array A. LDA >= max(1, M). */
8928
8929 /* B (input) DOUBLE PRECISION array, dimension (LDB, N) */
8930 /* The upper quasi triangular matrix B. */
8931
8932 /* LDB (input) INTEGER */
8933 /* The leading dimension of the array B. LDB >= max(1, N). */
8934
8935 /* C (input/output) DOUBLE PRECISION array, dimension (LDC, N) */
8936 /* On entry, C contains the right-hand-side of the first matrix */
8937 /* equation in (1) or (3). */
8938 /* On exit, if IJOB = 0, 1 or 2, C has been overwritten by */
8939 /* the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R, */
8940 /* the solution achieved during the computation of the */
8941 /* Dif-estimate. */
8942
8943 /* LDC (input) INTEGER */
8944 /* The leading dimension of the array C. LDC >= max(1, M). */
8945
8946 /* D (input) DOUBLE PRECISION array, dimension (LDD, M) */
8947 /* The upper triangular matrix D. */
8948
8949 /* LDD (input) INTEGER */
8950 /* The leading dimension of the array D. LDD >= max(1, M). */
8951
8952 /* E (input) DOUBLE PRECISION array, dimension (LDE, N) */
8953 /* The upper triangular matrix E. */
8954
8955 /* LDE (input) INTEGER */
8956 /* The leading dimension of the array E. LDE >= max(1, N). */
8957
8958 /* F (input/output) DOUBLE PRECISION array, dimension (LDF, N) */
8959 /* On entry, F contains the right-hand-side of the second matrix */
8960 /* equation in (1) or (3). */
8961 /* On exit, if IJOB = 0, 1 or 2, F has been overwritten by */
8962 /* the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L, */
8963 /* the solution achieved during the computation of the */
8964 /* Dif-estimate. */
8965
8966 /* LDF (input) INTEGER */
8967 /* The leading dimension of the array F. LDF >= max(1, M). */
8968
8969 /* DIF (output) DOUBLE PRECISION */
8970 /* On exit DIF is the reciprocal of a lower bound of the */
8971 /* reciprocal of the Dif-function, i.e. DIF is an upper bound of */
8972 /* Dif[(A,D), (B,E)] = sigma_min(Z), where Z as in (2). */
8973 /* IF IJOB = 0 or TRANS = 'T', DIF is not touched. */
8974
8975 /* SCALE (output) DOUBLE PRECISION */
8976 /* On exit SCALE is the scaling factor in (1) or (3). */
8977 /* If 0 < SCALE < 1, C and F hold the solutions R and L, resp., */
8978 /* to a slightly perturbed system but the input matrices A, B, D */
8979 /* and E have not been changed. If SCALE = 0, C and F hold the */
8980 /* solutions R and L, respectively, to the homogeneous system */
8981 /* with C = F = 0. Normally, SCALE = 1. */
8982
8983 /* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
8984 /* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
8985
8986 /* LWORK (input) INTEGER */
8987 /* The dimension of the array WORK. LWORK > = 1. */
8988 /* If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N). */
8989
8990 /* If LWORK = -1, then a workspace query is assumed; the routine */
8991 /* only calculates the optimal size of the WORK array, returns */
8992 /* this value as the first entry of the WORK array, and no error */
8993 /* message related to LWORK is issued by XERBLA. */
8994
8995 /* IWORK (workspace) INTEGER array, dimension (M+N+6) */
8996
8997 /* INFO (output) INTEGER */
8998 /* =0: successful exit */
8999 /* <0: If INFO = -i, the i-th argument had an illegal value. */
9000 /* >0: (A, D) and (B, E) have common or close eigenvalues. */
9001
9002 /* Further Details */
9003 /* =============== */
9004
9005 /* Based on contributions by */
9006 /* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
9007 /* Umea University, S-901 87 Umea, Sweden. */
9008
9009 /* [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */
9010 /* for Solving the Generalized Sylvester Equation and Estimating the */
9011 /* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */
9012 /* Department of Computing Science, Umea University, S-901 87 Umea, */
9013 /* Sweden, December 1993, Revised April 1994, Also as LAPACK Working */
9014 /* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, */
9015 /* No 1, 1996. */
9016
9017 /* [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester */
9018 /* Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal. */
9019 /* Appl., 15(4):1045-1060, 1994 */
9020
9021 /* [3] B. Kagstrom and L. Westin, Generalized Schur Methods with */
9022 /* Condition Estimators for Solving the Generalized Sylvester */
9023 /* Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7, */
9024 /* July 1989, pp 745-751. */
9025
9026 /* ===================================================================== */
9027 /* Replaced various illegal calls to DCOPY by calls to DLASET. */
9028 /* Sven Hammarling, 1/5/02. */
9029
9030 /* .. Parameters .. */
9031 /* .. */
9032 /* .. Local Scalars .. */
9033 /* .. */
9034 /* .. External Functions .. */
9035 /* .. */
9036 /* .. External Subroutines .. */
9037 /* .. */
9038 /* .. Intrinsic Functions .. */
9039 /* .. */
9040 /* .. Executable Statements .. */
9041
9042 /* Decode and test input parameters */
9043
9044 /* Parameter adjustments */
9045 a_dim1 = *lda;
9046 a_offset = 1 + a_dim1;
9047 a -= a_offset;
9048 b_dim1 = *ldb;
9049 b_offset = 1 + b_dim1;
9050 b -= b_offset;
9051 c_dim1 = *ldc;
9052 c_offset = 1 + c_dim1;
9053 c__ -= c_offset;
9054 d_dim1 = *ldd;
9055 d_offset = 1 + d_dim1;
9056 d__ -= d_offset;
9057 e_dim1 = *lde;
9058 e_offset = 1 + e_dim1;
9059 e -= e_offset;
9060 f_dim1 = *ldf;
9061 f_offset = 1 + f_dim1;
9062 f -= f_offset;
9063 --work;
9064 --iwork;
9065
9066 /* Function Body */
9067 *info = 0;
9068 notran = lsame_(trans, "N");
9069 lquery = *lwork == -1;
9070
9071 if (! notran && ! lsame_(trans, "T")) {
9072 *info = -1;
9073 } else if (notran) {
9074 if (*ijob < 0 || *ijob > 4) {
9075 *info = -2;
9076 }
9077 }
9078 if (*info == 0) {
9079 if (*m <= 0) {
9080 *info = -3;
9081 } else if (*n <= 0) {
9082 *info = -4;
9083 } else if (*lda < std::max(1_integer,*m)) {
9084 *info = -6;
9085 } else if (*ldb < std::max(1_integer,*n)) {
9086 *info = -8;
9087 } else if (*ldc < std::max(1_integer,*m)) {
9088 *info = -10;
9089 } else if (*ldd < std::max(1_integer,*m)) {
9090 *info = -12;
9091 } else if (*lde < std::max(1_integer,*n)) {
9092 *info = -14;
9093 } else if (*ldf < std::max(1_integer,*m)) {
9094 *info = -16;
9095 }
9096 }
9097
9098 if (*info == 0) {
9099 if (notran) {
9100 if (*ijob == 1 || *ijob == 2) {
9101 /* Computing MAX */
9102 i__1 = 1, i__2 = (*m << 1) * *n;
9103 lwmin = std::max(i__1,i__2);
9104 } else {
9105 lwmin = 1;
9106 }
9107 } else {
9108 lwmin = 1;
9109 }
9110 work[1] = (double) lwmin;
9111
9112 if (*lwork < lwmin && ! lquery) {
9113 *info = -20;
9114 }
9115 }
9116
9117 if (*info != 0) {
9118 i__1 = -(*info);
9119 xerbla_("DTGSYL", &i__1);
9120 return 0;
9121 } else if (lquery) {
9122 return 0;
9123 }
9124
9125 /* Quick return if possible */
9126
9127 if (*m == 0 || *n == 0) {
9128 *scale = 1.;
9129 if (notran) {
9130 if (*ijob != 0) {
9131 *dif = 0.;
9132 }
9133 }
9134 return 0;
9135 }
9136
9137 /* Determine optimal block sizes MB and NB */
9138
9139 mb = ilaenv_(&c__2, "DTGSYL", trans, m, n, &c_n1, &c_n1);
9140 nb = ilaenv_(&c__5, "DTGSYL", trans, m, n, &c_n1, &c_n1);
9141
9142 isolve = 1;
9143 ifunc = 0;
9144 if (notran) {
9145 if (*ijob >= 3) {
9146 ifunc = *ijob - 2;
9147 dlaset_("F", m, n, &c_b14, &c_b14, &c__[c_offset], ldc)
9148 ;
9149 dlaset_("F", m, n, &c_b14, &c_b14, &f[f_offset], ldf);
9150 } else if (*ijob >= 1) {
9151 isolve = 2;
9152 }
9153 }
9154
9155 if (mb <= 1 && nb <= 1 || mb >= *m && nb >= *n) {
9156
9157 i__1 = isolve;
9158 for (iround = 1; iround <= i__1; ++iround) {
9159
9160 /* Use unblocked Level 2 solver */
9161
9162 dscale = 0.;
9163 dsum = 1.;
9164 pq = 0;
9165 dtgsy2_(trans, &ifunc, m, n, &a[a_offset], lda, &b[b_offset], ldb,
9166 &c__[c_offset], ldc, &d__[d_offset], ldd, &e[e_offset],
9167 lde, &f[f_offset], ldf, scale, &dsum, &dscale, &iwork[1],
9168 &pq, info);
9169 if (dscale != 0.) {
9170 if (*ijob == 1 || *ijob == 3) {
9171 *dif = sqrt((double) ((*m << 1) * *n)) / (dscale *
9172 sqrt(dsum));
9173 } else {
9174 *dif = sqrt((double) pq) / (dscale * sqrt(dsum));
9175 }
9176 }
9177
9178 if (isolve == 2 && iround == 1) {
9179 if (notran) {
9180 ifunc = *ijob;
9181 }
9182 scale2 = *scale;
9183 dlacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m);
9184 dlacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m);
9185 dlaset_("F", m, n, &c_b14, &c_b14, &c__[c_offset], ldc);
9186 dlaset_("F", m, n, &c_b14, &c_b14, &f[f_offset], ldf);
9187 } else if (isolve == 2 && iround == 2) {
9188 dlacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc);
9189 dlacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf);
9190 *scale = scale2;
9191 }
9192 /* L30: */
9193 }
9194
9195 return 0;
9196 }
9197
9198 /* Determine block structure of A */
9199
9200 p = 0;
9201 i__ = 1;
9202 L40:
9203 if (i__ > *m) {
9204 goto L50;
9205 }
9206 ++p;
9207 iwork[p] = i__;
9208 i__ += mb;
9209 if (i__ >= *m) {
9210 goto L50;
9211 }
9212 if (a[i__ + (i__ - 1) * a_dim1] != 0.) {
9213 ++i__;
9214 }
9215 goto L40;
9216 L50:
9217
9218 iwork[p + 1] = *m + 1;
9219 if (iwork[p] == iwork[p + 1]) {
9220 --p;
9221 }
9222
9223 /* Determine block structure of B */
9224
9225 q = p + 1;
9226 j = 1;
9227 L60:
9228 if (j > *n) {
9229 goto L70;
9230 }
9231 ++q;
9232 iwork[q] = j;
9233 j += nb;
9234 if (j >= *n) {
9235 goto L70;
9236 }
9237 if (b[j + (j - 1) * b_dim1] != 0.) {
9238 ++j;
9239 }
9240 goto L60;
9241 L70:
9242
9243 iwork[q + 1] = *n + 1;
9244 if (iwork[q] == iwork[q + 1]) {
9245 --q;
9246 }
9247
9248 if (notran) {
9249
9250 i__1 = isolve;
9251 for (iround = 1; iround <= i__1; ++iround) {
9252
9253 /* Solve (I, J)-subsystem */
9254 /* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) */
9255 /* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) */
9256 /* for I = P, P - 1,..., 1; J = 1, 2,..., Q */
9257
9258 dscale = 0.;
9259 dsum = 1.;
9260 pq = 0;
9261 *scale = 1.;
9262 i__2 = q;
9263 for (j = p + 2; j <= i__2; ++j) {
9264 js = iwork[j];
9265 je = iwork[j + 1] - 1;
9266 nb = je - js + 1;
9267 for (i__ = p; i__ >= 1; --i__) {
9268 is = iwork[i__];
9269 ie = iwork[i__ + 1] - 1;
9270 mb = ie - is + 1;
9271 ppqq = 0;
9272 dtgsy2_(trans, &ifunc, &mb, &nb, &a[is + is * a_dim1],
9273 lda, &b[js + js * b_dim1], ldb, &c__[is + js *
9274 c_dim1], ldc, &d__[is + is * d_dim1], ldd, &e[js
9275 + js * e_dim1], lde, &f[is + js * f_dim1], ldf, &
9276 scaloc, &dsum, &dscale, &iwork[q + 2], &ppqq, &
9277 linfo);
9278 if (linfo > 0) {
9279 *info = linfo;
9280 }
9281
9282 pq += ppqq;
9283 if (scaloc != 1.) {
9284 i__3 = js - 1;
9285 for (k = 1; k <= i__3; ++k) {
9286 dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1);
9287 dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
9288 /* L80: */
9289 }
9290 i__3 = je;
9291 for (k = js; k <= i__3; ++k) {
9292 i__4 = is - 1;
9293 dscal_(&i__4, &scaloc, &c__[k * c_dim1 + 1], &
9294 c__1);
9295 i__4 = is - 1;
9296 dscal_(&i__4, &scaloc, &f[k * f_dim1 + 1], &c__1);
9297 /* L90: */
9298 }
9299 i__3 = je;
9300 for (k = js; k <= i__3; ++k) {
9301 i__4 = *m - ie;
9302 dscal_(&i__4, &scaloc, &c__[ie + 1 + k * c_dim1],
9303 &c__1);
9304 i__4 = *m - ie;
9305 dscal_(&i__4, &scaloc, &f[ie + 1 + k * f_dim1], &
9306 c__1);
9307 /* L100: */
9308 }
9309 i__3 = *n;
9310 for (k = je + 1; k <= i__3; ++k) {
9311 dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1);
9312 dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
9313 /* L110: */
9314 }
9315 *scale *= scaloc;
9316 }
9317
9318 /* Substitute R(I, J) and L(I, J) into remaining */
9319 /* equation. */
9320
9321 if (i__ > 1) {
9322 i__3 = is - 1;
9323 dgemm_("N", "N", &i__3, &nb, &mb, &c_b51, &a[is *
9324 a_dim1 + 1], lda, &c__[is + js * c_dim1], ldc,
9325 &c_b52, &c__[js * c_dim1 + 1], ldc);
9326 i__3 = is - 1;
9327 dgemm_("N", "N", &i__3, &nb, &mb, &c_b51, &d__[is *
9328 d_dim1 + 1], ldd, &c__[is + js * c_dim1], ldc,
9329 &c_b52, &f[js * f_dim1 + 1], ldf);
9330 }
9331 if (j < q) {
9332 i__3 = *n - je;
9333 dgemm_("N", "N", &mb, &i__3, &nb, &c_b52, &f[is + js *
9334 f_dim1], ldf, &b[js + (je + 1) * b_dim1],
9335 ldb, &c_b52, &c__[is + (je + 1) * c_dim1],
9336 ldc);
9337 i__3 = *n - je;
9338 dgemm_("N", "N", &mb, &i__3, &nb, &c_b52, &f[is + js *
9339 f_dim1], ldf, &e[js + (je + 1) * e_dim1],
9340 lde, &c_b52, &f[is + (je + 1) * f_dim1], ldf);
9341 }
9342 /* L120: */
9343 }
9344 /* L130: */
9345 }
9346 if (dscale != 0.) {
9347 if (*ijob == 1 || *ijob == 3) {
9348 *dif = sqrt((double) ((*m << 1) * *n)) / (dscale *
9349 sqrt(dsum));
9350 } else {
9351 *dif = sqrt((double) pq) / (dscale * sqrt(dsum));
9352 }
9353 }
9354 if (isolve == 2 && iround == 1) {
9355 if (notran) {
9356 ifunc = *ijob;
9357 }
9358 scale2 = *scale;
9359 dlacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m);
9360 dlacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m);
9361 dlaset_("F", m, n, &c_b14, &c_b14, &c__[c_offset], ldc);
9362 dlaset_("F", m, n, &c_b14, &c_b14, &f[f_offset], ldf);
9363 } else if (isolve == 2 && iround == 2) {
9364 dlacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc);
9365 dlacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf);
9366 *scale = scale2;
9367 }
9368 /* L150: */
9369 }
9370
9371 } else {
9372
9373 /* Solve transposed (I, J)-subsystem */
9374 /* A(I, I)' * R(I, J) + D(I, I)' * L(I, J) = C(I, J) */
9375 /* R(I, J) * B(J, J)' + L(I, J) * E(J, J)' = -F(I, J) */
9376 /* for I = 1,2,..., P; J = Q, Q-1,..., 1 */
9377
9378 *scale = 1.;
9379 i__1 = p;
9380 for (i__ = 1; i__ <= i__1; ++i__) {
9381 is = iwork[i__];
9382 ie = iwork[i__ + 1] - 1;
9383 mb = ie - is + 1;
9384 i__2 = p + 2;
9385 for (j = q; j >= i__2; --j) {
9386 js = iwork[j];
9387 je = iwork[j + 1] - 1;
9388 nb = je - js + 1;
9389 dtgsy2_(trans, &ifunc, &mb, &nb, &a[is + is * a_dim1], lda, &
9390 b[js + js * b_dim1], ldb, &c__[is + js * c_dim1], ldc,
9391 &d__[is + is * d_dim1], ldd, &e[js + js * e_dim1],
9392 lde, &f[is + js * f_dim1], ldf, &scaloc, &dsum, &
9393 dscale, &iwork[q + 2], &ppqq, &linfo);
9394 if (linfo > 0) {
9395 *info = linfo;
9396 }
9397 if (scaloc != 1.) {
9398 i__3 = js - 1;
9399 for (k = 1; k <= i__3; ++k) {
9400 dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1);
9401 dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
9402 /* L160: */
9403 }
9404 i__3 = je;
9405 for (k = js; k <= i__3; ++k) {
9406 i__4 = is - 1;
9407 dscal_(&i__4, &scaloc, &c__[k * c_dim1 + 1], &c__1);
9408 i__4 = is - 1;
9409 dscal_(&i__4, &scaloc, &f[k * f_dim1 + 1], &c__1);
9410 /* L170: */
9411 }
9412 i__3 = je;
9413 for (k = js; k <= i__3; ++k) {
9414 i__4 = *m - ie;
9415 dscal_(&i__4, &scaloc, &c__[ie + 1 + k * c_dim1], &
9416 c__1);
9417 i__4 = *m - ie;
9418 dscal_(&i__4, &scaloc, &f[ie + 1 + k * f_dim1], &c__1)
9419 ;
9420 /* L180: */
9421 }
9422 i__3 = *n;
9423 for (k = je + 1; k <= i__3; ++k) {
9424 dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1);
9425 dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
9426 /* L190: */
9427 }
9428 *scale *= scaloc;
9429 }
9430
9431 /* Substitute R(I, J) and L(I, J) into remaining equation. */
9432
9433 if (j > p + 2) {
9434 i__3 = js - 1;
9435 dgemm_("N", "T", &mb, &i__3, &nb, &c_b52, &c__[is + js *
9436 c_dim1], ldc, &b[js * b_dim1 + 1], ldb, &c_b52, &
9437 f[is + f_dim1], ldf);
9438 i__3 = js - 1;
9439 dgemm_("N", "T", &mb, &i__3, &nb, &c_b52, &f[is + js *
9440 f_dim1], ldf, &e[js * e_dim1 + 1], lde, &c_b52, &
9441 f[is + f_dim1], ldf);
9442 }
9443 if (i__ < p) {
9444 i__3 = *m - ie;
9445 dgemm_("T", "N", &i__3, &nb, &mb, &c_b51, &a[is + (ie + 1)
9446 * a_dim1], lda, &c__[is + js * c_dim1], ldc, &
9447 c_b52, &c__[ie + 1 + js * c_dim1], ldc);
9448 i__3 = *m - ie;
9449 dgemm_("T", "N", &i__3, &nb, &mb, &c_b51, &d__[is + (ie +
9450 1) * d_dim1], ldd, &f[is + js * f_dim1], ldf, &
9451 c_b52, &c__[ie + 1 + js * c_dim1], ldc);
9452 }
9453 /* L200: */
9454 }
9455 /* L210: */
9456 }
9457
9458 }
9459
9460 work[1] = (double) lwmin;
9461
9462 return 0;
9463
9464 /* End of DTGSYL */
9465
9466 } /* dtgsyl_ */
9467
dtpcon_(const char * norm,const char * uplo,const char * diag,integer * n,double * ap,double * rcond,double * work,integer * iwork,integer * info)9468 /* Subroutine */ int dtpcon_(const char *norm, const char *uplo, const char *diag, integer *n,
9469 double *ap, double *rcond, double *work, integer *iwork,
9470 integer *info)
9471 {
9472 /* Table of constant values */
9473 static integer c__1 = 1;
9474
9475 /* System generated locals */
9476 integer i__1;
9477 double d__1;
9478
9479 /* Local variables */
9480 integer ix, kase, kase1;
9481 double scale;
9482 integer isave[3];
9483 double anorm;
9484 bool upper;
9485 double xnorm;
9486 double ainvnm;
9487 bool onenrm;
9488 char normin[1];
9489 double smlnum;
9490 bool nounit;
9491
9492
9493 /* -- LAPACK routine (version 3.1) -- */
9494 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
9495 /* November 2006 */
9496
9497 /* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
9498
9499 /* .. Scalar Arguments .. */
9500 /* .. */
9501 /* .. Array Arguments .. */
9502 /* .. */
9503
9504 /* Purpose */
9505 /* ======= */
9506
9507 /* DTPCON estimates the reciprocal of the condition number of a packed */
9508 /* triangular matrix A, in either the 1-norm or the infinity-norm. */
9509
9510 /* The norm of A is computed and an estimate is obtained for */
9511 /* norm(inv(A)), then the reciprocal of the condition number is */
9512 /* computed as */
9513 /* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
9514
9515 /* Arguments */
9516 /* ========= */
9517
9518 /* NORM (input) CHARACTER*1 */
9519 /* Specifies whether the 1-norm condition number or the */
9520 /* infinity-norm condition number is required: */
9521 /* = '1' or 'O': 1-norm; */
9522 /* = 'I': Infinity-norm. */
9523
9524 /* UPLO (input) CHARACTER*1 */
9525 /* = 'U': A is upper triangular; */
9526 /* = 'L': A is lower triangular. */
9527
9528 /* DIAG (input) CHARACTER*1 */
9529 /* = 'N': A is non-unit triangular; */
9530 /* = 'U': A is unit triangular. */
9531
9532 /* N (input) INTEGER */
9533 /* The order of the matrix A. N >= 0. */
9534
9535 /* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
9536 /* The upper or lower triangular matrix A, packed columnwise in */
9537 /* a linear array. The j-th column of A is stored in the array */
9538 /* AP as follows: */
9539 /* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
9540 /* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
9541 /* If DIAG = 'U', the diagonal elements of A are not referenced */
9542 /* and are assumed to be 1. */
9543
9544 /* RCOND (output) DOUBLE PRECISION */
9545 /* The reciprocal of the condition number of the matrix A, */
9546 /* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
9547
9548 /* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
9549
9550 /* IWORK (workspace) INTEGER array, dimension (N) */
9551
9552 /* INFO (output) INTEGER */
9553 /* = 0: successful exit */
9554 /* < 0: if INFO = -i, the i-th argument had an illegal value */
9555
9556 /* ===================================================================== */
9557
9558 /* .. Parameters .. */
9559 /* .. */
9560 /* .. Local Scalars .. */
9561 /* .. */
9562 /* .. Local Arrays .. */
9563 /* .. */
9564 /* .. External Functions .. */
9565 /* .. */
9566 /* .. External Subroutines .. */
9567 /* .. */
9568 /* .. Intrinsic Functions .. */
9569 /* .. */
9570 /* .. Executable Statements .. */
9571
9572 /* Test the input parameters. */
9573
9574 /* Parameter adjustments */
9575 --iwork;
9576 --work;
9577 --ap;
9578
9579 /* Function Body */
9580 *info = 0;
9581 upper = lsame_(uplo, "U");
9582 onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
9583 nounit = lsame_(diag, "N");
9584
9585 if (! onenrm && ! lsame_(norm, "I")) {
9586 *info = -1;
9587 } else if (! upper && ! lsame_(uplo, "L")) {
9588 *info = -2;
9589 } else if (! nounit && ! lsame_(diag, "U")) {
9590 *info = -3;
9591 } else if (*n < 0) {
9592 *info = -4;
9593 }
9594 if (*info != 0) {
9595 i__1 = -(*info);
9596 xerbla_("DTPCON", &i__1);
9597 return 0;
9598 }
9599
9600 /* Quick return if possible */
9601
9602 if (*n == 0) {
9603 *rcond = 1.;
9604 return 0;
9605 }
9606
9607 *rcond = 0.;
9608 smlnum = dlamch_("Safe minimum") * (double) std::max(1_integer,*n);
9609
9610 /* Compute the norm of the triangular matrix A. */
9611
9612 anorm = dlantp_(norm, uplo, diag, n, &ap[1], &work[1]);
9613
9614 /* Continue only if ANORM > 0. */
9615
9616 if (anorm > 0.) {
9617
9618 /* Estimate the norm of the inverse of A. */
9619
9620 ainvnm = 0.;
9621 *(unsigned char *)normin = 'N';
9622 if (onenrm) {
9623 kase1 = 1;
9624 } else {
9625 kase1 = 2;
9626 }
9627 kase = 0;
9628 L10:
9629 dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
9630 if (kase != 0) {
9631 if (kase == kase1) {
9632
9633 /* Multiply by inv(A). */
9634
9635 dlatps_(uplo, "No transpose", diag, normin, n, &ap[1], &work[
9636 1], &scale, &work[(*n << 1) + 1], info);
9637 } else {
9638
9639 /* Multiply by inv(A'). */
9640
9641 dlatps_(uplo, "Transpose", diag, normin, n, &ap[1], &work[1],
9642 &scale, &work[(*n << 1) + 1], info);
9643 }
9644 *(unsigned char *)normin = 'Y';
9645
9646 /* Multiply by 1/SCALE if doing so will not cause overflow. */
9647
9648 if (scale != 1.) {
9649 ix = idamax_(n, &work[1], &c__1);
9650 xnorm = (d__1 = work[ix], abs(d__1));
9651 if (scale < xnorm * smlnum || scale == 0.) {
9652 goto L20;
9653 }
9654 drscl_(n, &scale, &work[1], &c__1);
9655 }
9656 goto L10;
9657 }
9658
9659 /* Compute the estimate of the reciprocal condition number. */
9660
9661 if (ainvnm != 0.) {
9662 *rcond = 1. / anorm / ainvnm;
9663 }
9664 }
9665
9666 L20:
9667 return 0;
9668
9669 /* End of DTPCON */
9670
9671 } /* dtpcon_ */
9672
dtprfs_(const char * uplo,const char * trans,const char * diag,integer * n,integer * nrhs,double * ap,double * b,integer * ldb,double * x,integer * ldx,double * ferr,double * berr,double * work,integer * iwork,integer * info)9673 /* Subroutine */ int dtprfs_(const char *uplo, const char *trans, const char *diag, integer *n,
9674 integer *nrhs, double *ap, double *b, integer *ldb,
9675 double *x, integer *ldx, double *ferr, double *berr,
9676 double *work, integer *iwork, integer *info)
9677 {
9678 /* Table of constant values */
9679 static integer c__1 = 1;
9680 static double c_b19 = -1.;
9681
9682 /* System generated locals */
9683 integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3;
9684 double d__1, d__2, d__3;
9685
9686 /* Local variables */
9687 integer i__, j, k;
9688 double s;
9689 integer kc;
9690 double xk;
9691 integer nz;
9692 double eps;
9693 integer kase;
9694 double safe1, safe2;
9695 integer isave[3];
9696 bool upper;
9697 double safmin;
9698 bool notran;
9699 char transt[1];
9700 bool nounit;
9701 double lstres;
9702
9703
9704 /* -- LAPACK routine (version 3.1) -- */
9705 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
9706 /* November 2006 */
9707
9708 /* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
9709
9710 /* .. Scalar Arguments .. */
9711 /* .. */
9712 /* .. Array Arguments .. */
9713 /* .. */
9714
9715 /* Purpose */
9716 /* ======= */
9717
9718 /* DTPRFS provides error bounds and backward error estimates for the */
9719 /* solution to a system of linear equations with a triangular packed */
9720 /* coefficient matrix. */
9721
9722 /* The solution matrix X must be computed by DTPTRS or some other */
9723 /* means before entering this routine. DTPRFS does not do iterative */
9724 /* refinement because doing so cannot improve the backward error. */
9725
9726 /* Arguments */
9727 /* ========= */
9728
9729 /* UPLO (input) CHARACTER*1 */
9730 /* = 'U': A is upper triangular; */
9731 /* = 'L': A is lower triangular. */
9732
9733 /* TRANS (input) CHARACTER*1 */
9734 /* Specifies the form of the system of equations: */
9735 /* = 'N': A * X = B (No transpose) */
9736 /* = 'T': A**T * X = B (Transpose) */
9737 /* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
9738
9739 /* DIAG (input) CHARACTER*1 */
9740 /* = 'N': A is non-unit triangular; */
9741 /* = 'U': A is unit triangular. */
9742
9743 /* N (input) INTEGER */
9744 /* The order of the matrix A. N >= 0. */
9745
9746 /* NRHS (input) INTEGER */
9747 /* The number of right hand sides, i.e., the number of columns */
9748 /* of the matrices B and X. NRHS >= 0. */
9749
9750 /* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
9751 /* The upper or lower triangular matrix A, packed columnwise in */
9752 /* a linear array. The j-th column of A is stored in the array */
9753 /* AP as follows: */
9754 /* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
9755 /* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
9756 /* If DIAG = 'U', the diagonal elements of A are not referenced */
9757 /* and are assumed to be 1. */
9758
9759 /* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
9760 /* The right hand side matrix B. */
9761
9762 /* LDB (input) INTEGER */
9763 /* The leading dimension of the array B. LDB >= max(1,N). */
9764
9765 /* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
9766 /* The solution matrix X. */
9767
9768 /* LDX (input) INTEGER */
9769 /* The leading dimension of the array X. LDX >= max(1,N). */
9770
9771 /* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
9772 /* The estimated forward error bound for each solution vector */
9773 /* X(j) (the j-th column of the solution matrix X). */
9774 /* If XTRUE is the true solution corresponding to X(j), FERR(j) */
9775 /* is an estimated upper bound for the magnitude of the largest */
9776 /* element in (X(j) - XTRUE) divided by the magnitude of the */
9777 /* largest element in X(j). The estimate is as reliable as */
9778 /* the estimate for RCOND, and is almost always a slight */
9779 /* overestimate of the true error. */
9780
9781 /* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
9782 /* The componentwise relative backward error of each solution */
9783 /* vector X(j) (i.e., the smallest relative change in */
9784 /* any element of A or B that makes X(j) an exact solution). */
9785
9786 /* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
9787
9788 /* IWORK (workspace) INTEGER array, dimension (N) */
9789
9790 /* INFO (output) INTEGER */
9791 /* = 0: successful exit */
9792 /* < 0: if INFO = -i, the i-th argument had an illegal value */
9793
9794 /* ===================================================================== */
9795
9796 /* .. Parameters .. */
9797 /* .. */
9798 /* .. Local Scalars .. */
9799 /* .. */
9800 /* .. Local Arrays .. */
9801 /* .. */
9802 /* .. External Subroutines .. */
9803 /* .. */
9804 /* .. Intrinsic Functions .. */
9805 /* .. */
9806 /* .. External Functions .. */
9807 /* .. */
9808 /* .. Executable Statements .. */
9809
9810 /* Test the input parameters. */
9811
9812 /* Parameter adjustments */
9813 --ap;
9814 b_dim1 = *ldb;
9815 b_offset = 1 + b_dim1;
9816 b -= b_offset;
9817 x_dim1 = *ldx;
9818 x_offset = 1 + x_dim1;
9819 x -= x_offset;
9820 --ferr;
9821 --berr;
9822 --work;
9823 --iwork;
9824
9825 /* Function Body */
9826 *info = 0;
9827 upper = lsame_(uplo, "U");
9828 notran = lsame_(trans, "N");
9829 nounit = lsame_(diag, "N");
9830
9831 if (! upper && ! lsame_(uplo, "L")) {
9832 *info = -1;
9833 } else if (! notran && ! lsame_(trans, "T") && !
9834 lsame_(trans, "C")) {
9835 *info = -2;
9836 } else if (! nounit && ! lsame_(diag, "U")) {
9837 *info = -3;
9838 } else if (*n < 0) {
9839 *info = -4;
9840 } else if (*nrhs < 0) {
9841 *info = -5;
9842 } else if (*ldb < std::max(1_integer,*n)) {
9843 *info = -8;
9844 } else if (*ldx < std::max(1_integer,*n)) {
9845 *info = -10;
9846 }
9847 if (*info != 0) {
9848 i__1 = -(*info);
9849 xerbla_("DTPRFS", &i__1);
9850 return 0;
9851 }
9852
9853 /* Quick return if possible */
9854
9855 if (*n == 0 || *nrhs == 0) {
9856 i__1 = *nrhs;
9857 for (j = 1; j <= i__1; ++j) {
9858 ferr[j] = 0.;
9859 berr[j] = 0.;
9860 /* L10: */
9861 }
9862 return 0;
9863 }
9864
9865 if (notran) {
9866 *(unsigned char *)transt = 'T';
9867 } else {
9868 *(unsigned char *)transt = 'N';
9869 }
9870
9871 /* NZ = maximum number of nonzero elements in each row of A, plus 1 */
9872
9873 nz = *n + 1;
9874 eps = dlamch_("Epsilon");
9875 safmin = dlamch_("Safe minimum");
9876 safe1 = nz * safmin;
9877 safe2 = safe1 / eps;
9878
9879 /* Do for each right hand side */
9880
9881 i__1 = *nrhs;
9882 for (j = 1; j <= i__1; ++j) {
9883
9884 /* Compute residual R = B - op(A) * X, */
9885 /* where op(A) = A or A', depending on TRANS. */
9886
9887 dcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[*n + 1], &c__1);
9888 dtpmv_(uplo, trans, diag, n, &ap[1], &work[*n + 1], &c__1);
9889 daxpy_(n, &c_b19, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
9890
9891 /* Compute componentwise relative backward error from formula */
9892
9893 /* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
9894
9895 /* where abs(Z) is the componentwise absolute value of the matrix */
9896 /* or vector Z. If the i-th component of the denominator is less */
9897 /* than SAFE2, then SAFE1 is added to the i-th components of the */
9898 /* numerator and denominator before dividing. */
9899
9900 i__2 = *n;
9901 for (i__ = 1; i__ <= i__2; ++i__) {
9902 work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1));
9903 /* L20: */
9904 }
9905
9906 if (notran) {
9907
9908 /* Compute abs(A)*abs(X) + abs(B). */
9909
9910 if (upper) {
9911 kc = 1;
9912 if (nounit) {
9913 i__2 = *n;
9914 for (k = 1; k <= i__2; ++k) {
9915 xk = (d__1 = x[k + j * x_dim1], abs(d__1));
9916 i__3 = k;
9917 for (i__ = 1; i__ <= i__3; ++i__) {
9918 work[i__] += (d__1 = ap[kc + i__ - 1], abs(d__1))
9919 * xk;
9920 /* L30: */
9921 }
9922 kc += k;
9923 /* L40: */
9924 }
9925 } else {
9926 i__2 = *n;
9927 for (k = 1; k <= i__2; ++k) {
9928 xk = (d__1 = x[k + j * x_dim1], abs(d__1));
9929 i__3 = k - 1;
9930 for (i__ = 1; i__ <= i__3; ++i__) {
9931 work[i__] += (d__1 = ap[kc + i__ - 1], abs(d__1))
9932 * xk;
9933 /* L50: */
9934 }
9935 work[k] += xk;
9936 kc += k;
9937 /* L60: */
9938 }
9939 }
9940 } else {
9941 kc = 1;
9942 if (nounit) {
9943 i__2 = *n;
9944 for (k = 1; k <= i__2; ++k) {
9945 xk = (d__1 = x[k + j * x_dim1], abs(d__1));
9946 i__3 = *n;
9947 for (i__ = k; i__ <= i__3; ++i__) {
9948 work[i__] += (d__1 = ap[kc + i__ - k], abs(d__1))
9949 * xk;
9950 /* L70: */
9951 }
9952 kc = kc + *n - k + 1;
9953 /* L80: */
9954 }
9955 } else {
9956 i__2 = *n;
9957 for (k = 1; k <= i__2; ++k) {
9958 xk = (d__1 = x[k + j * x_dim1], abs(d__1));
9959 i__3 = *n;
9960 for (i__ = k + 1; i__ <= i__3; ++i__) {
9961 work[i__] += (d__1 = ap[kc + i__ - k], abs(d__1))
9962 * xk;
9963 /* L90: */
9964 }
9965 work[k] += xk;
9966 kc = kc + *n - k + 1;
9967 /* L100: */
9968 }
9969 }
9970 }
9971 } else {
9972
9973 /* Compute abs(A')*abs(X) + abs(B). */
9974
9975 if (upper) {
9976 kc = 1;
9977 if (nounit) {
9978 i__2 = *n;
9979 for (k = 1; k <= i__2; ++k) {
9980 s = 0.;
9981 i__3 = k;
9982 for (i__ = 1; i__ <= i__3; ++i__) {
9983 s += (d__1 = ap[kc + i__ - 1], abs(d__1)) * (d__2
9984 = x[i__ + j * x_dim1], abs(d__2));
9985 /* L110: */
9986 }
9987 work[k] += s;
9988 kc += k;
9989 /* L120: */
9990 }
9991 } else {
9992 i__2 = *n;
9993 for (k = 1; k <= i__2; ++k) {
9994 s = (d__1 = x[k + j * x_dim1], abs(d__1));
9995 i__3 = k - 1;
9996 for (i__ = 1; i__ <= i__3; ++i__) {
9997 s += (d__1 = ap[kc + i__ - 1], abs(d__1)) * (d__2
9998 = x[i__ + j * x_dim1], abs(d__2));
9999 /* L130: */
10000 }
10001 work[k] += s;
10002 kc += k;
10003 /* L140: */
10004 }
10005 }
10006 } else {
10007 kc = 1;
10008 if (nounit) {
10009 i__2 = *n;
10010 for (k = 1; k <= i__2; ++k) {
10011 s = 0.;
10012 i__3 = *n;
10013 for (i__ = k; i__ <= i__3; ++i__) {
10014 s += (d__1 = ap[kc + i__ - k], abs(d__1)) * (d__2
10015 = x[i__ + j * x_dim1], abs(d__2));
10016 /* L150: */
10017 }
10018 work[k] += s;
10019 kc = kc + *n - k + 1;
10020 /* L160: */
10021 }
10022 } else {
10023 i__2 = *n;
10024 for (k = 1; k <= i__2; ++k) {
10025 s = (d__1 = x[k + j * x_dim1], abs(d__1));
10026 i__3 = *n;
10027 for (i__ = k + 1; i__ <= i__3; ++i__) {
10028 s += (d__1 = ap[kc + i__ - k], abs(d__1)) * (d__2
10029 = x[i__ + j * x_dim1], abs(d__2));
10030 /* L170: */
10031 }
10032 work[k] += s;
10033 kc = kc + *n - k + 1;
10034 /* L180: */
10035 }
10036 }
10037 }
10038 }
10039 s = 0.;
10040 i__2 = *n;
10041 for (i__ = 1; i__ <= i__2; ++i__) {
10042 if (work[i__] > safe2) {
10043 /* Computing MAX */
10044 d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[
10045 i__];
10046 s = std::max(d__2,d__3);
10047 } else {
10048 /* Computing MAX */
10049 d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1)
10050 / (work[i__] + safe1);
10051 s = std::max(d__2,d__3);
10052 }
10053 /* L190: */
10054 }
10055 berr[j] = s;
10056
10057 /* Bound error from formula */
10058
10059 /* norm(X - XTRUE) / norm(X) .le. FERR = */
10060 /* norm( abs(inv(op(A)))* */
10061 /* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
10062
10063 /* where */
10064 /* norm(Z) is the magnitude of the largest component of Z */
10065 /* inv(op(A)) is the inverse of op(A) */
10066 /* abs(Z) is the componentwise absolute value of the matrix or */
10067 /* vector Z */
10068 /* NZ is the maximum number of nonzeros in any row of A, plus 1 */
10069 /* EPS is machine epsilon */
10070
10071 /* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
10072 /* is incremented by SAFE1 if the i-th component of */
10073 /* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
10074
10075 /* Use DLACN2 to estimate the infinity-norm of the matrix */
10076 /* inv(op(A)) * diag(W), */
10077 /* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
10078
10079 i__2 = *n;
10080 for (i__ = 1; i__ <= i__2; ++i__) {
10081 if (work[i__] > safe2) {
10082 work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
10083 work[i__];
10084 } else {
10085 work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
10086 work[i__] + safe1;
10087 }
10088 /* L200: */
10089 }
10090
10091 kase = 0;
10092 L210:
10093 dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
10094 kase, isave);
10095 if (kase != 0) {
10096 if (kase == 1) {
10097
10098 /* Multiply by diag(W)*inv(op(A)'). */
10099
10100 dtpsv_(uplo, transt, diag, n, &ap[1], &work[*n + 1], &c__1);
10101 i__2 = *n;
10102 for (i__ = 1; i__ <= i__2; ++i__) {
10103 work[*n + i__] = work[i__] * work[*n + i__];
10104 /* L220: */
10105 }
10106 } else {
10107
10108 /* Multiply by inv(op(A))*diag(W). */
10109
10110 i__2 = *n;
10111 for (i__ = 1; i__ <= i__2; ++i__) {
10112 work[*n + i__] = work[i__] * work[*n + i__];
10113 /* L230: */
10114 }
10115 dtpsv_(uplo, trans, diag, n, &ap[1], &work[*n + 1], &c__1);
10116 }
10117 goto L210;
10118 }
10119
10120 /* Normalize error. */
10121
10122 lstres = 0.;
10123 i__2 = *n;
10124 for (i__ = 1; i__ <= i__2; ++i__) {
10125 /* Computing MAX */
10126 d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1));
10127 lstres = std::max(d__2,d__3);
10128 /* L240: */
10129 }
10130 if (lstres != 0.) {
10131 ferr[j] /= lstres;
10132 }
10133
10134 /* L250: */
10135 }
10136
10137 return 0;
10138
10139 /* End of DTPRFS */
10140
10141 } /* dtprfs_ */
10142
dtptri_(const char * uplo,const char * diag,integer * n,double * ap,integer * info)10143 /* Subroutine */ int dtptri_(const char *uplo, const char *diag, integer *n, double *
10144 ap, integer *info)
10145 {
10146 /* Table of constant values */
10147 static integer c__1 = 1;
10148
10149 /* System generated locals */
10150 integer i__1, i__2;
10151
10152 /* Local variables */
10153 integer j, jc, jj;
10154 double ajj;
10155 bool upper;
10156 integer jclast;
10157 bool nounit;
10158
10159
10160 /* -- LAPACK routine (version 3.1) -- */
10161 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
10162 /* November 2006 */
10163
10164 /* .. Scalar Arguments .. */
10165 /* .. */
10166 /* .. Array Arguments .. */
10167 /* .. */
10168
10169 /* Purpose */
10170 /* ======= */
10171
10172 /* DTPTRI computes the inverse of a real upper or lower triangular */
10173 /* matrix A stored in packed format. */
10174
10175 /* Arguments */
10176 /* ========= */
10177
10178 /* UPLO (input) CHARACTER*1 */
10179 /* = 'U': A is upper triangular; */
10180 /* = 'L': A is lower triangular. */
10181
10182 /* DIAG (input) CHARACTER*1 */
10183 /* = 'N': A is non-unit triangular; */
10184 /* = 'U': A is unit triangular. */
10185
10186 /* N (input) INTEGER */
10187 /* The order of the matrix A. N >= 0. */
10188
10189 /* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
10190 /* On entry, the upper or lower triangular matrix A, stored */
10191 /* columnwise in a linear array. The j-th column of A is stored */
10192 /* in the array AP as follows: */
10193 /* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
10194 /* if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n. */
10195 /* See below for further details. */
10196 /* On exit, the (triangular) inverse of the original matrix, in */
10197 /* the same packed storage format. */
10198
10199 /* INFO (output) INTEGER */
10200 /* = 0: successful exit */
10201 /* < 0: if INFO = -i, the i-th argument had an illegal value */
10202 /* > 0: if INFO = i, A(i,i) is exactly zero. The triangular */
10203 /* matrix is singular and its inverse can not be computed. */
10204
10205 /* Further Details */
10206 /* =============== */
10207
10208 /* A triangular matrix A can be transferred to packed storage using one */
10209 /* of the following program segments: */
10210
10211 /* UPLO = 'U': UPLO = 'L': */
10212
10213 /* JC = 1 JC = 1 */
10214 /* DO 2 J = 1, N DO 2 J = 1, N */
10215 /* DO 1 I = 1, J DO 1 I = J, N */
10216 /* AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J) */
10217 /* 1 CONTINUE 1 CONTINUE */
10218 /* JC = JC + J JC = JC + N - J + 1 */
10219 /* 2 CONTINUE 2 CONTINUE */
10220
10221 /* ===================================================================== */
10222
10223 /* .. Parameters .. */
10224 /* .. */
10225 /* .. Local Scalars .. */
10226 /* .. */
10227 /* .. External Functions .. */
10228 /* .. */
10229 /* .. External Subroutines .. */
10230 /* .. */
10231 /* .. Executable Statements .. */
10232
10233 /* Test the input parameters. */
10234
10235 /* Parameter adjustments */
10236 --ap;
10237
10238 /* Function Body */
10239 *info = 0;
10240 upper = lsame_(uplo, "U");
10241 nounit = lsame_(diag, "N");
10242 if (! upper && ! lsame_(uplo, "L")) {
10243 *info = -1;
10244 } else if (! nounit && ! lsame_(diag, "U")) {
10245 *info = -2;
10246 } else if (*n < 0) {
10247 *info = -3;
10248 }
10249 if (*info != 0) {
10250 i__1 = -(*info);
10251 xerbla_("DTPTRI", &i__1);
10252 return 0;
10253 }
10254
10255 /* Check for singularity if non-unit. */
10256
10257 if (nounit) {
10258 if (upper) {
10259 jj = 0;
10260 i__1 = *n;
10261 for (*info = 1; *info <= i__1; ++(*info)) {
10262 jj += *info;
10263 if (ap[jj] == 0.) {
10264 return 0;
10265 }
10266 /* L10: */
10267 }
10268 } else {
10269 jj = 1;
10270 i__1 = *n;
10271 for (*info = 1; *info <= i__1; ++(*info)) {
10272 if (ap[jj] == 0.) {
10273 return 0;
10274 }
10275 jj = jj + *n - *info + 1;
10276 /* L20: */
10277 }
10278 }
10279 *info = 0;
10280 }
10281
10282 if (upper) {
10283
10284 /* Compute inverse of upper triangular matrix. */
10285
10286 jc = 1;
10287 i__1 = *n;
10288 for (j = 1; j <= i__1; ++j) {
10289 if (nounit) {
10290 ap[jc + j - 1] = 1. / ap[jc + j - 1];
10291 ajj = -ap[jc + j - 1];
10292 } else {
10293 ajj = -1.;
10294 }
10295
10296 /* Compute elements 1:j-1 of j-th column. */
10297
10298 i__2 = j - 1;
10299 dtpmv_("Upper", "No transpose", diag, &i__2, &ap[1], &ap[jc], &
10300 c__1);
10301 i__2 = j - 1;
10302 dscal_(&i__2, &ajj, &ap[jc], &c__1);
10303 jc += j;
10304 /* L30: */
10305 }
10306
10307 } else {
10308
10309 /* Compute inverse of lower triangular matrix. */
10310
10311 jc = *n * (*n + 1) / 2;
10312 for (j = *n; j >= 1; --j) {
10313 if (nounit) {
10314 ap[jc] = 1. / ap[jc];
10315 ajj = -ap[jc];
10316 } else {
10317 ajj = -1.;
10318 }
10319 if (j < *n) {
10320
10321 /* Compute elements j+1:n of j-th column. */
10322
10323 i__1 = *n - j;
10324 dtpmv_("Lower", "No transpose", diag, &i__1, &ap[jclast], &ap[
10325 jc + 1], &c__1);
10326 i__1 = *n - j;
10327 dscal_(&i__1, &ajj, &ap[jc + 1], &c__1);
10328 }
10329 jclast = jc;
10330 jc = jc - *n + j - 2;
10331 /* L40: */
10332 }
10333 }
10334
10335 return 0;
10336
10337 /* End of DTPTRI */
10338
10339 } /* dtptri_ */
10340
dtptrs_(const char * uplo,const char * trans,const char * diag,integer * n,integer * nrhs,double * ap,double * b,integer * ldb,integer * info)10341 /* Subroutine */ int dtptrs_(const char *uplo, const char *trans, const char *diag, integer *n,
10342 integer *nrhs, double *ap, double *b, integer *ldb, integer *
10343 info)
10344 {
10345 /* Table of constant values */
10346 static integer c__1 = 1;
10347
10348 /* System generated locals */
10349 integer b_dim1, b_offset, i__1;
10350
10351 /* Local variables */
10352 integer j, jc;
10353 bool upper;
10354 bool nounit;
10355
10356
10357 /* -- LAPACK routine (version 3.1) -- */
10358 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
10359 /* November 2006 */
10360
10361 /* .. Scalar Arguments .. */
10362 /* .. */
10363 /* .. Array Arguments .. */
10364 /* .. */
10365
10366 /* Purpose */
10367 /* ======= */
10368
10369 /* DTPTRS solves a triangular system of the form */
10370
10371 /* A * X = B or A**T * X = B, */
10372
10373 /* where A is a triangular matrix of order N stored in packed format, */
10374 /* and B is an N-by-NRHS matrix. A check is made to verify that A is */
10375 /* nonsingular. */
10376
10377 /* Arguments */
10378 /* ========= */
10379
10380 /* UPLO (input) CHARACTER*1 */
10381 /* = 'U': A is upper triangular; */
10382 /* = 'L': A is lower triangular. */
10383
10384 /* TRANS (input) CHARACTER*1 */
10385 /* Specifies the form of the system of equations: */
10386 /* = 'N': A * X = B (No transpose) */
10387 /* = 'T': A**T * X = B (Transpose) */
10388 /* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
10389
10390 /* DIAG (input) CHARACTER*1 */
10391 /* = 'N': A is non-unit triangular; */
10392 /* = 'U': A is unit triangular. */
10393
10394 /* N (input) INTEGER */
10395 /* The order of the matrix A. N >= 0. */
10396
10397 /* NRHS (input) INTEGER */
10398 /* The number of right hand sides, i.e., the number of columns */
10399 /* of the matrix B. NRHS >= 0. */
10400
10401 /* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
10402 /* The upper or lower triangular matrix A, packed columnwise in */
10403 /* a linear array. The j-th column of A is stored in the array */
10404 /* AP as follows: */
10405 /* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
10406 /* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
10407
10408 /* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
10409 /* On entry, the right hand side matrix B. */
10410 /* On exit, if INFO = 0, the solution matrix X. */
10411
10412 /* LDB (input) INTEGER */
10413 /* The leading dimension of the array B. LDB >= max(1,N). */
10414
10415 /* INFO (output) INTEGER */
10416 /* = 0: successful exit */
10417 /* < 0: if INFO = -i, the i-th argument had an illegal value */
10418 /* > 0: if INFO = i, the i-th diagonal element of A is zero, */
10419 /* indicating that the matrix is singular and the */
10420 /* solutions X have not been computed. */
10421
10422 /* ===================================================================== */
10423
10424 /* .. Parameters .. */
10425 /* .. */
10426 /* .. Local Scalars .. */
10427 /* .. */
10428 /* .. External Functions .. */
10429 /* .. */
10430 /* .. External Subroutines .. */
10431 /* .. */
10432 /* .. Intrinsic Functions .. */
10433 /* .. */
10434 /* .. Executable Statements .. */
10435
10436 /* Test the input parameters. */
10437
10438 /* Parameter adjustments */
10439 --ap;
10440 b_dim1 = *ldb;
10441 b_offset = 1 + b_dim1;
10442 b -= b_offset;
10443
10444 /* Function Body */
10445 *info = 0;
10446 upper = lsame_(uplo, "U");
10447 nounit = lsame_(diag, "N");
10448 if (! upper && ! lsame_(uplo, "L")) {
10449 *info = -1;
10450 } else if (! lsame_(trans, "N") && ! lsame_(trans,
10451 "T") && ! lsame_(trans, "C")) {
10452 *info = -2;
10453 } else if (! nounit && ! lsame_(diag, "U")) {
10454 *info = -3;
10455 } else if (*n < 0) {
10456 *info = -4;
10457 } else if (*nrhs < 0) {
10458 *info = -5;
10459 } else if (*ldb < std::max(1_integer,*n)) {
10460 *info = -8;
10461 }
10462 if (*info != 0) {
10463 i__1 = -(*info);
10464 xerbla_("DTPTRS", &i__1);
10465 return 0;
10466 }
10467
10468 /* Quick return if possible */
10469
10470 if (*n == 0) {
10471 return 0;
10472 }
10473
10474 /* Check for singularity. */
10475
10476 if (nounit) {
10477 if (upper) {
10478 jc = 1;
10479 i__1 = *n;
10480 for (*info = 1; *info <= i__1; ++(*info)) {
10481 if (ap[jc + *info - 1] == 0.) {
10482 return 0;
10483 }
10484 jc += *info;
10485 /* L10: */
10486 }
10487 } else {
10488 jc = 1;
10489 i__1 = *n;
10490 for (*info = 1; *info <= i__1; ++(*info)) {
10491 if (ap[jc] == 0.) {
10492 return 0;
10493 }
10494 jc = jc + *n - *info + 1;
10495 /* L20: */
10496 }
10497 }
10498 }
10499 *info = 0;
10500
10501 /* Solve A * x = b or A' * x = b. */
10502
10503 i__1 = *nrhs;
10504 for (j = 1; j <= i__1; ++j) {
10505 dtpsv_(uplo, trans, diag, n, &ap[1], &b[j * b_dim1 + 1], &c__1);
10506 /* L30: */
10507 }
10508
10509 return 0;
10510
10511 /* End of DTPTRS */
10512
10513 } /* dtptrs_ */
10514
dtpttf_(const char * transr,const char * uplo,integer * n,double * ap,double * arf,integer * info)10515 int dtpttf_(const char *transr, const char *uplo, integer *n, double *ap, double *arf, integer *info)
10516 {
10517 /* System generated locals */
10518 integer i__1, i__2, i__3;
10519
10520 /* Local variables */
10521 integer i__, j, k, n1, n2, ij, jp, js, lda, ijp;
10522 bool normaltransr, lower, nisodd;
10523
10524
10525 /* -- LAPACK routine (version 3.2) -- */
10526
10527 /* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
10528 /* -- November 2008 -- */
10529
10530 /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
10531 /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
10532
10533 /* .. */
10534 /* .. Scalar Arguments .. */
10535 /* .. */
10536 /* .. Array Arguments .. */
10537
10538 /* Purpose */
10539 /* ======= */
10540
10541 /* DTPTTF copies a triangular matrix A from standard packed format (TP) */
10542 /* to rectangular full packed format (TF). */
10543
10544 /* Arguments */
10545 /* ========= */
10546
10547 /* TRANSR (input) CHARACTER */
10548 /* = 'N': ARF in Normal format is wanted; */
10549 /* = 'T': ARF in Conjugate-transpose format is wanted. */
10550
10551 /* UPLO (input) CHARACTER */
10552 /* = 'U': A is upper triangular; */
10553 /* = 'L': A is lower triangular. */
10554
10555 /* N (input) INTEGER */
10556 /* The order of the matrix A. N >= 0. */
10557
10558 /* AP (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), */
10559 /* On entry, the upper or lower triangular matrix A, packed */
10560 /* columnwise in a linear array. The j-th column of A is stored */
10561 /* in the array AP as follows: */
10562 /* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
10563 /* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
10564
10565 /* ARF (output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), */
10566 /* On exit, the upper or lower triangular matrix A stored in */
10567 /* RFP format. For a further discussion see Notes below. */
10568
10569 /* INFO (output) INTEGER */
10570 /* = 0: successful exit */
10571 /* < 0: if INFO = -i, the i-th argument had an illegal value */
10572
10573 /* Notes */
10574 /* ===== */
10575
10576 /* We first consider Rectangular Full Packed (RFP) Format when N is */
10577 /* even. We give an example where N = 6. */
10578
10579 /* AP is Upper AP is Lower */
10580
10581 /* 00 01 02 03 04 05 00 */
10582 /* 11 12 13 14 15 10 11 */
10583 /* 22 23 24 25 20 21 22 */
10584 /* 33 34 35 30 31 32 33 */
10585 /* 44 45 40 41 42 43 44 */
10586 /* 55 50 51 52 53 54 55 */
10587
10588
10589 /* Let TRANSR = 'N'. RFP holds AP as follows: */
10590 /* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
10591 /* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
10592 /* the transpose of the first three columns of AP upper. */
10593 /* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
10594 /* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
10595 /* the transpose of the last three columns of AP lower. */
10596 /* This covers the case N even and TRANSR = 'N'. */
10597
10598 /* RFP A RFP A */
10599
10600 /* 03 04 05 33 43 53 */
10601 /* 13 14 15 00 44 54 */
10602 /* 23 24 25 10 11 55 */
10603 /* 33 34 35 20 21 22 */
10604 /* 00 44 45 30 31 32 */
10605 /* 01 11 55 40 41 42 */
10606 /* 02 12 22 50 51 52 */
10607
10608 /* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
10609 /* transpose of RFP A above. One therefore gets: */
10610
10611
10612 /* RFP A RFP A */
10613
10614 /* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
10615 /* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
10616 /* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
10617
10618
10619 /* We first consider Rectangular Full Packed (RFP) Format when N is */
10620 /* odd. We give an example where N = 5. */
10621
10622 /* AP is Upper AP is Lower */
10623
10624 /* 00 01 02 03 04 00 */
10625 /* 11 12 13 14 10 11 */
10626 /* 22 23 24 20 21 22 */
10627 /* 33 34 30 31 32 33 */
10628 /* 44 40 41 42 43 44 */
10629
10630
10631 /* Let TRANSR = 'N'. RFP holds AP as follows: */
10632 /* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
10633 /* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
10634 /* the transpose of the first two columns of AP upper. */
10635 /* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
10636 /* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
10637 /* the transpose of the last two columns of AP lower. */
10638 /* This covers the case N odd and TRANSR = 'N'. */
10639
10640 /* RFP A RFP A */
10641
10642 /* 02 03 04 00 33 43 */
10643 /* 12 13 14 10 11 44 */
10644 /* 22 23 24 20 21 22 */
10645 /* 00 33 34 30 31 32 */
10646 /* 01 11 44 40 41 42 */
10647
10648 /* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
10649 /* transpose of RFP A above. One therefore gets: */
10650
10651 /* RFP A RFP A */
10652
10653 /* 02 12 22 00 01 00 10 20 30 40 50 */
10654 /* 03 13 23 33 11 33 11 21 31 41 51 */
10655 /* 04 14 24 34 44 43 44 22 32 42 52 */
10656
10657 /* ===================================================================== */
10658
10659 /* .. Parameters .. */
10660 /* .. */
10661 /* .. Local Scalars .. */
10662 /* .. */
10663 /* .. External Functions .. */
10664 /* .. */
10665 /* .. External Subroutines .. */
10666 /* .. */
10667 /* .. Intrinsic Functions .. */
10668 /* .. */
10669 /* .. Executable Statements .. */
10670
10671 /* Test the input parameters. */
10672
10673 *info = 0;
10674 normaltransr = lsame_(transr, "N");
10675 lower = lsame_(uplo, "L");
10676 if (! normaltransr && ! lsame_(transr, "T")) {
10677 *info = -1;
10678 } else if (! lower && ! lsame_(uplo, "U")) {
10679 *info = -2;
10680 } else if (*n < 0) {
10681 *info = -3;
10682 }
10683 if (*info != 0) {
10684 i__1 = -(*info);
10685 xerbla_("DTPTTF", &i__1);
10686 return 0;
10687 }
10688
10689 /* Quick return if possible */
10690
10691 if (*n == 0) {
10692 return 0;
10693 }
10694
10695 if (*n == 1) {
10696 if (normaltransr) {
10697 arf[0] = ap[0];
10698 } else {
10699 arf[0] = ap[0];
10700 }
10701 return 0;
10702 }
10703
10704 /* Size of array ARF(0:NT-1) */
10705
10706 // nt = *n * (*n + 1) / 2;
10707
10708 /* Set N1 and N2 depending on LOWER */
10709
10710 if (lower) {
10711 n2 = *n / 2;
10712 n1 = *n - n2;
10713 } else {
10714 n1 = *n / 2;
10715 n2 = *n - n1;
10716 }
10717
10718 /* If N is odd, set NISODD = .TRUE. */
10719 /* If N is even, set K = N/2 and NISODD = .FALSE. */
10720
10721 /* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) */
10722 /* where noe = 0 if n is even, noe = 1 if n is odd */
10723
10724 if (*n % 2 == 0) {
10725 k = *n / 2;
10726 nisodd = false;
10727 lda = *n + 1;
10728 } else {
10729 nisodd = true;
10730 lda = *n;
10731 }
10732
10733 /* ARF^C has lda rows and n+1-noe cols */
10734
10735 if (! normaltransr) {
10736 lda = (*n + 1) / 2;
10737 }
10738
10739 /* start execution: there are eight cases */
10740
10741 if (nisodd) {
10742
10743 /* N is odd */
10744
10745 if (normaltransr) {
10746
10747 /* N is odd and TRANSR = 'N' */
10748
10749 if (lower) {
10750
10751 /* N is odd, TRANSR = 'N', and UPLO = 'L' */
10752
10753 ijp = 0;
10754 jp = 0;
10755 i__1 = n2;
10756 for (j = 0; j <= i__1; ++j) {
10757 i__2 = *n - 1;
10758 for (i__ = j; i__ <= i__2; ++i__) {
10759 ij = i__ + jp;
10760 arf[ij] = ap[ijp];
10761 ++ijp;
10762 }
10763 jp += lda;
10764 }
10765 i__1 = n2 - 1;
10766 for (i__ = 0; i__ <= i__1; ++i__) {
10767 i__2 = n2;
10768 for (j = i__ + 1; j <= i__2; ++j) {
10769 ij = i__ + j * lda;
10770 arf[ij] = ap[ijp];
10771 ++ijp;
10772 }
10773 }
10774
10775 } else {
10776
10777 /* N is odd, TRANSR = 'N', and UPLO = 'U' */
10778
10779 ijp = 0;
10780 i__1 = n1 - 1;
10781 for (j = 0; j <= i__1; ++j) {
10782 ij = n2 + j;
10783 i__2 = j;
10784 for (i__ = 0; i__ <= i__2; ++i__) {
10785 arf[ij] = ap[ijp];
10786 ++ijp;
10787 ij += lda;
10788 }
10789 }
10790 js = 0;
10791 i__1 = *n - 1;
10792 for (j = n1; j <= i__1; ++j) {
10793 ij = js;
10794 i__2 = js + j;
10795 for (ij = js; ij <= i__2; ++ij) {
10796 arf[ij] = ap[ijp];
10797 ++ijp;
10798 }
10799 js += lda;
10800 }
10801
10802 }
10803
10804 } else {
10805
10806 /* N is odd and TRANSR = 'T' */
10807
10808 if (lower) {
10809
10810 /* N is odd, TRANSR = 'T', and UPLO = 'L' */
10811
10812 ijp = 0;
10813 i__1 = n2;
10814 for (i__ = 0; i__ <= i__1; ++i__) {
10815 i__2 = *n * lda - 1;
10816 i__3 = lda;
10817 for (ij = i__ * (lda + 1); i__3 < 0 ? ij >= i__2 : ij <=
10818 i__2; ij += i__3) {
10819 arf[ij] = ap[ijp];
10820 ++ijp;
10821 }
10822 }
10823 js = 1;
10824 i__1 = n2 - 1;
10825 for (j = 0; j <= i__1; ++j) {
10826 i__3 = js + n2 - j - 1;
10827 for (ij = js; ij <= i__3; ++ij) {
10828 arf[ij] = ap[ijp];
10829 ++ijp;
10830 }
10831 js = js + lda + 1;
10832 }
10833
10834 } else {
10835
10836 /* N is odd, TRANSR = 'T', and UPLO = 'U' */
10837
10838 ijp = 0;
10839 js = n2 * lda;
10840 i__1 = n1 - 1;
10841 for (j = 0; j <= i__1; ++j) {
10842 i__3 = js + j;
10843 for (ij = js; ij <= i__3; ++ij) {
10844 arf[ij] = ap[ijp];
10845 ++ijp;
10846 }
10847 js += lda;
10848 }
10849 i__1 = n1;
10850 for (i__ = 0; i__ <= i__1; ++i__) {
10851 i__3 = i__ + (n1 + i__) * lda;
10852 i__2 = lda;
10853 for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij +=
10854 i__2) {
10855 arf[ij] = ap[ijp];
10856 ++ijp;
10857 }
10858 }
10859
10860 }
10861
10862 }
10863
10864 } else {
10865
10866 /* N is even */
10867
10868 if (normaltransr) {
10869
10870 /* N is even and TRANSR = 'N' */
10871
10872 if (lower) {
10873
10874 /* N is even, TRANSR = 'N', and UPLO = 'L' */
10875
10876 ijp = 0;
10877 jp = 0;
10878 i__1 = k - 1;
10879 for (j = 0; j <= i__1; ++j) {
10880 i__2 = *n - 1;
10881 for (i__ = j; i__ <= i__2; ++i__) {
10882 ij = i__ + 1 + jp;
10883 arf[ij] = ap[ijp];
10884 ++ijp;
10885 }
10886 jp += lda;
10887 }
10888 i__1 = k - 1;
10889 for (i__ = 0; i__ <= i__1; ++i__) {
10890 i__2 = k - 1;
10891 for (j = i__; j <= i__2; ++j) {
10892 ij = i__ + j * lda;
10893 arf[ij] = ap[ijp];
10894 ++ijp;
10895 }
10896 }
10897
10898 } else {
10899
10900 /* N is even, TRANSR = 'N', and UPLO = 'U' */
10901
10902 ijp = 0;
10903 i__1 = k - 1;
10904 for (j = 0; j <= i__1; ++j) {
10905 ij = k + 1 + j;
10906 i__2 = j;
10907 for (i__ = 0; i__ <= i__2; ++i__) {
10908 arf[ij] = ap[ijp];
10909 ++ijp;
10910 ij += lda;
10911 }
10912 }
10913 js = 0;
10914 i__1 = *n - 1;
10915 for (j = k; j <= i__1; ++j) {
10916 ij = js;
10917 i__2 = js + j;
10918 for (ij = js; ij <= i__2; ++ij) {
10919 arf[ij] = ap[ijp];
10920 ++ijp;
10921 }
10922 js += lda;
10923 }
10924
10925 }
10926
10927 } else {
10928
10929 /* N is even and TRANSR = 'T' */
10930
10931 if (lower) {
10932
10933 /* N is even, TRANSR = 'T', and UPLO = 'L' */
10934
10935 ijp = 0;
10936 i__1 = k - 1;
10937 for (i__ = 0; i__ <= i__1; ++i__) {
10938 i__2 = (*n + 1) * lda - 1;
10939 i__3 = lda;
10940 for (ij = i__ + (i__ + 1) * lda; i__3 < 0 ? ij >= i__2 :
10941 ij <= i__2; ij += i__3) {
10942 arf[ij] = ap[ijp];
10943 ++ijp;
10944 }
10945 }
10946 js = 0;
10947 i__1 = k - 1;
10948 for (j = 0; j <= i__1; ++j) {
10949 i__3 = js + k - j - 1;
10950 for (ij = js; ij <= i__3; ++ij) {
10951 arf[ij] = ap[ijp];
10952 ++ijp;
10953 }
10954 js = js + lda + 1;
10955 }
10956
10957 } else {
10958
10959 /* N is even, TRANSR = 'T', and UPLO = 'U' */
10960
10961 ijp = 0;
10962 js = (k + 1) * lda;
10963 i__1 = k - 1;
10964 for (j = 0; j <= i__1; ++j) {
10965 i__3 = js + j;
10966 for (ij = js; ij <= i__3; ++ij) {
10967 arf[ij] = ap[ijp];
10968 ++ijp;
10969 }
10970 js += lda;
10971 }
10972 i__1 = k - 1;
10973 for (i__ = 0; i__ <= i__1; ++i__) {
10974 i__3 = i__ + (k + i__) * lda;
10975 i__2 = lda;
10976 for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij +=
10977 i__2) {
10978 arf[ij] = ap[ijp];
10979 ++ijp;
10980 }
10981 }
10982
10983 }
10984
10985 }
10986
10987 }
10988
10989 return 0;
10990
10991 /* End of DTPTTF */
10992
10993 } /* dtpttf_ */
10994
dtpttr_(const char * uplo,integer * n,double * ap,double * a,integer * lda,integer * info)10995 int dtpttr_(const char *uplo, integer *n, double *ap, double *a, integer *lda, integer *info)
10996 {
10997 /* System generated locals */
10998 integer a_dim1, a_offset, i__1, i__2;
10999
11000 /* Local variables */
11001 integer i__, j, k;
11002 bool lower;
11003
11004 /* -- LAPACK routine (version 3.2) -- */
11005
11006 /* -- Contributed by Julien Langou of the Univ. of Colorado Denver -- */
11007 /* -- November 2008 -- */
11008
11009 /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
11010 /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
11011
11012 /* .. Scalar Arguments .. */
11013 /* .. */
11014 /* .. Array Arguments .. */
11015 /* .. */
11016
11017 /* Purpose */
11018 /* ======= */
11019
11020 /* DTPTTR copies a triangular matrix A from standard packed format (TP) */
11021 /* to standard full format (TR). */
11022
11023 /* Arguments */
11024 /* ========= */
11025
11026 /* UPLO (input) CHARACTER */
11027 /* = 'U': A is upper triangular. */
11028 /* = 'L': A is lower triangular. */
11029
11030 /* N (input) INTEGER */
11031 /* The order of the matrix A. N >= 0. */
11032
11033 /* AP (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), */
11034 /* On entry, the upper or lower triangular matrix A, packed */
11035 /* columnwise in a linear array. The j-th column of A is stored */
11036 /* in the array AP as follows: */
11037 /* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
11038 /* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
11039
11040 /* A (output) DOUBLE PRECISION array, dimension ( LDA, N ) */
11041 /* On exit, the triangular matrix A. If UPLO = 'U', the leading */
11042 /* N-by-N upper triangular part of A contains the upper */
11043 /* triangular part of the matrix A, and the strictly lower */
11044 /* triangular part of A is not referenced. If UPLO = 'L', the */
11045 /* leading N-by-N lower triangular part of A contains the lower */
11046 /* triangular part of the matrix A, and the strictly upper */
11047 /* triangular part of A is not referenced. */
11048
11049 /* LDA (input) INTEGER */
11050 /* The leading dimension of the array A. LDA >= max(1,N). */
11051
11052 /* INFO (output) INTEGER */
11053 /* = 0: successful exit */
11054 /* < 0: if INFO = -i, the i-th argument had an illegal value */
11055
11056 /* ===================================================================== */
11057
11058 /* .. Parameters .. */
11059 /* .. */
11060 /* .. Local Scalars .. */
11061 /* .. */
11062 /* .. External Functions .. */
11063 /* .. */
11064 /* .. External Subroutines .. */
11065 /* .. */
11066 /* .. Executable Statements .. */
11067
11068 /* Test the input parameters. */
11069
11070 /* Parameter adjustments */
11071 --ap;
11072 a_dim1 = *lda;
11073 a_offset = 1 + a_dim1;
11074 a -= a_offset;
11075
11076 /* Function Body */
11077 *info = 0;
11078 lower = lsame_(uplo, "L");
11079 if (! lower && ! lsame_(uplo, "U")) {
11080 *info = -1;
11081 } else if (*n < 0) {
11082 *info = -2;
11083 } else if (*lda < std::max(1_integer,*n)) {
11084 *info = -5;
11085 }
11086 if (*info != 0) {
11087 i__1 = -(*info);
11088 xerbla_("DTPTTR", &i__1);
11089 return 0;
11090 }
11091
11092 if (lower) {
11093 k = 0;
11094 i__1 = *n;
11095 for (j = 1; j <= i__1; ++j) {
11096 i__2 = *n;
11097 for (i__ = j; i__ <= i__2; ++i__) {
11098 ++k;
11099 a[i__ + j * a_dim1] = ap[k];
11100 }
11101 }
11102 } else {
11103 k = 0;
11104 i__1 = *n;
11105 for (j = 1; j <= i__1; ++j) {
11106 i__2 = j;
11107 for (i__ = 1; i__ <= i__2; ++i__) {
11108 ++k;
11109 a[i__ + j * a_dim1] = ap[k];
11110 }
11111 }
11112 }
11113
11114
11115 return 0;
11116
11117 /* End of DTPTTR */
11118
11119 } /* dtpttr_ */
11120
dtrcon_(const char * norm,const char * uplo,const char * diag,integer * n,double * a,integer * lda,double * rcond,double * work,integer * iwork,integer * info)11121 /* Subroutine */ int dtrcon_(const char *norm, const char *uplo, const char *diag, integer *n,
11122 double *a, integer *lda, double *rcond, double *work,
11123 integer *iwork, integer *info)
11124 {
11125 /* Table of constant values */
11126 static integer c__1 = 1;
11127
11128 /* System generated locals */
11129 integer a_dim1, a_offset, i__1;
11130 double d__1;
11131
11132 /* Local variables */
11133 integer ix, kase, kase1;
11134 double scale;
11135 integer isave[3];
11136 double anorm;
11137 bool upper;
11138 double xnorm;
11139 double ainvnm;
11140 bool onenrm;
11141 char normin[1];
11142 double smlnum;
11143 bool nounit;
11144
11145
11146 /* -- LAPACK routine (version 3.1) -- */
11147 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
11148 /* November 2006 */
11149
11150 /* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
11151
11152 /* .. Scalar Arguments .. */
11153 /* .. */
11154 /* .. Array Arguments .. */
11155 /* .. */
11156
11157 /* Purpose */
11158 /* ======= */
11159
11160 /* DTRCON estimates the reciprocal of the condition number of a */
11161 /* triangular matrix A, in either the 1-norm or the infinity-norm. */
11162
11163 /* The norm of A is computed and an estimate is obtained for */
11164 /* norm(inv(A)), then the reciprocal of the condition number is */
11165 /* computed as */
11166 /* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
11167
11168 /* Arguments */
11169 /* ========= */
11170
11171 /* NORM (input) CHARACTER*1 */
11172 /* Specifies whether the 1-norm condition number or the */
11173 /* infinity-norm condition number is required: */
11174 /* = '1' or 'O': 1-norm; */
11175 /* = 'I': Infinity-norm. */
11176
11177 /* UPLO (input) CHARACTER*1 */
11178 /* = 'U': A is upper triangular; */
11179 /* = 'L': A is lower triangular. */
11180
11181 /* DIAG (input) CHARACTER*1 */
11182 /* = 'N': A is non-unit triangular; */
11183 /* = 'U': A is unit triangular. */
11184
11185 /* N (input) INTEGER */
11186 /* The order of the matrix A. N >= 0. */
11187
11188 /* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
11189 /* The triangular matrix A. If UPLO = 'U', the leading N-by-N */
11190 /* upper triangular part of the array A contains the upper */
11191 /* triangular matrix, and the strictly lower triangular part of */
11192 /* A is not referenced. If UPLO = 'L', the leading N-by-N lower */
11193 /* triangular part of the array A contains the lower triangular */
11194 /* matrix, and the strictly upper triangular part of A is not */
11195 /* referenced. If DIAG = 'U', the diagonal elements of A are */
11196 /* also not referenced and are assumed to be 1. */
11197
11198 /* LDA (input) INTEGER */
11199 /* The leading dimension of the array A. LDA >= max(1,N). */
11200
11201 /* RCOND (output) DOUBLE PRECISION */
11202 /* The reciprocal of the condition number of the matrix A, */
11203 /* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
11204
11205 /* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
11206
11207 /* IWORK (workspace) INTEGER array, dimension (N) */
11208
11209 /* INFO (output) INTEGER */
11210 /* = 0: successful exit */
11211 /* < 0: if INFO = -i, the i-th argument had an illegal value */
11212
11213 /* ===================================================================== */
11214
11215 /* .. Parameters .. */
11216 /* .. */
11217 /* .. Local Scalars .. */
11218 /* .. */
11219 /* .. Local Arrays .. */
11220 /* .. */
11221 /* .. External Functions .. */
11222 /* .. */
11223 /* .. External Subroutines .. */
11224 /* .. */
11225 /* .. Intrinsic Functions .. */
11226 /* .. */
11227 /* .. Executable Statements .. */
11228
11229 /* Test the input parameters. */
11230
11231 /* Parameter adjustments */
11232 a_dim1 = *lda;
11233 a_offset = 1 + a_dim1;
11234 a -= a_offset;
11235 --work;
11236 --iwork;
11237
11238 /* Function Body */
11239 *info = 0;
11240 upper = lsame_(uplo, "U");
11241 onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
11242 nounit = lsame_(diag, "N");
11243
11244 if (! onenrm && ! lsame_(norm, "I")) {
11245 *info = -1;
11246 } else if (! upper && ! lsame_(uplo, "L")) {
11247 *info = -2;
11248 } else if (! nounit && ! lsame_(diag, "U")) {
11249 *info = -3;
11250 } else if (*n < 0) {
11251 *info = -4;
11252 } else if (*lda < std::max(1_integer,*n)) {
11253 *info = -6;
11254 }
11255 if (*info != 0) {
11256 i__1 = -(*info);
11257 xerbla_("DTRCON", &i__1);
11258 return 0;
11259 }
11260
11261 /* Quick return if possible */
11262
11263 if (*n == 0) {
11264 *rcond = 1.;
11265 return 0;
11266 }
11267
11268 *rcond = 0.;
11269 smlnum = dlamch_("Safe minimum") * (double) std::max(1_integer,*n);
11270
11271 /* Compute the norm of the triangular matrix A. */
11272
11273 anorm = dlantr_(norm, uplo, diag, n, n, &a[a_offset], lda, &work[1]);
11274
11275 /* Continue only if ANORM > 0. */
11276
11277 if (anorm > 0.) {
11278
11279 /* Estimate the norm of the inverse of A. */
11280
11281 ainvnm = 0.;
11282 *(unsigned char *)normin = 'N';
11283 if (onenrm) {
11284 kase1 = 1;
11285 } else {
11286 kase1 = 2;
11287 }
11288 kase = 0;
11289 L10:
11290 dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
11291 if (kase != 0) {
11292 if (kase == kase1) {
11293
11294 /* Multiply by inv(A). */
11295
11296 dlatrs_(uplo, "No transpose", diag, normin, n, &a[a_offset],
11297 lda, &work[1], &scale, &work[(*n << 1) + 1], info);
11298 } else {
11299
11300 /* Multiply by inv(A'). */
11301
11302 dlatrs_(uplo, "Transpose", diag, normin, n, &a[a_offset], lda,
11303 &work[1], &scale, &work[(*n << 1) + 1], info);
11304 }
11305 *(unsigned char *)normin = 'Y';
11306
11307 /* Multiply by 1/SCALE if doing so will not cause overflow. */
11308
11309 if (scale != 1.) {
11310 ix = idamax_(n, &work[1], &c__1);
11311 xnorm = (d__1 = work[ix], abs(d__1));
11312 if (scale < xnorm * smlnum || scale == 0.) {
11313 goto L20;
11314 }
11315 drscl_(n, &scale, &work[1], &c__1);
11316 }
11317 goto L10;
11318 }
11319
11320 /* Compute the estimate of the reciprocal condition number. */
11321
11322 if (ainvnm != 0.) {
11323 *rcond = 1. / anorm / ainvnm;
11324 }
11325 }
11326
11327 L20:
11328 return 0;
11329
11330 /* End of DTRCON */
11331
11332 } /* dtrcon_ */
11333
dtrevc_(const char * side,const char * howmny,bool * select,integer * n,double * t,integer * ldt,double * vl,integer * ldvl,double * vr,integer * ldvr,integer * mm,integer * m,double * work,integer * info)11334 /* Subroutine */ int dtrevc_(const char *side, const char *howmny, bool *select,
11335 integer *n, double *t, integer *ldt, double *vl, integer *
11336 ldvl, double *vr, integer *ldvr, integer *mm, integer *m,
11337 double *work, integer *info)
11338 {
11339 /* Table of constant values */
11340 static bool c_false = false;
11341 static integer c__1 = 1;
11342 static double c_b22 = 1.;
11343 static double c_b25 = 0.;
11344 static integer c__2 = 2;
11345 static bool c_true = true;
11346
11347 /* System generated locals */
11348 integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
11349 i__2, i__3;
11350 double d__1, d__2, d__3, d__4;
11351
11352 /* Local variables */
11353 integer i__, j, k;
11354 double x[4] /* was [2][2] */;
11355 integer j1, j2, n2, ii, ki, ip, is;
11356 double wi, wr, rec, ulp, beta, emax;
11357 bool pair;
11358 bool allv;
11359 integer ierr;
11360 double unfl, ovfl, smin;
11361 bool over;
11362 double vmax;
11363 integer jnxt;
11364 double scale;
11365 double remax;
11366 bool leftv, bothv;
11367 double vcrit;
11368 bool somev;
11369 double xnorm;
11370 double bignum;
11371 bool rightv;
11372 double smlnum;
11373
11374
11375 /* -- LAPACK routine (version 3.1) -- */
11376 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
11377 /* November 2006 */
11378
11379 /* .. Scalar Arguments .. */
11380 /* .. */
11381 /* .. Array Arguments .. */
11382 /* .. */
11383
11384 /* Purpose */
11385 /* ======= */
11386
11387 /* DTREVC computes some or all of the right and/or left eigenvectors of */
11388 /* a real upper quasi-triangular matrix T. */
11389 /* Matrices of this type are produced by the Schur factorization of */
11390 /* a real general matrix: A = Q*T*Q**T, as computed by DHSEQR. */
11391
11392 /* The right eigenvector x and the left eigenvector y of T corresponding */
11393 /* to an eigenvalue w are defined by: */
11394
11395 /* T*x = w*x, (y**H)*T = w*(y**H) */
11396
11397 /* where y**H denotes the conjugate transpose of y. */
11398 /* The eigenvalues are not input to this routine, but are read directly */
11399 /* from the diagonal blocks of T. */
11400
11401 /* This routine returns the matrices X and/or Y of right and left */
11402 /* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an */
11403 /* input matrix. If Q is the orthogonal factor that reduces a matrix */
11404 /* A to Schur form T, then Q*X and Q*Y are the matrices of right and */
11405 /* left eigenvectors of A. */
11406
11407 /* Arguments */
11408 /* ========= */
11409
11410 /* SIDE (input) CHARACTER*1 */
11411 /* = 'R': compute right eigenvectors only; */
11412 /* = 'L': compute left eigenvectors only; */
11413 /* = 'B': compute both right and left eigenvectors. */
11414
11415 /* HOWMNY (input) CHARACTER*1 */
11416 /* = 'A': compute all right and/or left eigenvectors; */
11417 /* = 'B': compute all right and/or left eigenvectors, */
11418 /* backtransformed by the matrices in VR and/or VL; */
11419 /* = 'S': compute selected right and/or left eigenvectors, */
11420 /* as indicated by the logical array SELECT. */
11421
11422 /* SELECT (input/output) LOGICAL array, dimension (N) */
11423 /* If HOWMNY = 'S', SELECT specifies the eigenvectors to be */
11424 /* computed. */
11425 /* If w(j) is a real eigenvalue, the corresponding real */
11426 /* eigenvector is computed if SELECT(j) is .TRUE.. */
11427 /* If w(j) and w(j+1) are the real and imaginary parts of a */
11428 /* complex eigenvalue, the corresponding complex eigenvector is */
11429 /* computed if either SELECT(j) or SELECT(j+1) is .TRUE., and */
11430 /* on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to */
11431 /* .FALSE.. */
11432 /* Not referenced if HOWMNY = 'A' or 'B'. */
11433
11434 /* N (input) INTEGER */
11435 /* The order of the matrix T. N >= 0. */
11436
11437 /* T (input) DOUBLE PRECISION array, dimension (LDT,N) */
11438 /* The upper quasi-triangular matrix T in Schur canonical form. */
11439
11440 /* LDT (input) INTEGER */
11441 /* The leading dimension of the array T. LDT >= max(1,N). */
11442
11443 /* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM) */
11444 /* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */
11445 /* contain an N-by-N matrix Q (usually the orthogonal matrix Q */
11446 /* of Schur vectors returned by DHSEQR). */
11447 /* On exit, if SIDE = 'L' or 'B', VL contains: */
11448 /* if HOWMNY = 'A', the matrix Y of left eigenvectors of T; */
11449 /* if HOWMNY = 'B', the matrix Q*Y; */
11450 /* if HOWMNY = 'S', the left eigenvectors of T specified by */
11451 /* SELECT, stored consecutively in the columns */
11452 /* of VL, in the same order as their */
11453 /* eigenvalues. */
11454 /* A complex eigenvector corresponding to a complex eigenvalue */
11455 /* is stored in two consecutive columns, the first holding the */
11456 /* real part, and the second the imaginary part. */
11457 /* Not referenced if SIDE = 'R'. */
11458
11459 /* LDVL (input) INTEGER */
11460 /* The leading dimension of the array VL. LDVL >= 1, and if */
11461 /* SIDE = 'L' or 'B', LDVL >= N. */
11462
11463 /* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM) */
11464 /* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */
11465 /* contain an N-by-N matrix Q (usually the orthogonal matrix Q */
11466 /* of Schur vectors returned by DHSEQR). */
11467 /* On exit, if SIDE = 'R' or 'B', VR contains: */
11468 /* if HOWMNY = 'A', the matrix X of right eigenvectors of T; */
11469 /* if HOWMNY = 'B', the matrix Q*X; */
11470 /* if HOWMNY = 'S', the right eigenvectors of T specified by */
11471 /* SELECT, stored consecutively in the columns */
11472 /* of VR, in the same order as their */
11473 /* eigenvalues. */
11474 /* A complex eigenvector corresponding to a complex eigenvalue */
11475 /* is stored in two consecutive columns, the first holding the */
11476 /* real part and the second the imaginary part. */
11477 /* Not referenced if SIDE = 'L'. */
11478
11479 /* LDVR (input) INTEGER */
11480 /* The leading dimension of the array VR. LDVR >= 1, and if */
11481 /* SIDE = 'R' or 'B', LDVR >= N. */
11482
11483 /* MM (input) INTEGER */
11484 /* The number of columns in the arrays VL and/or VR. MM >= M. */
11485
11486 /* M (output) INTEGER */
11487 /* The number of columns in the arrays VL and/or VR actually */
11488 /* used to store the eigenvectors. */
11489 /* If HOWMNY = 'A' or 'B', M is set to N. */
11490 /* Each selected real eigenvector occupies one column and each */
11491 /* selected complex eigenvector occupies two columns. */
11492
11493 /* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
11494
11495 /* INFO (output) INTEGER */
11496 /* = 0: successful exit */
11497 /* < 0: if INFO = -i, the i-th argument had an illegal value */
11498
11499 /* Further Details */
11500 /* =============== */
11501
11502 /* The algorithm used in this program is basically backward (forward) */
11503 /* substitution, with scaling to make the the code robust against */
11504 /* possible overflow. */
11505
11506 /* Each eigenvector is normalized so that the element of largest */
11507 /* magnitude has magnitude 1; here the magnitude of a complex number */
11508 /* (x,y) is taken to be |x| + |y|. */
11509
11510 /* ===================================================================== */
11511
11512 /* .. Parameters .. */
11513 /* .. */
11514 /* .. Local Scalars .. */
11515 /* .. */
11516 /* .. External Functions .. */
11517 /* .. */
11518 /* .. External Subroutines .. */
11519 /* .. */
11520 /* .. Intrinsic Functions .. */
11521 /* .. */
11522 /* .. Local Arrays .. */
11523 /* .. */
11524 /* .. Executable Statements .. */
11525
11526 /* Decode and test the input parameters */
11527
11528 /* Parameter adjustments */
11529 --select;
11530 t_dim1 = *ldt;
11531 t_offset = 1 + t_dim1;
11532 t -= t_offset;
11533 vl_dim1 = *ldvl;
11534 vl_offset = 1 + vl_dim1;
11535 vl -= vl_offset;
11536 vr_dim1 = *ldvr;
11537 vr_offset = 1 + vr_dim1;
11538 vr -= vr_offset;
11539 --work;
11540
11541 /* Function Body */
11542 bothv = lsame_(side, "B");
11543 rightv = lsame_(side, "R") || bothv;
11544 leftv = lsame_(side, "L") || bothv;
11545
11546 allv = lsame_(howmny, "A");
11547 over = lsame_(howmny, "B");
11548 somev = lsame_(howmny, "S");
11549
11550 *info = 0;
11551 if (! rightv && ! leftv) {
11552 *info = -1;
11553 } else if (! allv && ! over && ! somev) {
11554 *info = -2;
11555 } else if (*n < 0) {
11556 *info = -4;
11557 } else if (*ldt < std::max(1_integer,*n)) {
11558 *info = -6;
11559 } else if (*ldvl < 1 || leftv && *ldvl < *n) {
11560 *info = -8;
11561 } else if (*ldvr < 1 || rightv && *ldvr < *n) {
11562 *info = -10;
11563 } else {
11564
11565 /* Set M to the number of columns required to store the selected */
11566 /* eigenvectors, standardize the array SELECT if necessary, and */
11567 /* test MM. */
11568
11569 if (somev) {
11570 *m = 0;
11571 pair = false;
11572 i__1 = *n;
11573 for (j = 1; j <= i__1; ++j) {
11574 if (pair) {
11575 pair = false;
11576 select[j] = false;
11577 } else {
11578 if (j < *n) {
11579 if (t[j + 1 + j * t_dim1] == 0.) {
11580 if (select[j]) {
11581 ++(*m);
11582 }
11583 } else {
11584 pair = true;
11585 if (select[j] || select[j + 1]) {
11586 select[j] = true;
11587 *m += 2;
11588 }
11589 }
11590 } else {
11591 if (select[*n]) {
11592 ++(*m);
11593 }
11594 }
11595 }
11596 /* L10: */
11597 }
11598 } else {
11599 *m = *n;
11600 }
11601
11602 if (*mm < *m) {
11603 *info = -11;
11604 }
11605 }
11606 if (*info != 0) {
11607 i__1 = -(*info);
11608 xerbla_("DTREVC", &i__1);
11609 return 0;
11610 }
11611
11612 /* Quick return if possible. */
11613
11614 if (*n == 0) {
11615 return 0;
11616 }
11617
11618 /* Set the constants to control overflow. */
11619
11620 unfl = dlamch_("Safe minimum");
11621 ovfl = 1. / unfl;
11622 dlabad_(&unfl, &ovfl);
11623 ulp = dlamch_("Precision");
11624 smlnum = unfl * (*n / ulp);
11625 bignum = (1. - ulp) / smlnum;
11626
11627 /* Compute 1-norm of each column of strictly upper triangular */
11628 /* part of T to control overflow in triangular solver. */
11629
11630 work[1] = 0.;
11631 i__1 = *n;
11632 for (j = 2; j <= i__1; ++j) {
11633 work[j] = 0.;
11634 i__2 = j - 1;
11635 for (i__ = 1; i__ <= i__2; ++i__) {
11636 work[j] += (d__1 = t[i__ + j * t_dim1], abs(d__1));
11637 /* L20: */
11638 }
11639 /* L30: */
11640 }
11641
11642 /* Index IP is used to specify the real or complex eigenvalue: */
11643 /* IP = 0, real eigenvalue, */
11644 /* 1, first of conjugate complex pair: (wr,wi) */
11645 /* -1, second of conjugate complex pair: (wr,wi) */
11646
11647 n2 = *n << 1;
11648
11649 if (rightv) {
11650
11651 /* Compute right eigenvectors. */
11652
11653 ip = 0;
11654 is = *m;
11655 for (ki = *n; ki >= 1; --ki) {
11656
11657 if (ip == 1) {
11658 goto L130;
11659 }
11660 if (ki == 1) {
11661 goto L40;
11662 }
11663 if (t[ki + (ki - 1) * t_dim1] == 0.) {
11664 goto L40;
11665 }
11666 ip = -1;
11667
11668 L40:
11669 if (somev) {
11670 if (ip == 0) {
11671 if (! select[ki]) {
11672 goto L130;
11673 }
11674 } else {
11675 if (! select[ki - 1]) {
11676 goto L130;
11677 }
11678 }
11679 }
11680
11681 /* Compute the KI-th eigenvalue (WR,WI). */
11682
11683 wr = t[ki + ki * t_dim1];
11684 wi = 0.;
11685 if (ip != 0) {
11686 wi = sqrt((d__1 = t[ki + (ki - 1) * t_dim1], abs(d__1))) *
11687 sqrt((d__2 = t[ki - 1 + ki * t_dim1], abs(d__2)));
11688 }
11689 /* Computing MAX */
11690 d__1 = ulp * (abs(wr) + abs(wi));
11691 smin = std::max(d__1,smlnum);
11692
11693 if (ip == 0) {
11694
11695 /* Real right eigenvector */
11696
11697 work[ki + *n] = 1.;
11698
11699 /* Form right-hand side */
11700
11701 i__1 = ki - 1;
11702 for (k = 1; k <= i__1; ++k) {
11703 work[k + *n] = -t[k + ki * t_dim1];
11704 /* L50: */
11705 }
11706
11707 /* Solve the upper quasi-triangular system: */
11708 /* (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK. */
11709
11710 jnxt = ki - 1;
11711 for (j = ki - 1; j >= 1; --j) {
11712 if (j > jnxt) {
11713 goto L60;
11714 }
11715 j1 = j;
11716 j2 = j;
11717 jnxt = j - 1;
11718 if (j > 1) {
11719 if (t[j + (j - 1) * t_dim1] != 0.) {
11720 j1 = j - 1;
11721 jnxt = j - 2;
11722 }
11723 }
11724
11725 if (j1 == j2) {
11726
11727 /* 1-by-1 diagonal block */
11728
11729 dlaln2_(&c_false, &c__1, &c__1, &smin, &c_b22, &t[j +
11730 j * t_dim1], ldt, &c_b22, &c_b22, &work[j + *
11731 n], n, &wr, &c_b25, x, &c__2, &scale, &xnorm,
11732 &ierr);
11733
11734 /* Scale X(1,1) to avoid overflow when updating */
11735 /* the right-hand side. */
11736
11737 if (xnorm > 1.) {
11738 if (work[j] > bignum / xnorm) {
11739 x[0] /= xnorm;
11740 scale /= xnorm;
11741 }
11742 }
11743
11744 /* Scale if necessary */
11745
11746 if (scale != 1.) {
11747 dscal_(&ki, &scale, &work[*n + 1], &c__1);
11748 }
11749 work[j + *n] = x[0];
11750
11751 /* Update right-hand side */
11752
11753 i__1 = j - 1;
11754 d__1 = -x[0];
11755 daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[
11756 *n + 1], &c__1);
11757
11758 } else {
11759
11760 /* 2-by-2 diagonal block */
11761
11762 dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b22, &t[j -
11763 1 + (j - 1) * t_dim1], ldt, &c_b22, &c_b22, &
11764 work[j - 1 + *n], n, &wr, &c_b25, x, &c__2, &
11765 scale, &xnorm, &ierr);
11766
11767 /* Scale X(1,1) and X(2,1) to avoid overflow when */
11768 /* updating the right-hand side. */
11769
11770 if (xnorm > 1.) {
11771 /* Computing MAX */
11772 d__1 = work[j - 1], d__2 = work[j];
11773 beta = std::max(d__1,d__2);
11774 if (beta > bignum / xnorm) {
11775 x[0] /= xnorm;
11776 x[1] /= xnorm;
11777 scale /= xnorm;
11778 }
11779 }
11780
11781 /* Scale if necessary */
11782
11783 if (scale != 1.) {
11784 dscal_(&ki, &scale, &work[*n + 1], &c__1);
11785 }
11786 work[j - 1 + *n] = x[0];
11787 work[j + *n] = x[1];
11788
11789 /* Update right-hand side */
11790
11791 i__1 = j - 2;
11792 d__1 = -x[0];
11793 daxpy_(&i__1, &d__1, &t[(j - 1) * t_dim1 + 1], &c__1,
11794 &work[*n + 1], &c__1);
11795 i__1 = j - 2;
11796 d__1 = -x[1];
11797 daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[
11798 *n + 1], &c__1);
11799 }
11800 L60:
11801 ;
11802 }
11803
11804 /* Copy the vector x or Q*x to VR and normalize. */
11805
11806 if (! over) {
11807 dcopy_(&ki, &work[*n + 1], &c__1, &vr[is * vr_dim1 + 1], &
11808 c__1);
11809
11810 ii = idamax_(&ki, &vr[is * vr_dim1 + 1], &c__1);
11811 remax = 1. / (d__1 = vr[ii + is * vr_dim1], abs(d__1));
11812 dscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1);
11813
11814 i__1 = *n;
11815 for (k = ki + 1; k <= i__1; ++k) {
11816 vr[k + is * vr_dim1] = 0.;
11817 /* L70: */
11818 }
11819 } else {
11820 if (ki > 1) {
11821 i__1 = ki - 1;
11822 dgemv_("N", n, &i__1, &c_b22, &vr[vr_offset], ldvr, &
11823 work[*n + 1], &c__1, &work[ki + *n], &vr[ki *
11824 vr_dim1 + 1], &c__1);
11825 }
11826
11827 ii = idamax_(n, &vr[ki * vr_dim1 + 1], &c__1);
11828 remax = 1. / (d__1 = vr[ii + ki * vr_dim1], abs(d__1));
11829 dscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1);
11830 }
11831
11832 } else {
11833
11834 /* Complex right eigenvector. */
11835
11836 /* Initial solve */
11837 /* [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0. */
11838 /* [ (T(KI,KI-1) T(KI,KI) ) ] */
11839
11840 if ((d__1 = t[ki - 1 + ki * t_dim1], abs(d__1)) >= (d__2 = t[
11841 ki + (ki - 1) * t_dim1], abs(d__2))) {
11842 work[ki - 1 + *n] = 1.;
11843 work[ki + n2] = wi / t[ki - 1 + ki * t_dim1];
11844 } else {
11845 work[ki - 1 + *n] = -wi / t[ki + (ki - 1) * t_dim1];
11846 work[ki + n2] = 1.;
11847 }
11848 work[ki + *n] = 0.;
11849 work[ki - 1 + n2] = 0.;
11850
11851 /* Form right-hand side */
11852
11853 i__1 = ki - 2;
11854 for (k = 1; k <= i__1; ++k) {
11855 work[k + *n] = -work[ki - 1 + *n] * t[k + (ki - 1) *
11856 t_dim1];
11857 work[k + n2] = -work[ki + n2] * t[k + ki * t_dim1];
11858 /* L80: */
11859 }
11860
11861 /* Solve upper quasi-triangular system: */
11862 /* (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2) */
11863
11864 jnxt = ki - 2;
11865 for (j = ki - 2; j >= 1; --j) {
11866 if (j > jnxt) {
11867 goto L90;
11868 }
11869 j1 = j;
11870 j2 = j;
11871 jnxt = j - 1;
11872 if (j > 1) {
11873 if (t[j + (j - 1) * t_dim1] != 0.) {
11874 j1 = j - 1;
11875 jnxt = j - 2;
11876 }
11877 }
11878
11879 if (j1 == j2) {
11880
11881 /* 1-by-1 diagonal block */
11882
11883 dlaln2_(&c_false, &c__1, &c__2, &smin, &c_b22, &t[j +
11884 j * t_dim1], ldt, &c_b22, &c_b22, &work[j + *
11885 n], n, &wr, &wi, x, &c__2, &scale, &xnorm, &
11886 ierr);
11887
11888 /* Scale X(1,1) and X(1,2) to avoid overflow when */
11889 /* updating the right-hand side. */
11890
11891 if (xnorm > 1.) {
11892 if (work[j] > bignum / xnorm) {
11893 x[0] /= xnorm;
11894 x[2] /= xnorm;
11895 scale /= xnorm;
11896 }
11897 }
11898
11899 /* Scale if necessary */
11900
11901 if (scale != 1.) {
11902 dscal_(&ki, &scale, &work[*n + 1], &c__1);
11903 dscal_(&ki, &scale, &work[n2 + 1], &c__1);
11904 }
11905 work[j + *n] = x[0];
11906 work[j + n2] = x[2];
11907
11908 /* Update the right-hand side */
11909
11910 i__1 = j - 1;
11911 d__1 = -x[0];
11912 daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[
11913 *n + 1], &c__1);
11914 i__1 = j - 1;
11915 d__1 = -x[2];
11916 daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[
11917 n2 + 1], &c__1);
11918
11919 } else {
11920
11921 /* 2-by-2 diagonal block */
11922
11923 dlaln2_(&c_false, &c__2, &c__2, &smin, &c_b22, &t[j -
11924 1 + (j - 1) * t_dim1], ldt, &c_b22, &c_b22, &
11925 work[j - 1 + *n], n, &wr, &wi, x, &c__2, &
11926 scale, &xnorm, &ierr);
11927
11928 /* Scale X to avoid overflow when updating */
11929 /* the right-hand side. */
11930
11931 if (xnorm > 1.) {
11932 /* Computing MAX */
11933 d__1 = work[j - 1], d__2 = work[j];
11934 beta = std::max(d__1,d__2);
11935 if (beta > bignum / xnorm) {
11936 rec = 1. / xnorm;
11937 x[0] *= rec;
11938 x[2] *= rec;
11939 x[1] *= rec;
11940 x[3] *= rec;
11941 scale *= rec;
11942 }
11943 }
11944
11945 /* Scale if necessary */
11946
11947 if (scale != 1.) {
11948 dscal_(&ki, &scale, &work[*n + 1], &c__1);
11949 dscal_(&ki, &scale, &work[n2 + 1], &c__1);
11950 }
11951 work[j - 1 + *n] = x[0];
11952 work[j + *n] = x[1];
11953 work[j - 1 + n2] = x[2];
11954 work[j + n2] = x[3];
11955
11956 /* Update the right-hand side */
11957
11958 i__1 = j - 2;
11959 d__1 = -x[0];
11960 daxpy_(&i__1, &d__1, &t[(j - 1) * t_dim1 + 1], &c__1,
11961 &work[*n + 1], &c__1);
11962 i__1 = j - 2;
11963 d__1 = -x[1];
11964 daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[
11965 *n + 1], &c__1);
11966 i__1 = j - 2;
11967 d__1 = -x[2];
11968 daxpy_(&i__1, &d__1, &t[(j - 1) * t_dim1 + 1], &c__1,
11969 &work[n2 + 1], &c__1);
11970 i__1 = j - 2;
11971 d__1 = -x[3];
11972 daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[
11973 n2 + 1], &c__1);
11974 }
11975 L90:
11976 ;
11977 }
11978
11979 /* Copy the vector x or Q*x to VR and normalize. */
11980
11981 if (! over) {
11982 dcopy_(&ki, &work[*n + 1], &c__1, &vr[(is - 1) * vr_dim1
11983 + 1], &c__1);
11984 dcopy_(&ki, &work[n2 + 1], &c__1, &vr[is * vr_dim1 + 1], &
11985 c__1);
11986
11987 emax = 0.;
11988 i__1 = ki;
11989 for (k = 1; k <= i__1; ++k) {
11990 /* Computing MAX */
11991 d__3 = emax, d__4 = (d__1 = vr[k + (is - 1) * vr_dim1]
11992 , abs(d__1)) + (d__2 = vr[k + is * vr_dim1],
11993 abs(d__2));
11994 emax = std::max(d__3,d__4);
11995 /* L100: */
11996 }
11997
11998 remax = 1. / emax;
11999 dscal_(&ki, &remax, &vr[(is - 1) * vr_dim1 + 1], &c__1);
12000 dscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1);
12001
12002 i__1 = *n;
12003 for (k = ki + 1; k <= i__1; ++k) {
12004 vr[k + (is - 1) * vr_dim1] = 0.;
12005 vr[k + is * vr_dim1] = 0.;
12006 /* L110: */
12007 }
12008
12009 } else {
12010
12011 if (ki > 2) {
12012 i__1 = ki - 2;
12013 dgemv_("N", n, &i__1, &c_b22, &vr[vr_offset], ldvr, &
12014 work[*n + 1], &c__1, &work[ki - 1 + *n], &vr[(
12015 ki - 1) * vr_dim1 + 1], &c__1);
12016 i__1 = ki - 2;
12017 dgemv_("N", n, &i__1, &c_b22, &vr[vr_offset], ldvr, &
12018 work[n2 + 1], &c__1, &work[ki + n2], &vr[ki *
12019 vr_dim1 + 1], &c__1);
12020 } else {
12021 dscal_(n, &work[ki - 1 + *n], &vr[(ki - 1) * vr_dim1
12022 + 1], &c__1);
12023 dscal_(n, &work[ki + n2], &vr[ki * vr_dim1 + 1], &
12024 c__1);
12025 }
12026
12027 emax = 0.;
12028 i__1 = *n;
12029 for (k = 1; k <= i__1; ++k) {
12030 /* Computing MAX */
12031 d__3 = emax, d__4 = (d__1 = vr[k + (ki - 1) * vr_dim1]
12032 , abs(d__1)) + (d__2 = vr[k + ki * vr_dim1],
12033 abs(d__2));
12034 emax = std::max(d__3,d__4);
12035 /* L120: */
12036 }
12037 remax = 1. / emax;
12038 dscal_(n, &remax, &vr[(ki - 1) * vr_dim1 + 1], &c__1);
12039 dscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1);
12040 }
12041 }
12042
12043 --is;
12044 if (ip != 0) {
12045 --is;
12046 }
12047 L130:
12048 if (ip == 1) {
12049 ip = 0;
12050 }
12051 if (ip == -1) {
12052 ip = 1;
12053 }
12054 /* L140: */
12055 }
12056 }
12057
12058 if (leftv) {
12059
12060 /* Compute left eigenvectors. */
12061
12062 ip = 0;
12063 is = 1;
12064 i__1 = *n;
12065 for (ki = 1; ki <= i__1; ++ki) {
12066
12067 if (ip == -1) {
12068 goto L250;
12069 }
12070 if (ki == *n) {
12071 goto L150;
12072 }
12073 if (t[ki + 1 + ki * t_dim1] == 0.) {
12074 goto L150;
12075 }
12076 ip = 1;
12077
12078 L150:
12079 if (somev) {
12080 if (! select[ki]) {
12081 goto L250;
12082 }
12083 }
12084
12085 /* Compute the KI-th eigenvalue (WR,WI). */
12086
12087 wr = t[ki + ki * t_dim1];
12088 wi = 0.;
12089 if (ip != 0) {
12090 wi = sqrt((d__1 = t[ki + (ki + 1) * t_dim1], abs(d__1))) *
12091 sqrt((d__2 = t[ki + 1 + ki * t_dim1], abs(d__2)));
12092 }
12093 /* Computing MAX */
12094 d__1 = ulp * (abs(wr) + abs(wi));
12095 smin = std::max(d__1,smlnum);
12096
12097 if (ip == 0) {
12098
12099 /* Real left eigenvector. */
12100
12101 work[ki + *n] = 1.;
12102
12103 /* Form right-hand side */
12104
12105 i__2 = *n;
12106 for (k = ki + 1; k <= i__2; ++k) {
12107 work[k + *n] = -t[ki + k * t_dim1];
12108 /* L160: */
12109 }
12110
12111 /* Solve the quasi-triangular system: */
12112 /* (T(KI+1:N,KI+1:N) - WR)'*X = SCALE*WORK */
12113
12114 vmax = 1.;
12115 vcrit = bignum;
12116
12117 jnxt = ki + 1;
12118 i__2 = *n;
12119 for (j = ki + 1; j <= i__2; ++j) {
12120 if (j < jnxt) {
12121 goto L170;
12122 }
12123 j1 = j;
12124 j2 = j;
12125 jnxt = j + 1;
12126 if (j < *n) {
12127 if (t[j + 1 + j * t_dim1] != 0.) {
12128 j2 = j + 1;
12129 jnxt = j + 2;
12130 }
12131 }
12132
12133 if (j1 == j2) {
12134
12135 /* 1-by-1 diagonal block */
12136
12137 /* Scale if necessary to avoid overflow when forming */
12138 /* the right-hand side. */
12139
12140 if (work[j] > vcrit) {
12141 rec = 1. / vmax;
12142 i__3 = *n - ki + 1;
12143 dscal_(&i__3, &rec, &work[ki + *n], &c__1);
12144 vmax = 1.;
12145 vcrit = bignum;
12146 }
12147
12148 i__3 = j - ki - 1;
12149 work[j + *n] -= ddot_(&i__3, &t[ki + 1 + j * t_dim1],
12150 &c__1, &work[ki + 1 + *n], &c__1);
12151
12152 /* Solve (T(J,J)-WR)'*X = WORK */
12153
12154 dlaln2_(&c_false, &c__1, &c__1, &smin, &c_b22, &t[j +
12155 j * t_dim1], ldt, &c_b22, &c_b22, &work[j + *
12156 n], n, &wr, &c_b25, x, &c__2, &scale, &xnorm,
12157 &ierr);
12158
12159 /* Scale if necessary */
12160
12161 if (scale != 1.) {
12162 i__3 = *n - ki + 1;
12163 dscal_(&i__3, &scale, &work[ki + *n], &c__1);
12164 }
12165 work[j + *n] = x[0];
12166 /* Computing MAX */
12167 d__2 = (d__1 = work[j + *n], abs(d__1));
12168 vmax = std::max(d__2,vmax);
12169 vcrit = bignum / vmax;
12170
12171 } else {
12172
12173 /* 2-by-2 diagonal block */
12174
12175 /* Scale if necessary to avoid overflow when forming */
12176 /* the right-hand side. */
12177
12178 /* Computing MAX */
12179 d__1 = work[j], d__2 = work[j + 1];
12180 beta = std::max(d__1,d__2);
12181 if (beta > vcrit) {
12182 rec = 1. / vmax;
12183 i__3 = *n - ki + 1;
12184 dscal_(&i__3, &rec, &work[ki + *n], &c__1);
12185 vmax = 1.;
12186 vcrit = bignum;
12187 }
12188
12189 i__3 = j - ki - 1;
12190 work[j + *n] -= ddot_(&i__3, &t[ki + 1 + j * t_dim1],
12191 &c__1, &work[ki + 1 + *n], &c__1);
12192
12193 i__3 = j - ki - 1;
12194 work[j + 1 + *n] -= ddot_(&i__3, &t[ki + 1 + (j + 1) *
12195 t_dim1], &c__1, &work[ki + 1 + *n], &c__1);
12196
12197 /* Solve */
12198 /* [T(J,J)-WR T(J,J+1) ]'* X = SCALE*( WORK1 ) */
12199 /* [T(J+1,J) T(J+1,J+1)-WR] ( WORK2 ) */
12200
12201 dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b22, &t[j +
12202 j * t_dim1], ldt, &c_b22, &c_b22, &work[j + *
12203 n], n, &wr, &c_b25, x, &c__2, &scale, &xnorm,
12204 &ierr);
12205
12206 /* Scale if necessary */
12207
12208 if (scale != 1.) {
12209 i__3 = *n - ki + 1;
12210 dscal_(&i__3, &scale, &work[ki + *n], &c__1);
12211 }
12212 work[j + *n] = x[0];
12213 work[j + 1 + *n] = x[1];
12214
12215 /* Computing MAX */
12216 d__3 = (d__1 = work[j + *n], abs(d__1)), d__4 = (d__2
12217 = work[j + 1 + *n], abs(d__2)), d__3 = std::max(
12218 d__3,d__4);
12219 vmax = std::max(d__3,vmax);
12220 vcrit = bignum / vmax;
12221
12222 }
12223 L170:
12224 ;
12225 }
12226
12227 /* Copy the vector x or Q*x to VL and normalize. */
12228
12229 if (! over) {
12230 i__2 = *n - ki + 1;
12231 dcopy_(&i__2, &work[ki + *n], &c__1, &vl[ki + is *
12232 vl_dim1], &c__1);
12233
12234 i__2 = *n - ki + 1;
12235 ii = idamax_(&i__2, &vl[ki + is * vl_dim1], &c__1) + ki -
12236 1;
12237 remax = 1. / (d__1 = vl[ii + is * vl_dim1], abs(d__1));
12238 i__2 = *n - ki + 1;
12239 dscal_(&i__2, &remax, &vl[ki + is * vl_dim1], &c__1);
12240
12241 i__2 = ki - 1;
12242 for (k = 1; k <= i__2; ++k) {
12243 vl[k + is * vl_dim1] = 0.;
12244 /* L180: */
12245 }
12246
12247 } else {
12248
12249 if (ki < *n) {
12250 i__2 = *n - ki;
12251 dgemv_("N", n, &i__2, &c_b22, &vl[(ki + 1) * vl_dim1
12252 + 1], ldvl, &work[ki + 1 + *n], &c__1, &work[
12253 ki + *n], &vl[ki * vl_dim1 + 1], &c__1);
12254 }
12255
12256 ii = idamax_(n, &vl[ki * vl_dim1 + 1], &c__1);
12257 remax = 1. / (d__1 = vl[ii + ki * vl_dim1], abs(d__1));
12258 dscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1);
12259
12260 }
12261
12262 } else {
12263
12264 /* Complex left eigenvector. */
12265
12266 /* Initial solve: */
12267 /* ((T(KI,KI) T(KI,KI+1) )' - (WR - I* WI))*X = 0. */
12268 /* ((T(KI+1,KI) T(KI+1,KI+1)) ) */
12269
12270 if ((d__1 = t[ki + (ki + 1) * t_dim1], abs(d__1)) >= (d__2 =
12271 t[ki + 1 + ki * t_dim1], abs(d__2))) {
12272 work[ki + *n] = wi / t[ki + (ki + 1) * t_dim1];
12273 work[ki + 1 + n2] = 1.;
12274 } else {
12275 work[ki + *n] = 1.;
12276 work[ki + 1 + n2] = -wi / t[ki + 1 + ki * t_dim1];
12277 }
12278 work[ki + 1 + *n] = 0.;
12279 work[ki + n2] = 0.;
12280
12281 /* Form right-hand side */
12282
12283 i__2 = *n;
12284 for (k = ki + 2; k <= i__2; ++k) {
12285 work[k + *n] = -work[ki + *n] * t[ki + k * t_dim1];
12286 work[k + n2] = -work[ki + 1 + n2] * t[ki + 1 + k * t_dim1]
12287 ;
12288 /* L190: */
12289 }
12290
12291 /* Solve complex quasi-triangular system: */
12292 /* ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2 */
12293
12294 vmax = 1.;
12295 vcrit = bignum;
12296
12297 jnxt = ki + 2;
12298 i__2 = *n;
12299 for (j = ki + 2; j <= i__2; ++j) {
12300 if (j < jnxt) {
12301 goto L200;
12302 }
12303 j1 = j;
12304 j2 = j;
12305 jnxt = j + 1;
12306 if (j < *n) {
12307 if (t[j + 1 + j * t_dim1] != 0.) {
12308 j2 = j + 1;
12309 jnxt = j + 2;
12310 }
12311 }
12312
12313 if (j1 == j2) {
12314
12315 /* 1-by-1 diagonal block */
12316
12317 /* Scale if necessary to avoid overflow when */
12318 /* forming the right-hand side elements. */
12319
12320 if (work[j] > vcrit) {
12321 rec = 1. / vmax;
12322 i__3 = *n - ki + 1;
12323 dscal_(&i__3, &rec, &work[ki + *n], &c__1);
12324 i__3 = *n - ki + 1;
12325 dscal_(&i__3, &rec, &work[ki + n2], &c__1);
12326 vmax = 1.;
12327 vcrit = bignum;
12328 }
12329
12330 i__3 = j - ki - 2;
12331 work[j + *n] -= ddot_(&i__3, &t[ki + 2 + j * t_dim1],
12332 &c__1, &work[ki + 2 + *n], &c__1);
12333 i__3 = j - ki - 2;
12334 work[j + n2] -= ddot_(&i__3, &t[ki + 2 + j * t_dim1],
12335 &c__1, &work[ki + 2 + n2], &c__1);
12336
12337 /* Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2 */
12338
12339 d__1 = -wi;
12340 dlaln2_(&c_false, &c__1, &c__2, &smin, &c_b22, &t[j +
12341 j * t_dim1], ldt, &c_b22, &c_b22, &work[j + *
12342 n], n, &wr, &d__1, x, &c__2, &scale, &xnorm, &
12343 ierr);
12344
12345 /* Scale if necessary */
12346
12347 if (scale != 1.) {
12348 i__3 = *n - ki + 1;
12349 dscal_(&i__3, &scale, &work[ki + *n], &c__1);
12350 i__3 = *n - ki + 1;
12351 dscal_(&i__3, &scale, &work[ki + n2], &c__1);
12352 }
12353 work[j + *n] = x[0];
12354 work[j + n2] = x[2];
12355 /* Computing MAX */
12356 d__3 = (d__1 = work[j + *n], abs(d__1)), d__4 = (d__2
12357 = work[j + n2], abs(d__2)), d__3 = std::max(d__3,
12358 d__4);
12359 vmax = std::max(d__3,vmax);
12360 vcrit = bignum / vmax;
12361
12362 } else {
12363
12364 /* 2-by-2 diagonal block */
12365
12366 /* Scale if necessary to avoid overflow when forming */
12367 /* the right-hand side elements. */
12368
12369 /* Computing MAX */
12370 d__1 = work[j], d__2 = work[j + 1];
12371 beta = std::max(d__1,d__2);
12372 if (beta > vcrit) {
12373 rec = 1. / vmax;
12374 i__3 = *n - ki + 1;
12375 dscal_(&i__3, &rec, &work[ki + *n], &c__1);
12376 i__3 = *n - ki + 1;
12377 dscal_(&i__3, &rec, &work[ki + n2], &c__1);
12378 vmax = 1.;
12379 vcrit = bignum;
12380 }
12381
12382 i__3 = j - ki - 2;
12383 work[j + *n] -= ddot_(&i__3, &t[ki + 2 + j * t_dim1],
12384 &c__1, &work[ki + 2 + *n], &c__1);
12385
12386 i__3 = j - ki - 2;
12387 work[j + n2] -= ddot_(&i__3, &t[ki + 2 + j * t_dim1],
12388 &c__1, &work[ki + 2 + n2], &c__1);
12389
12390 i__3 = j - ki - 2;
12391 work[j + 1 + *n] -= ddot_(&i__3, &t[ki + 2 + (j + 1) *
12392 t_dim1], &c__1, &work[ki + 2 + *n], &c__1);
12393
12394 i__3 = j - ki - 2;
12395 work[j + 1 + n2] -= ddot_(&i__3, &t[ki + 2 + (j + 1) *
12396 t_dim1], &c__1, &work[ki + 2 + n2], &c__1);
12397
12398 /* Solve 2-by-2 complex linear equation */
12399 /* ([T(j,j) T(j,j+1) ]'-(wr-i*wi)*I)*X = SCALE*B */
12400 /* ([T(j+1,j) T(j+1,j+1)] ) */
12401
12402 d__1 = -wi;
12403 dlaln2_(&c_true, &c__2, &c__2, &smin, &c_b22, &t[j +
12404 j * t_dim1], ldt, &c_b22, &c_b22, &work[j + *
12405 n], n, &wr, &d__1, x, &c__2, &scale, &xnorm, &
12406 ierr);
12407
12408 /* Scale if necessary */
12409
12410 if (scale != 1.) {
12411 i__3 = *n - ki + 1;
12412 dscal_(&i__3, &scale, &work[ki + *n], &c__1);
12413 i__3 = *n - ki + 1;
12414 dscal_(&i__3, &scale, &work[ki + n2], &c__1);
12415 }
12416 work[j + *n] = x[0];
12417 work[j + n2] = x[2];
12418 work[j + 1 + *n] = x[1];
12419 work[j + 1 + n2] = x[3];
12420 /* Computing MAX */
12421 d__1 = abs(x[0]), d__2 = abs(x[2]), d__1 = std::max(d__1,
12422 d__2), d__2 = abs(x[1]), d__1 = std::max(d__1,d__2)
12423 , d__2 = abs(x[3]), d__1 = std::max(d__1,d__2);
12424 vmax = std::max(d__1,vmax);
12425 vcrit = bignum / vmax;
12426
12427 }
12428 L200:
12429 ;
12430 }
12431
12432 /* Copy the vector x or Q*x to VL and normalize. */
12433
12434 if (! over) {
12435 i__2 = *n - ki + 1;
12436 dcopy_(&i__2, &work[ki + *n], &c__1, &vl[ki + is *
12437 vl_dim1], &c__1);
12438 i__2 = *n - ki + 1;
12439 dcopy_(&i__2, &work[ki + n2], &c__1, &vl[ki + (is + 1) *
12440 vl_dim1], &c__1);
12441
12442 emax = 0.;
12443 i__2 = *n;
12444 for (k = ki; k <= i__2; ++k) {
12445 /* Computing MAX */
12446 d__3 = emax, d__4 = (d__1 = vl[k + is * vl_dim1], abs(
12447 d__1)) + (d__2 = vl[k + (is + 1) * vl_dim1],
12448 abs(d__2));
12449 emax = std::max(d__3,d__4);
12450 /* L220: */
12451 }
12452 remax = 1. / emax;
12453 i__2 = *n - ki + 1;
12454 dscal_(&i__2, &remax, &vl[ki + is * vl_dim1], &c__1);
12455 i__2 = *n - ki + 1;
12456 dscal_(&i__2, &remax, &vl[ki + (is + 1) * vl_dim1], &c__1)
12457 ;
12458
12459 i__2 = ki - 1;
12460 for (k = 1; k <= i__2; ++k) {
12461 vl[k + is * vl_dim1] = 0.;
12462 vl[k + (is + 1) * vl_dim1] = 0.;
12463 /* L230: */
12464 }
12465 } else {
12466 if (ki < *n - 1) {
12467 i__2 = *n - ki - 1;
12468 dgemv_("N", n, &i__2, &c_b22, &vl[(ki + 2) * vl_dim1
12469 + 1], ldvl, &work[ki + 2 + *n], &c__1, &work[
12470 ki + *n], &vl[ki * vl_dim1 + 1], &c__1);
12471 i__2 = *n - ki - 1;
12472 dgemv_("N", n, &i__2, &c_b22, &vl[(ki + 2) * vl_dim1
12473 + 1], ldvl, &work[ki + 2 + n2], &c__1, &work[
12474 ki + 1 + n2], &vl[(ki + 1) * vl_dim1 + 1], &
12475 c__1);
12476 } else {
12477 dscal_(n, &work[ki + *n], &vl[ki * vl_dim1 + 1], &
12478 c__1);
12479 dscal_(n, &work[ki + 1 + n2], &vl[(ki + 1) * vl_dim1
12480 + 1], &c__1);
12481 }
12482
12483 emax = 0.;
12484 i__2 = *n;
12485 for (k = 1; k <= i__2; ++k) {
12486 /* Computing MAX */
12487 d__3 = emax, d__4 = (d__1 = vl[k + ki * vl_dim1], abs(
12488 d__1)) + (d__2 = vl[k + (ki + 1) * vl_dim1],
12489 abs(d__2));
12490 emax = std::max(d__3,d__4);
12491 /* L240: */
12492 }
12493 remax = 1. / emax;
12494 dscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1);
12495 dscal_(n, &remax, &vl[(ki + 1) * vl_dim1 + 1], &c__1);
12496
12497 }
12498
12499 }
12500
12501 ++is;
12502 if (ip != 0) {
12503 ++is;
12504 }
12505 L250:
12506 if (ip == -1) {
12507 ip = 0;
12508 }
12509 if (ip == 1) {
12510 ip = -1;
12511 }
12512
12513 /* L260: */
12514 }
12515
12516 }
12517
12518 return 0;
12519
12520 /* End of DTREVC */
12521
12522 } /* dtrevc_ */
12523
dtrexc_(const char * compq,integer * n,double * t,integer * ldt,double * q,integer * ldq,integer * ifst,integer * ilst,double * work,integer * info)12524 /* Subroutine */ int dtrexc_(const char *compq, integer *n, double *t, integer *
12525 ldt, double *q, integer *ldq, integer *ifst, integer *ilst,
12526 double *work, integer *info)
12527 {
12528 /* Table of constant values */
12529 static integer c__1 = 1;
12530 static integer c__2 = 2;
12531
12532 /* System generated locals */
12533 integer q_dim1, q_offset, t_dim1, t_offset, i__1;
12534
12535 /* Local variables */
12536 integer nbf, nbl, here;
12537 bool wantq;
12538 integer nbnext;
12539
12540
12541 /* -- LAPACK routine (version 3.1) -- */
12542 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
12543 /* November 2006 */
12544
12545 /* .. Scalar Arguments .. */
12546 /* .. */
12547 /* .. Array Arguments .. */
12548 /* .. */
12549
12550 /* Purpose */
12551 /* ======= */
12552
12553 /* DTREXC reorders the real Schur factorization of a real matrix */
12554 /* A = Q*T*Q**T, so that the diagonal block of T with row index IFST is */
12555 /* moved to row ILST. */
12556
12557 /* The real Schur form T is reordered by an orthogonal similarity */
12558 /* transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors */
12559 /* is updated by postmultiplying it with Z. */
12560
12561 /* T must be in Schur canonical form (as returned by DHSEQR), that is, */
12562 /* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each */
12563 /* 2-by-2 diagonal block has its diagonal elements equal and its */
12564 /* off-diagonal elements of opposite sign. */
12565
12566 /* Arguments */
12567 /* ========= */
12568
12569 /* COMPQ (input) CHARACTER*1 */
12570 /* = 'V': update the matrix Q of Schur vectors; */
12571 /* = 'N': do not update Q. */
12572
12573 /* N (input) INTEGER */
12574 /* The order of the matrix T. N >= 0. */
12575
12576 /* T (input/output) DOUBLE PRECISION array, dimension (LDT,N) */
12577 /* On entry, the upper quasi-triangular matrix T, in Schur */
12578 /* Schur canonical form. */
12579 /* On exit, the reordered upper quasi-triangular matrix, again */
12580 /* in Schur canonical form. */
12581
12582 /* LDT (input) INTEGER */
12583 /* The leading dimension of the array T. LDT >= max(1,N). */
12584
12585 /* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */
12586 /* On entry, if COMPQ = 'V', the matrix Q of Schur vectors. */
12587 /* On exit, if COMPQ = 'V', Q has been postmultiplied by the */
12588 /* orthogonal transformation matrix Z which reorders T. */
12589 /* If COMPQ = 'N', Q is not referenced. */
12590
12591 /* LDQ (input) INTEGER */
12592 /* The leading dimension of the array Q. LDQ >= max(1,N). */
12593
12594 /* IFST (input/output) INTEGER */
12595 /* ILST (input/output) INTEGER */
12596 /* Specify the reordering of the diagonal blocks of T. */
12597 /* The block with row index IFST is moved to row ILST, by a */
12598 /* sequence of transpositions between adjacent blocks. */
12599 /* On exit, if IFST pointed on entry to the second row of a */
12600 /* 2-by-2 block, it is changed to point to the first row; ILST */
12601 /* always points to the first row of the block in its final */
12602 /* position (which may differ from its input value by +1 or -1). */
12603 /* 1 <= IFST <= N; 1 <= ILST <= N. */
12604
12605 /* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
12606
12607 /* INFO (output) INTEGER */
12608 /* = 0: successful exit */
12609 /* < 0: if INFO = -i, the i-th argument had an illegal value */
12610 /* = 1: two adjacent blocks were too close to swap (the problem */
12611 /* is very ill-conditioned); T may have been partially */
12612 /* reordered, and ILST points to the first row of the */
12613 /* current position of the block being moved. */
12614
12615 /* ===================================================================== */
12616
12617 /* .. Parameters .. */
12618 /* .. */
12619 /* .. Local Scalars .. */
12620 /* .. */
12621 /* .. External Functions .. */
12622 /* .. */
12623 /* .. External Subroutines .. */
12624 /* .. */
12625 /* .. Intrinsic Functions .. */
12626 /* .. */
12627 /* .. Executable Statements .. */
12628
12629 /* Decode and test the input arguments. */
12630
12631 /* Parameter adjustments */
12632 t_dim1 = *ldt;
12633 t_offset = 1 + t_dim1;
12634 t -= t_offset;
12635 q_dim1 = *ldq;
12636 q_offset = 1 + q_dim1;
12637 q -= q_offset;
12638 --work;
12639
12640 /* Function Body */
12641 *info = 0;
12642 wantq = lsame_(compq, "V");
12643 if (! wantq && ! lsame_(compq, "N")) {
12644 *info = -1;
12645 } else if (*n < 0) {
12646 *info = -2;
12647 } else if (*ldt < std::max(1_integer,*n)) {
12648 *info = -4;
12649 } else if (*ldq < 1 || wantq && *ldq < std::max(1_integer,*n)) {
12650 *info = -6;
12651 } else if (*ifst < 1 || *ifst > *n) {
12652 *info = -7;
12653 } else if (*ilst < 1 || *ilst > *n) {
12654 *info = -8;
12655 }
12656 if (*info != 0) {
12657 i__1 = -(*info);
12658 xerbla_("DTREXC", &i__1);
12659 return 0;
12660 }
12661
12662 /* Quick return if possible */
12663
12664 if (*n <= 1) {
12665 return 0;
12666 }
12667
12668 /* Determine the first row of specified block */
12669 /* and find out it is 1 by 1 or 2 by 2. */
12670
12671 if (*ifst > 1) {
12672 if (t[*ifst + (*ifst - 1) * t_dim1] != 0.) {
12673 --(*ifst);
12674 }
12675 }
12676 nbf = 1;
12677 if (*ifst < *n) {
12678 if (t[*ifst + 1 + *ifst * t_dim1] != 0.) {
12679 nbf = 2;
12680 }
12681 }
12682
12683 /* Determine the first row of the final block */
12684 /* and find out it is 1 by 1 or 2 by 2. */
12685
12686 if (*ilst > 1) {
12687 if (t[*ilst + (*ilst - 1) * t_dim1] != 0.) {
12688 --(*ilst);
12689 }
12690 }
12691 nbl = 1;
12692 if (*ilst < *n) {
12693 if (t[*ilst + 1 + *ilst * t_dim1] != 0.) {
12694 nbl = 2;
12695 }
12696 }
12697
12698 if (*ifst == *ilst) {
12699 return 0;
12700 }
12701
12702 if (*ifst < *ilst) {
12703
12704 /* Update ILST */
12705
12706 if (nbf == 2 && nbl == 1) {
12707 --(*ilst);
12708 }
12709 if (nbf == 1 && nbl == 2) {
12710 ++(*ilst);
12711 }
12712
12713 here = *ifst;
12714
12715 L10:
12716
12717 /* Swap block with next one below */
12718
12719 if (nbf == 1 || nbf == 2) {
12720
12721 /* Current block either 1 by 1 or 2 by 2 */
12722
12723 nbnext = 1;
12724 if (here + nbf + 1 <= *n) {
12725 if (t[here + nbf + 1 + (here + nbf) * t_dim1] != 0.) {
12726 nbnext = 2;
12727 }
12728 }
12729 dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &here, &
12730 nbf, &nbnext, &work[1], info);
12731 if (*info != 0) {
12732 *ilst = here;
12733 return 0;
12734 }
12735 here += nbnext;
12736
12737 /* Test if 2 by 2 block breaks into two 1 by 1 blocks */
12738
12739 if (nbf == 2) {
12740 if (t[here + 1 + here * t_dim1] == 0.) {
12741 nbf = 3;
12742 }
12743 }
12744
12745 } else {
12746
12747 /* Current block consists of two 1 by 1 blocks each of which */
12748 /* must be swapped individually */
12749
12750 nbnext = 1;
12751 if (here + 3 <= *n) {
12752 if (t[here + 3 + (here + 2) * t_dim1] != 0.) {
12753 nbnext = 2;
12754 }
12755 }
12756 i__1 = here + 1;
12757 dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, &
12758 c__1, &nbnext, &work[1], info);
12759 if (*info != 0) {
12760 *ilst = here;
12761 return 0;
12762 }
12763 if (nbnext == 1) {
12764
12765 /* Swap two 1 by 1 blocks, no problems possible */
12766
12767 dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
12768 here, &c__1, &nbnext, &work[1], info);
12769 ++here;
12770 } else {
12771
12772 /* Recompute NBNEXT in case 2 by 2 split */
12773
12774 if (t[here + 2 + (here + 1) * t_dim1] == 0.) {
12775 nbnext = 1;
12776 }
12777 if (nbnext == 2) {
12778
12779 /* 2 by 2 Block did not split */
12780
12781 dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
12782 here, &c__1, &nbnext, &work[1], info);
12783 if (*info != 0) {
12784 *ilst = here;
12785 return 0;
12786 }
12787 here += 2;
12788 } else {
12789
12790 /* 2 by 2 Block did split */
12791
12792 dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
12793 here, &c__1, &c__1, &work[1], info);
12794 i__1 = here + 1;
12795 dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
12796 i__1, &c__1, &c__1, &work[1], info);
12797 here += 2;
12798 }
12799 }
12800 }
12801 if (here < *ilst) {
12802 goto L10;
12803 }
12804
12805 } else {
12806
12807 here = *ifst;
12808 L20:
12809
12810 /* Swap block with next one above */
12811
12812 if (nbf == 1 || nbf == 2) {
12813
12814 /* Current block either 1 by 1 or 2 by 2 */
12815
12816 nbnext = 1;
12817 if (here >= 3) {
12818 if (t[here - 1 + (here - 2) * t_dim1] != 0.) {
12819 nbnext = 2;
12820 }
12821 }
12822 i__1 = here - nbnext;
12823 dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, &
12824 nbnext, &nbf, &work[1], info);
12825 if (*info != 0) {
12826 *ilst = here;
12827 return 0;
12828 }
12829 here -= nbnext;
12830
12831 /* Test if 2 by 2 block breaks into two 1 by 1 blocks */
12832
12833 if (nbf == 2) {
12834 if (t[here + 1 + here * t_dim1] == 0.) {
12835 nbf = 3;
12836 }
12837 }
12838
12839 } else {
12840
12841 /* Current block consists of two 1 by 1 blocks each of which */
12842 /* must be swapped individually */
12843
12844 nbnext = 1;
12845 if (here >= 3) {
12846 if (t[here - 1 + (here - 2) * t_dim1] != 0.) {
12847 nbnext = 2;
12848 }
12849 }
12850 i__1 = here - nbnext;
12851 dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, &
12852 nbnext, &c__1, &work[1], info);
12853 if (*info != 0) {
12854 *ilst = here;
12855 return 0;
12856 }
12857 if (nbnext == 1) {
12858
12859 /* Swap two 1 by 1 blocks, no problems possible */
12860
12861 dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
12862 here, &nbnext, &c__1, &work[1], info);
12863 --here;
12864 } else {
12865
12866 /* Recompute NBNEXT in case 2 by 2 split */
12867
12868 if (t[here + (here - 1) * t_dim1] == 0.) {
12869 nbnext = 1;
12870 }
12871 if (nbnext == 2) {
12872
12873 /* 2 by 2 Block did not split */
12874
12875 i__1 = here - 1;
12876 dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
12877 i__1, &c__2, &c__1, &work[1], info);
12878 if (*info != 0) {
12879 *ilst = here;
12880 return 0;
12881 }
12882 here += -2;
12883 } else {
12884
12885 /* 2 by 2 Block did split */
12886
12887 dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
12888 here, &c__1, &c__1, &work[1], info);
12889 i__1 = here - 1;
12890 dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
12891 i__1, &c__1, &c__1, &work[1], info);
12892 here += -2;
12893 }
12894 }
12895 }
12896 if (here > *ilst) {
12897 goto L20;
12898 }
12899 }
12900 *ilst = here;
12901
12902 return 0;
12903
12904 /* End of DTREXC */
12905
12906 } /* dtrexc_ */
12907
dtrrfs_(const char * uplo,const char * trans,const char * diag,integer * n,integer * nrhs,double * a,integer * lda,double * b,integer * ldb,double * x,integer * ldx,double * ferr,double * berr,double * work,integer * iwork,integer * info)12908 /* Subroutine */ int dtrrfs_(const char *uplo, const char *trans, const char *diag, integer *n,
12909 integer *nrhs, double *a, integer *lda, double *b, integer *
12910 ldb, double *x, integer *ldx, double *ferr, double *berr,
12911 double *work, integer *iwork, integer *info)
12912 {
12913 /* Table of constant values */
12914 static integer c__1 = 1;
12915 static double c_b19 = -1.;
12916
12917 /* System generated locals */
12918 integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2,
12919 i__3;
12920 double d__1, d__2, d__3;
12921
12922 /* Local variables */
12923 integer i__, j, k;
12924 double s, xk;
12925 integer nz;
12926 double eps;
12927 integer kase;
12928 double safe1, safe2;
12929 integer isave[3];
12930 bool upper;
12931 double safmin;
12932 bool notran;
12933 char transt[1];
12934 bool nounit;
12935 double lstres;
12936
12937
12938 /* -- LAPACK routine (version 3.1) -- */
12939 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
12940 /* November 2006 */
12941
12942 /* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
12943
12944 /* .. Scalar Arguments .. */
12945 /* .. */
12946 /* .. Array Arguments .. */
12947 /* .. */
12948
12949 /* Purpose */
12950 /* ======= */
12951
12952 /* DTRRFS provides error bounds and backward error estimates for the */
12953 /* solution to a system of linear equations with a triangular */
12954 /* coefficient matrix. */
12955
12956 /* The solution matrix X must be computed by DTRTRS or some other */
12957 /* means before entering this routine. DTRRFS does not do iterative */
12958 /* refinement because doing so cannot improve the backward error. */
12959
12960 /* Arguments */
12961 /* ========= */
12962
12963 /* UPLO (input) CHARACTER*1 */
12964 /* = 'U': A is upper triangular; */
12965 /* = 'L': A is lower triangular. */
12966
12967 /* TRANS (input) CHARACTER*1 */
12968 /* Specifies the form of the system of equations: */
12969 /* = 'N': A * X = B (No transpose) */
12970 /* = 'T': A**T * X = B (Transpose) */
12971 /* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
12972
12973 /* DIAG (input) CHARACTER*1 */
12974 /* = 'N': A is non-unit triangular; */
12975 /* = 'U': A is unit triangular. */
12976
12977 /* N (input) INTEGER */
12978 /* The order of the matrix A. N >= 0. */
12979
12980 /* NRHS (input) INTEGER */
12981 /* The number of right hand sides, i.e., the number of columns */
12982 /* of the matrices B and X. NRHS >= 0. */
12983
12984 /* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
12985 /* The triangular matrix A. If UPLO = 'U', the leading N-by-N */
12986 /* upper triangular part of the array A contains the upper */
12987 /* triangular matrix, and the strictly lower triangular part of */
12988 /* A is not referenced. If UPLO = 'L', the leading N-by-N lower */
12989 /* triangular part of the array A contains the lower triangular */
12990 /* matrix, and the strictly upper triangular part of A is not */
12991 /* referenced. If DIAG = 'U', the diagonal elements of A are */
12992 /* also not referenced and are assumed to be 1. */
12993
12994 /* LDA (input) INTEGER */
12995 /* The leading dimension of the array A. LDA >= max(1,N). */
12996
12997 /* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
12998 /* The right hand side matrix B. */
12999
13000 /* LDB (input) INTEGER */
13001 /* The leading dimension of the array B. LDB >= max(1,N). */
13002
13003 /* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
13004 /* The solution matrix X. */
13005
13006 /* LDX (input) INTEGER */
13007 /* The leading dimension of the array X. LDX >= max(1,N). */
13008
13009 /* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
13010 /* The estimated forward error bound for each solution vector */
13011 /* X(j) (the j-th column of the solution matrix X). */
13012 /* If XTRUE is the true solution corresponding to X(j), FERR(j) */
13013 /* is an estimated upper bound for the magnitude of the largest */
13014 /* element in (X(j) - XTRUE) divided by the magnitude of the */
13015 /* largest element in X(j). The estimate is as reliable as */
13016 /* the estimate for RCOND, and is almost always a slight */
13017 /* overestimate of the true error. */
13018
13019 /* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
13020 /* The componentwise relative backward error of each solution */
13021 /* vector X(j) (i.e., the smallest relative change in */
13022 /* any element of A or B that makes X(j) an exact solution). */
13023
13024 /* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
13025
13026 /* IWORK (workspace) INTEGER array, dimension (N) */
13027
13028 /* INFO (output) INTEGER */
13029 /* = 0: successful exit */
13030 /* < 0: if INFO = -i, the i-th argument had an illegal value */
13031
13032 /* ===================================================================== */
13033
13034 /* .. Parameters .. */
13035 /* .. */
13036 /* .. Local Scalars .. */
13037 /* .. */
13038 /* .. Local Arrays .. */
13039 /* .. */
13040 /* .. External Subroutines .. */
13041 /* .. */
13042 /* .. Intrinsic Functions .. */
13043 /* .. */
13044 /* .. External Functions .. */
13045 /* .. */
13046 /* .. Executable Statements .. */
13047
13048 /* Test the input parameters. */
13049
13050 /* Parameter adjustments */
13051 a_dim1 = *lda;
13052 a_offset = 1 + a_dim1;
13053 a -= a_offset;
13054 b_dim1 = *ldb;
13055 b_offset = 1 + b_dim1;
13056 b -= b_offset;
13057 x_dim1 = *ldx;
13058 x_offset = 1 + x_dim1;
13059 x -= x_offset;
13060 --ferr;
13061 --berr;
13062 --work;
13063 --iwork;
13064
13065 /* Function Body */
13066 *info = 0;
13067 upper = lsame_(uplo, "U");
13068 notran = lsame_(trans, "N");
13069 nounit = lsame_(diag, "N");
13070
13071 if (! upper && ! lsame_(uplo, "L")) {
13072 *info = -1;
13073 } else if (! notran && ! lsame_(trans, "T") && !
13074 lsame_(trans, "C")) {
13075 *info = -2;
13076 } else if (! nounit && ! lsame_(diag, "U")) {
13077 *info = -3;
13078 } else if (*n < 0) {
13079 *info = -4;
13080 } else if (*nrhs < 0) {
13081 *info = -5;
13082 } else if (*lda < std::max(1_integer,*n)) {
13083 *info = -7;
13084 } else if (*ldb < std::max(1_integer,*n)) {
13085 *info = -9;
13086 } else if (*ldx < std::max(1_integer,*n)) {
13087 *info = -11;
13088 }
13089 if (*info != 0) {
13090 i__1 = -(*info);
13091 xerbla_("DTRRFS", &i__1);
13092 return 0;
13093 }
13094
13095 /* Quick return if possible */
13096
13097 if (*n == 0 || *nrhs == 0) {
13098 i__1 = *nrhs;
13099 for (j = 1; j <= i__1; ++j) {
13100 ferr[j] = 0.;
13101 berr[j] = 0.;
13102 /* L10: */
13103 }
13104 return 0;
13105 }
13106
13107 if (notran) {
13108 *(unsigned char *)transt = 'T';
13109 } else {
13110 *(unsigned char *)transt = 'N';
13111 }
13112
13113 /* NZ = maximum number of nonzero elements in each row of A, plus 1 */
13114
13115 nz = *n + 1;
13116 eps = dlamch_("Epsilon");
13117 safmin = dlamch_("Safe minimum");
13118 safe1 = nz * safmin;
13119 safe2 = safe1 / eps;
13120
13121 /* Do for each right hand side */
13122
13123 i__1 = *nrhs;
13124 for (j = 1; j <= i__1; ++j) {
13125
13126 /* Compute residual R = B - op(A) * X, */
13127 /* where op(A) = A or A', depending on TRANS. */
13128
13129 dcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[*n + 1], &c__1);
13130 dtrmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[*n + 1], &c__1);
13131 daxpy_(n, &c_b19, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
13132
13133 /* Compute componentwise relative backward error from formula */
13134
13135 /* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
13136
13137 /* where abs(Z) is the componentwise absolute value of the matrix */
13138 /* or vector Z. If the i-th component of the denominator is less */
13139 /* than SAFE2, then SAFE1 is added to the i-th components of the */
13140 /* numerator and denominator before dividing. */
13141
13142 i__2 = *n;
13143 for (i__ = 1; i__ <= i__2; ++i__) {
13144 work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1));
13145 /* L20: */
13146 }
13147
13148 if (notran) {
13149
13150 /* Compute abs(A)*abs(X) + abs(B). */
13151
13152 if (upper) {
13153 if (nounit) {
13154 i__2 = *n;
13155 for (k = 1; k <= i__2; ++k) {
13156 xk = (d__1 = x[k + j * x_dim1], abs(d__1));
13157 i__3 = k;
13158 for (i__ = 1; i__ <= i__3; ++i__) {
13159 work[i__] += (d__1 = a[i__ + k * a_dim1], abs(
13160 d__1)) * xk;
13161 /* L30: */
13162 }
13163 /* L40: */
13164 }
13165 } else {
13166 i__2 = *n;
13167 for (k = 1; k <= i__2; ++k) {
13168 xk = (d__1 = x[k + j * x_dim1], abs(d__1));
13169 i__3 = k - 1;
13170 for (i__ = 1; i__ <= i__3; ++i__) {
13171 work[i__] += (d__1 = a[i__ + k * a_dim1], abs(
13172 d__1)) * xk;
13173 /* L50: */
13174 }
13175 work[k] += xk;
13176 /* L60: */
13177 }
13178 }
13179 } else {
13180 if (nounit) {
13181 i__2 = *n;
13182 for (k = 1; k <= i__2; ++k) {
13183 xk = (d__1 = x[k + j * x_dim1], abs(d__1));
13184 i__3 = *n;
13185 for (i__ = k; i__ <= i__3; ++i__) {
13186 work[i__] += (d__1 = a[i__ + k * a_dim1], abs(
13187 d__1)) * xk;
13188 /* L70: */
13189 }
13190 /* L80: */
13191 }
13192 } else {
13193 i__2 = *n;
13194 for (k = 1; k <= i__2; ++k) {
13195 xk = (d__1 = x[k + j * x_dim1], abs(d__1));
13196 i__3 = *n;
13197 for (i__ = k + 1; i__ <= i__3; ++i__) {
13198 work[i__] += (d__1 = a[i__ + k * a_dim1], abs(
13199 d__1)) * xk;
13200 /* L90: */
13201 }
13202 work[k] += xk;
13203 /* L100: */
13204 }
13205 }
13206 }
13207 } else {
13208
13209 /* Compute abs(A')*abs(X) + abs(B). */
13210
13211 if (upper) {
13212 if (nounit) {
13213 i__2 = *n;
13214 for (k = 1; k <= i__2; ++k) {
13215 s = 0.;
13216 i__3 = k;
13217 for (i__ = 1; i__ <= i__3; ++i__) {
13218 s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (
13219 d__2 = x[i__ + j * x_dim1], abs(d__2));
13220 /* L110: */
13221 }
13222 work[k] += s;
13223 /* L120: */
13224 }
13225 } else {
13226 i__2 = *n;
13227 for (k = 1; k <= i__2; ++k) {
13228 s = (d__1 = x[k + j * x_dim1], abs(d__1));
13229 i__3 = k - 1;
13230 for (i__ = 1; i__ <= i__3; ++i__) {
13231 s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (
13232 d__2 = x[i__ + j * x_dim1], abs(d__2));
13233 /* L130: */
13234 }
13235 work[k] += s;
13236 /* L140: */
13237 }
13238 }
13239 } else {
13240 if (nounit) {
13241 i__2 = *n;
13242 for (k = 1; k <= i__2; ++k) {
13243 s = 0.;
13244 i__3 = *n;
13245 for (i__ = k; i__ <= i__3; ++i__) {
13246 s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (
13247 d__2 = x[i__ + j * x_dim1], abs(d__2));
13248 /* L150: */
13249 }
13250 work[k] += s;
13251 /* L160: */
13252 }
13253 } else {
13254 i__2 = *n;
13255 for (k = 1; k <= i__2; ++k) {
13256 s = (d__1 = x[k + j * x_dim1], abs(d__1));
13257 i__3 = *n;
13258 for (i__ = k + 1; i__ <= i__3; ++i__) {
13259 s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (
13260 d__2 = x[i__ + j * x_dim1], abs(d__2));
13261 /* L170: */
13262 }
13263 work[k] += s;
13264 /* L180: */
13265 }
13266 }
13267 }
13268 }
13269 s = 0.;
13270 i__2 = *n;
13271 for (i__ = 1; i__ <= i__2; ++i__) {
13272 if (work[i__] > safe2) {
13273 /* Computing MAX */
13274 d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[
13275 i__];
13276 s = std::max(d__2,d__3);
13277 } else {
13278 /* Computing MAX */
13279 d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1)
13280 / (work[i__] + safe1);
13281 s = std::max(d__2,d__3);
13282 }
13283 /* L190: */
13284 }
13285 berr[j] = s;
13286
13287 /* Bound error from formula */
13288
13289 /* norm(X - XTRUE) / norm(X) .le. FERR = */
13290 /* norm( abs(inv(op(A)))* */
13291 /* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
13292
13293 /* where */
13294 /* norm(Z) is the magnitude of the largest component of Z */
13295 /* inv(op(A)) is the inverse of op(A) */
13296 /* abs(Z) is the componentwise absolute value of the matrix or */
13297 /* vector Z */
13298 /* NZ is the maximum number of nonzeros in any row of A, plus 1 */
13299 /* EPS is machine epsilon */
13300
13301 /* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
13302 /* is incremented by SAFE1 if the i-th component of */
13303 /* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
13304
13305 /* Use DLACN2 to estimate the infinity-norm of the matrix */
13306 /* inv(op(A)) * diag(W), */
13307 /* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
13308
13309 i__2 = *n;
13310 for (i__ = 1; i__ <= i__2; ++i__) {
13311 if (work[i__] > safe2) {
13312 work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
13313 work[i__];
13314 } else {
13315 work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
13316 work[i__] + safe1;
13317 }
13318 /* L200: */
13319 }
13320
13321 kase = 0;
13322 L210:
13323 dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
13324 kase, isave);
13325 if (kase != 0) {
13326 if (kase == 1) {
13327
13328 /* Multiply by diag(W)*inv(op(A)'). */
13329
13330 dtrsv_(uplo, transt, diag, n, &a[a_offset], lda, &work[*n + 1]
13331 , &c__1);
13332 i__2 = *n;
13333 for (i__ = 1; i__ <= i__2; ++i__) {
13334 work[*n + i__] = work[i__] * work[*n + i__];
13335 /* L220: */
13336 }
13337 } else {
13338
13339 /* Multiply by inv(op(A))*diag(W). */
13340
13341 i__2 = *n;
13342 for (i__ = 1; i__ <= i__2; ++i__) {
13343 work[*n + i__] = work[i__] * work[*n + i__];
13344 /* L230: */
13345 }
13346 dtrsv_(uplo, trans, diag, n, &a[a_offset], lda, &work[*n + 1],
13347 &c__1);
13348 }
13349 goto L210;
13350 }
13351
13352 /* Normalize error. */
13353
13354 lstres = 0.;
13355 i__2 = *n;
13356 for (i__ = 1; i__ <= i__2; ++i__) {
13357 /* Computing MAX */
13358 d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1));
13359 lstres = std::max(d__2,d__3);
13360 /* L240: */
13361 }
13362 if (lstres != 0.) {
13363 ferr[j] /= lstres;
13364 }
13365
13366 /* L250: */
13367 }
13368
13369 return 0;
13370
13371 /* End of DTRRFS */
13372
13373 } /* dtrrfs_ */
13374
dtrsen_(const char * job,const char * compq,bool * select,integer * n,double * t,integer * ldt,double * q,integer * ldq,double * wr,double * wi,integer * m,double * s,double * sep,double * work,integer * lwork,integer * iwork,integer * liwork,integer * info)13375 /* Subroutine */ int dtrsen_(const char *job, const char *compq, bool *select, integer
13376 *n, double *t, integer *ldt, double *q, integer *ldq,
13377 double *wr, double *wi, integer *m, double *s, double
13378 *sep, double *work, integer *lwork, integer *iwork, integer *
13379 liwork, integer *info)
13380 {
13381 /* Table of constant values */
13382 static integer c_n1 = -1;
13383
13384 /* System generated locals */
13385 integer q_dim1, q_offset, t_dim1, t_offset, i__1, i__2;
13386 double d__1, d__2;
13387
13388 /* Local variables */
13389 integer k, n1, n2, kk, nn, ks;
13390 double est;
13391 integer kase;
13392 bool pair;
13393 integer ierr;
13394 bool swap;
13395 double scale;
13396 integer isave[3], lwmin;
13397 bool wantq, wants;
13398 double rnorm;
13399 bool wantbh;
13400 integer liwmin;
13401 bool wantsp, lquery;
13402
13403
13404 /* -- LAPACK routine (version 3.1) -- */
13405 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
13406 /* November 2006 */
13407
13408 /* .. Scalar Arguments .. */
13409 /* .. */
13410 /* .. Array Arguments .. */
13411 /* .. */
13412
13413 /* Purpose */
13414 /* ======= */
13415
13416 /* DTRSEN reorders the real Schur factorization of a real matrix */
13417 /* A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in */
13418 /* the leading diagonal blocks of the upper quasi-triangular matrix T, */
13419 /* and the leading columns of Q form an orthonormal basis of the */
13420 /* corresponding right invariant subspace. */
13421
13422 /* Optionally the routine computes the reciprocal condition numbers of */
13423 /* the cluster of eigenvalues and/or the invariant subspace. */
13424
13425 /* T must be in Schur canonical form (as returned by DHSEQR), that is, */
13426 /* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each */
13427 /* 2-by-2 diagonal block has its diagonal elemnts equal and its */
13428 /* off-diagonal elements of opposite sign. */
13429
13430 /* Arguments */
13431 /* ========= */
13432
13433 /* JOB (input) CHARACTER*1 */
13434 /* Specifies whether condition numbers are required for the */
13435 /* cluster of eigenvalues (S) or the invariant subspace (SEP): */
13436 /* = 'N': none; */
13437 /* = 'E': for eigenvalues only (S); */
13438 /* = 'V': for invariant subspace only (SEP); */
13439 /* = 'B': for both eigenvalues and invariant subspace (S and */
13440 /* SEP). */
13441
13442 /* COMPQ (input) CHARACTER*1 */
13443 /* = 'V': update the matrix Q of Schur vectors; */
13444 /* = 'N': do not update Q. */
13445
13446 /* SELECT (input) LOGICAL array, dimension (N) */
13447 /* SELECT specifies the eigenvalues in the selected cluster. To */
13448 /* select a real eigenvalue w(j), SELECT(j) must be set to */
13449 /* .TRUE.. To select a complex conjugate pair of eigenvalues */
13450 /* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, */
13451 /* either SELECT(j) or SELECT(j+1) or both must be set to */
13452 /* .TRUE.; a complex conjugate pair of eigenvalues must be */
13453 /* either both included in the cluster or both excluded. */
13454
13455 /* N (input) INTEGER */
13456 /* The order of the matrix T. N >= 0. */
13457
13458 /* T (input/output) DOUBLE PRECISION array, dimension (LDT,N) */
13459 /* On entry, the upper quasi-triangular matrix T, in Schur */
13460 /* canonical form. */
13461 /* On exit, T is overwritten by the reordered matrix T, again in */
13462 /* Schur canonical form, with the selected eigenvalues in the */
13463 /* leading diagonal blocks. */
13464
13465 /* LDT (input) INTEGER */
13466 /* The leading dimension of the array T. LDT >= max(1,N). */
13467
13468 /* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */
13469 /* On entry, if COMPQ = 'V', the matrix Q of Schur vectors. */
13470 /* On exit, if COMPQ = 'V', Q has been postmultiplied by the */
13471 /* orthogonal transformation matrix which reorders T; the */
13472 /* leading M columns of Q form an orthonormal basis for the */
13473 /* specified invariant subspace. */
13474 /* If COMPQ = 'N', Q is not referenced. */
13475
13476 /* LDQ (input) INTEGER */
13477 /* The leading dimension of the array Q. */
13478 /* LDQ >= 1; and if COMPQ = 'V', LDQ >= N. */
13479
13480 /* WR (output) DOUBLE PRECISION array, dimension (N) */
13481 /* WI (output) DOUBLE PRECISION array, dimension (N) */
13482 /* The real and imaginary parts, respectively, of the reordered */
13483 /* eigenvalues of T. The eigenvalues are stored in the same */
13484 /* order as on the diagonal of T, with WR(i) = T(i,i) and, if */
13485 /* T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and */
13486 /* WI(i+1) = -WI(i). Note that if a complex eigenvalue is */
13487 /* sufficiently ill-conditioned, then its value may differ */
13488 /* significantly from its value before reordering. */
13489
13490 /* M (output) INTEGER */
13491 /* The dimension of the specified invariant subspace. */
13492 /* 0 < = M <= N. */
13493
13494 /* S (output) DOUBLE PRECISION */
13495 /* If JOB = 'E' or 'B', S is a lower bound on the reciprocal */
13496 /* condition number for the selected cluster of eigenvalues. */
13497 /* S cannot underestimate the true reciprocal condition number */
13498 /* by more than a factor of sqrt(N). If M = 0 or N, S = 1. */
13499 /* If JOB = 'N' or 'V', S is not referenced. */
13500
13501 /* SEP (output) DOUBLE PRECISION */
13502 /* If JOB = 'V' or 'B', SEP is the estimated reciprocal */
13503 /* condition number of the specified invariant subspace. If */
13504 /* M = 0 or N, SEP = norm(T). */
13505 /* If JOB = 'N' or 'E', SEP is not referenced. */
13506
13507 /* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
13508 /* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
13509
13510 /* LWORK (input) INTEGER */
13511 /* The dimension of the array WORK. */
13512 /* If JOB = 'N', LWORK >= max(1,N); */
13513 /* if JOB = 'E', LWORK >= max(1,M*(N-M)); */
13514 /* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)). */
13515
13516 /* If LWORK = -1, then a workspace query is assumed; the routine */
13517 /* only calculates the optimal size of the WORK array, returns */
13518 /* this value as the first entry of the WORK array, and no error */
13519 /* message related to LWORK is issued by XERBLA. */
13520
13521 /* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK)) */
13522 /* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
13523
13524 /* LIWORK (input) INTEGER */
13525 /* The dimension of the array IWORK. */
13526 /* If JOB = 'N' or 'E', LIWORK >= 1; */
13527 /* if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)). */
13528
13529 /* If LIWORK = -1, then a workspace query is assumed; the */
13530 /* routine only calculates the optimal size of the IWORK array, */
13531 /* returns this value as the first entry of the IWORK array, and */
13532 /* no error message related to LIWORK is issued by XERBLA. */
13533
13534 /* INFO (output) INTEGER */
13535 /* = 0: successful exit */
13536 /* < 0: if INFO = -i, the i-th argument had an illegal value */
13537 /* = 1: reordering of T failed because some eigenvalues are too */
13538 /* close to separate (the problem is very ill-conditioned); */
13539 /* T may have been partially reordered, and WR and WI */
13540 /* contain the eigenvalues in the same order as in T; S and */
13541 /* SEP (if requested) are set to zero. */
13542
13543 /* Further Details */
13544 /* =============== */
13545
13546 /* DTRSEN first collects the selected eigenvalues by computing an */
13547 /* orthogonal transformation Z to move them to the top left corner of T. */
13548 /* In other words, the selected eigenvalues are the eigenvalues of T11 */
13549 /* in: */
13550
13551 /* Z'*T*Z = ( T11 T12 ) n1 */
13552 /* ( 0 T22 ) n2 */
13553 /* n1 n2 */
13554
13555 /* where N = n1+n2 and Z' means the transpose of Z. The first n1 columns */
13556 /* of Z span the specified invariant subspace of T. */
13557
13558 /* If T has been obtained from the real Schur factorization of a matrix */
13559 /* A = Q*T*Q', then the reordered real Schur factorization of A is given */
13560 /* by A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span */
13561 /* the corresponding invariant subspace of A. */
13562
13563 /* The reciprocal condition number of the average of the eigenvalues of */
13564 /* T11 may be returned in S. S lies between 0 (very badly conditioned) */
13565 /* and 1 (very well conditioned). It is computed as follows. First we */
13566 /* compute R so that */
13567
13568 /* P = ( I R ) n1 */
13569 /* ( 0 0 ) n2 */
13570 /* n1 n2 */
13571
13572 /* is the projector on the invariant subspace associated with T11. */
13573 /* R is the solution of the Sylvester equation: */
13574
13575 /* T11*R - R*T22 = T12. */
13576
13577 /* Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote */
13578 /* the two-norm of M. Then S is computed as the lower bound */
13579
13580 /* (1 + F-norm(R)**2)**(-1/2) */
13581
13582 /* on the reciprocal of 2-norm(P), the true reciprocal condition number. */
13583 /* S cannot underestimate 1 / 2-norm(P) by more than a factor of */
13584 /* sqrt(N). */
13585
13586 /* An approximate error bound for the computed average of the */
13587 /* eigenvalues of T11 is */
13588
13589 /* EPS * norm(T) / S */
13590
13591 /* where EPS is the machine precision. */
13592
13593 /* The reciprocal condition number of the right invariant subspace */
13594 /* spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP. */
13595 /* SEP is defined as the separation of T11 and T22: */
13596
13597 /* sep( T11, T22 ) = sigma-min( C ) */
13598
13599 /* where sigma-min(C) is the smallest singular value of the */
13600 /* n1*n2-by-n1*n2 matrix */
13601
13602 /* C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) ) */
13603
13604 /* I(m) is an m by m identity matrix, and kprod denotes the Kronecker */
13605 /* product. We estimate sigma-min(C) by the reciprocal of an estimate of */
13606 /* the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C) */
13607 /* cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2). */
13608
13609 /* When SEP is small, small changes in T can cause large changes in */
13610 /* the invariant subspace. An approximate bound on the maximum angular */
13611 /* error in the computed right invariant subspace is */
13612
13613 /* EPS * norm(T) / SEP */
13614
13615 /* ===================================================================== */
13616
13617 /* .. Parameters .. */
13618 /* .. */
13619 /* .. Local Scalars .. */
13620 /* .. */
13621 /* .. Local Arrays .. */
13622 /* .. */
13623 /* .. External Functions .. */
13624 /* .. */
13625 /* .. External Subroutines .. */
13626 /* .. */
13627 /* .. Intrinsic Functions .. */
13628 /* .. */
13629 /* .. Executable Statements .. */
13630
13631 /* Decode and test the input parameters */
13632
13633 /* Parameter adjustments */
13634 --select;
13635 t_dim1 = *ldt;
13636 t_offset = 1 + t_dim1;
13637 t -= t_offset;
13638 q_dim1 = *ldq;
13639 q_offset = 1 + q_dim1;
13640 q -= q_offset;
13641 --wr;
13642 --wi;
13643 --work;
13644 --iwork;
13645
13646 /* Function Body */
13647 wantbh = lsame_(job, "B");
13648 wants = lsame_(job, "E") || wantbh;
13649 wantsp = lsame_(job, "V") || wantbh;
13650 wantq = lsame_(compq, "V");
13651
13652 *info = 0;
13653 lquery = *lwork == -1;
13654 if (! lsame_(job, "N") && ! wants && ! wantsp) {
13655 *info = -1;
13656 } else if (! lsame_(compq, "N") && ! wantq) {
13657 *info = -2;
13658 } else if (*n < 0) {
13659 *info = -4;
13660 } else if (*ldt < std::max(1_integer,*n)) {
13661 *info = -6;
13662 } else if (*ldq < 1 || wantq && *ldq < *n) {
13663 *info = -8;
13664 } else {
13665
13666 /* Set M to the dimension of the specified invariant subspace, */
13667 /* and test LWORK and LIWORK. */
13668
13669 *m = 0;
13670 pair = false;
13671 i__1 = *n;
13672 for (k = 1; k <= i__1; ++k) {
13673 if (pair) {
13674 pair = false;
13675 } else {
13676 if (k < *n) {
13677 if (t[k + 1 + k * t_dim1] == 0.) {
13678 if (select[k]) {
13679 ++(*m);
13680 }
13681 } else {
13682 pair = true;
13683 if (select[k] || select[k + 1]) {
13684 *m += 2;
13685 }
13686 }
13687 } else {
13688 if (select[*n]) {
13689 ++(*m);
13690 }
13691 }
13692 }
13693 /* L10: */
13694 }
13695
13696 n1 = *m;
13697 n2 = *n - *m;
13698 nn = n1 * n2;
13699
13700 if (wantsp) {
13701 /* Computing MAX */
13702 i__1 = 1, i__2 = nn << 1;
13703 lwmin = std::max(i__1,i__2);
13704 liwmin = std::max(1_integer,nn);
13705 } else if (lsame_(job, "N")) {
13706 lwmin = std::max(1_integer,*n);
13707 liwmin = 1;
13708 } else if (lsame_(job, "E")) {
13709 lwmin = std::max(1_integer,nn);
13710 liwmin = 1;
13711 }
13712
13713 if (*lwork < lwmin && ! lquery) {
13714 *info = -15;
13715 } else if (*liwork < liwmin && ! lquery) {
13716 *info = -17;
13717 }
13718 }
13719
13720 if (*info == 0) {
13721 work[1] = (double) lwmin;
13722 iwork[1] = liwmin;
13723 }
13724
13725 if (*info != 0) {
13726 i__1 = -(*info);
13727 xerbla_("DTRSEN", &i__1);
13728 return 0;
13729 } else if (lquery) {
13730 return 0;
13731 }
13732
13733 /* Quick return if possible. */
13734
13735 if (*m == *n || *m == 0) {
13736 if (wants) {
13737 *s = 1.;
13738 }
13739 if (wantsp) {
13740 *sep = dlange_("1", n, n, &t[t_offset], ldt, &work[1]);
13741 }
13742 goto L40;
13743 }
13744
13745 /* Collect the selected blocks at the top-left corner of T. */
13746
13747 ks = 0;
13748 pair = false;
13749 i__1 = *n;
13750 for (k = 1; k <= i__1; ++k) {
13751 if (pair) {
13752 pair = false;
13753 } else {
13754 swap = select[k];
13755 if (k < *n) {
13756 if (t[k + 1 + k * t_dim1] != 0.) {
13757 pair = true;
13758 swap = swap || select[k + 1];
13759 }
13760 }
13761 if (swap) {
13762 ++ks;
13763
13764 /* Swap the K-th block to position KS. */
13765
13766 ierr = 0;
13767 kk = k;
13768 if (k != ks) {
13769 dtrexc_(compq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
13770 kk, &ks, &work[1], &ierr);
13771 }
13772 if (ierr == 1 || ierr == 2) {
13773
13774 /* Blocks too close to swap: exit. */
13775
13776 *info = 1;
13777 if (wants) {
13778 *s = 0.;
13779 }
13780 if (wantsp) {
13781 *sep = 0.;
13782 }
13783 goto L40;
13784 }
13785 if (pair) {
13786 ++ks;
13787 }
13788 }
13789 }
13790 /* L20: */
13791 }
13792
13793 if (wants) {
13794
13795 /* Solve Sylvester equation for R: */
13796
13797 /* T11*R - R*T22 = scale*T12 */
13798
13799 dlacpy_("F", &n1, &n2, &t[(n1 + 1) * t_dim1 + 1], ldt, &work[1], &n1);
13800 dtrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + 1 + (n1
13801 + 1) * t_dim1], ldt, &work[1], &n1, &scale, &ierr);
13802
13803 /* Estimate the reciprocal of the condition number of the cluster */
13804 /* of eigenvalues. */
13805
13806 rnorm = dlange_("F", &n1, &n2, &work[1], &n1, &work[1]);
13807 if (rnorm == 0.) {
13808 *s = 1.;
13809 } else {
13810 *s = scale / (sqrt(scale * scale / rnorm + rnorm) * sqrt(rnorm));
13811 }
13812 }
13813
13814 if (wantsp) {
13815
13816 /* Estimate sep(T11,T22). */
13817
13818 est = 0.;
13819 kase = 0;
13820 L30:
13821 dlacn2_(&nn, &work[nn + 1], &work[1], &iwork[1], &est, &kase, isave);
13822 if (kase != 0) {
13823 if (kase == 1) {
13824
13825 /* Solve T11*R - R*T22 = scale*X. */
13826
13827 dtrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 +
13828 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, &
13829 ierr);
13830 } else {
13831
13832 /* Solve T11'*R - R*T22' = scale*X. */
13833
13834 dtrsyl_("T", "T", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 +
13835 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, &
13836 ierr);
13837 }
13838 goto L30;
13839 }
13840
13841 *sep = scale / est;
13842 }
13843
13844 L40:
13845
13846 /* Store the output eigenvalues in WR and WI. */
13847
13848 i__1 = *n;
13849 for (k = 1; k <= i__1; ++k) {
13850 wr[k] = t[k + k * t_dim1];
13851 wi[k] = 0.;
13852 /* L50: */
13853 }
13854 i__1 = *n - 1;
13855 for (k = 1; k <= i__1; ++k) {
13856 if (t[k + 1 + k * t_dim1] != 0.) {
13857 wi[k] = sqrt((d__1 = t[k + (k + 1) * t_dim1], abs(d__1))) * sqrt((
13858 d__2 = t[k + 1 + k * t_dim1], abs(d__2)));
13859 wi[k + 1] = -wi[k];
13860 }
13861 /* L60: */
13862 }
13863
13864 work[1] = (double) lwmin;
13865 iwork[1] = liwmin;
13866
13867 return 0;
13868
13869 /* End of DTRSEN */
13870
13871 } /* dtrsen_ */
13872
dtrsna_(const char * job,const char * howmny,bool * select,integer * n,double * t,integer * ldt,double * vl,integer * ldvl,double * vr,integer * ldvr,double * s,double * sep,integer * mm,integer * m,double * work,integer * ldwork,integer * iwork,integer * info)13873 /* Subroutine */ int dtrsna_(const char *job, const char *howmny, bool *select,
13874 integer *n, double *t, integer *ldt, double *vl, integer *
13875 ldvl, double *vr, integer *ldvr, double *s, double *sep,
13876 integer *mm, integer *m, double *work, integer *ldwork, integer *
13877 iwork, integer *info)
13878 {
13879 /* Table of constant values */
13880 static integer c__1 = 1;
13881 static bool c_true = true;
13882 static bool c_false = false;
13883
13884 /* System generated locals */
13885 integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset,
13886 work_dim1, work_offset, i__1, i__2;
13887 double d__1, d__2;
13888
13889 /* Local variables */
13890 integer i__, j, k, n2;
13891 double cs;
13892 integer nn, ks;
13893 double sn, mu, eps, est;
13894 integer kase;
13895 double cond;
13896 bool pair;
13897 integer ierr;
13898 double dumm, prod;
13899 integer ifst;
13900 double lnrm;
13901 integer ilst;
13902 double rnrm;
13903 double prod1, prod2, scale, delta;
13904 integer isave[3];
13905 bool wants;
13906 double dummy[1];
13907 double bignum;
13908 bool wantbh;
13909 bool somcon;
13910 double smlnum;
13911 bool wantsp;
13912
13913
13914 /* -- LAPACK routine (version 3.1) -- */
13915 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
13916 /* November 2006 */
13917
13918 /* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
13919
13920 /* .. Scalar Arguments .. */
13921 /* .. */
13922 /* .. Array Arguments .. */
13923 /* .. */
13924
13925 /* Purpose */
13926 /* ======= */
13927
13928 /* DTRSNA estimates reciprocal condition numbers for specified */
13929 /* eigenvalues and/or right eigenvectors of a real upper */
13930 /* quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q */
13931 /* orthogonal). */
13932
13933 /* T must be in Schur canonical form (as returned by DHSEQR), that is, */
13934 /* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each */
13935 /* 2-by-2 diagonal block has its diagonal elements equal and its */
13936 /* off-diagonal elements of opposite sign. */
13937
13938 /* Arguments */
13939 /* ========= */
13940
13941 /* JOB (input) CHARACTER*1 */
13942 /* Specifies whether condition numbers are required for */
13943 /* eigenvalues (S) or eigenvectors (SEP): */
13944 /* = 'E': for eigenvalues only (S); */
13945 /* = 'V': for eigenvectors only (SEP); */
13946 /* = 'B': for both eigenvalues and eigenvectors (S and SEP). */
13947
13948 /* HOWMNY (input) CHARACTER*1 */
13949 /* = 'A': compute condition numbers for all eigenpairs; */
13950 /* = 'S': compute condition numbers for selected eigenpairs */
13951 /* specified by the array SELECT. */
13952
13953 /* SELECT (input) LOGICAL array, dimension (N) */
13954 /* If HOWMNY = 'S', SELECT specifies the eigenpairs for which */
13955 /* condition numbers are required. To select condition numbers */
13956 /* for the eigenpair corresponding to a real eigenvalue w(j), */
13957 /* SELECT(j) must be set to .TRUE.. To select condition numbers */
13958 /* corresponding to a complex conjugate pair of eigenvalues w(j) */
13959 /* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be */
13960 /* set to .TRUE.. */
13961 /* If HOWMNY = 'A', SELECT is not referenced. */
13962
13963 /* N (input) INTEGER */
13964 /* The order of the matrix T. N >= 0. */
13965
13966 /* T (input) DOUBLE PRECISION array, dimension (LDT,N) */
13967 /* The upper quasi-triangular matrix T, in Schur canonical form. */
13968
13969 /* LDT (input) INTEGER */
13970 /* The leading dimension of the array T. LDT >= max(1,N). */
13971
13972 /* VL (input) DOUBLE PRECISION array, dimension (LDVL,M) */
13973 /* If JOB = 'E' or 'B', VL must contain left eigenvectors of T */
13974 /* (or of any Q*T*Q**T with Q orthogonal), corresponding to the */
13975 /* eigenpairs specified by HOWMNY and SELECT. The eigenvectors */
13976 /* must be stored in consecutive columns of VL, as returned by */
13977 /* DHSEIN or DTREVC. */
13978 /* If JOB = 'V', VL is not referenced. */
13979
13980 /* LDVL (input) INTEGER */
13981 /* The leading dimension of the array VL. */
13982 /* LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N. */
13983
13984 /* VR (input) DOUBLE PRECISION array, dimension (LDVR,M) */
13985 /* If JOB = 'E' or 'B', VR must contain right eigenvectors of T */
13986 /* (or of any Q*T*Q**T with Q orthogonal), corresponding to the */
13987 /* eigenpairs specified by HOWMNY and SELECT. The eigenvectors */
13988 /* must be stored in consecutive columns of VR, as returned by */
13989 /* DHSEIN or DTREVC. */
13990 /* If JOB = 'V', VR is not referenced. */
13991
13992 /* LDVR (input) INTEGER */
13993 /* The leading dimension of the array VR. */
13994 /* LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N. */
13995
13996 /* S (output) DOUBLE PRECISION array, dimension (MM) */
13997 /* If JOB = 'E' or 'B', the reciprocal condition numbers of the */
13998 /* selected eigenvalues, stored in consecutive elements of the */
13999 /* array. For a complex conjugate pair of eigenvalues two */
14000 /* consecutive elements of S are set to the same value. Thus */
14001 /* S(j), SEP(j), and the j-th columns of VL and VR all */
14002 /* correspond to the same eigenpair (but not in general the */
14003 /* j-th eigenpair, unless all eigenpairs are selected). */
14004 /* If JOB = 'V', S is not referenced. */
14005
14006 /* SEP (output) DOUBLE PRECISION array, dimension (MM) */
14007 /* If JOB = 'V' or 'B', the estimated reciprocal condition */
14008 /* numbers of the selected eigenvectors, stored in consecutive */
14009 /* elements of the array. For a complex eigenvector two */
14010 /* consecutive elements of SEP are set to the same value. If */
14011 /* the eigenvalues cannot be reordered to compute SEP(j), SEP(j) */
14012 /* is set to 0; this can only occur when the true value would be */
14013 /* very small anyway. */
14014 /* If JOB = 'E', SEP is not referenced. */
14015
14016 /* MM (input) INTEGER */
14017 /* The number of elements in the arrays S (if JOB = 'E' or 'B') */
14018 /* and/or SEP (if JOB = 'V' or 'B'). MM >= M. */
14019
14020 /* M (output) INTEGER */
14021 /* The number of elements of the arrays S and/or SEP actually */
14022 /* used to store the estimated condition numbers. */
14023 /* If HOWMNY = 'A', M is set to N. */
14024
14025 /* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,N+6) */
14026 /* If JOB = 'E', WORK is not referenced. */
14027
14028 /* LDWORK (input) INTEGER */
14029 /* The leading dimension of the array WORK. */
14030 /* LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N. */
14031
14032 /* IWORK (workspace) INTEGER array, dimension (2*(N-1)) */
14033 /* If JOB = 'E', IWORK is not referenced. */
14034
14035 /* INFO (output) INTEGER */
14036 /* = 0: successful exit */
14037 /* < 0: if INFO = -i, the i-th argument had an illegal value */
14038
14039 /* Further Details */
14040 /* =============== */
14041
14042 /* The reciprocal of the condition number of an eigenvalue lambda is */
14043 /* defined as */
14044
14045 /* S(lambda) = |v'*u| / (norm(u)*norm(v)) */
14046
14047 /* where u and v are the right and left eigenvectors of T corresponding */
14048 /* to lambda; v' denotes the conjugate-transpose of v, and norm(u) */
14049 /* denotes the Euclidean norm. These reciprocal condition numbers always */
14050 /* lie between zero (very badly conditioned) and one (very well */
14051 /* conditioned). If n = 1, S(lambda) is defined to be 1. */
14052
14053 /* An approximate error bound for a computed eigenvalue W(i) is given by */
14054
14055 /* EPS * norm(T) / S(i) */
14056
14057 /* where EPS is the machine precision. */
14058
14059 /* The reciprocal of the condition number of the right eigenvector u */
14060 /* corresponding to lambda is defined as follows. Suppose */
14061
14062 /* T = ( lambda c ) */
14063 /* ( 0 T22 ) */
14064
14065 /* Then the reciprocal condition number is */
14066
14067 /* SEP( lambda, T22 ) = sigma-min( T22 - lambda*I ) */
14068
14069 /* where sigma-min denotes the smallest singular value. We approximate */
14070 /* the smallest singular value by the reciprocal of an estimate of the */
14071 /* one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is */
14072 /* defined to be abs(T(1,1)). */
14073
14074 /* An approximate error bound for a computed right eigenvector VR(i) */
14075 /* is given by */
14076
14077 /* EPS * norm(T) / SEP(i) */
14078
14079 /* ===================================================================== */
14080
14081 /* .. Parameters .. */
14082 /* .. */
14083 /* .. Local Scalars .. */
14084 /* .. */
14085 /* .. Local Arrays .. */
14086 /* .. */
14087 /* .. External Functions .. */
14088 /* .. */
14089 /* .. External Subroutines .. */
14090 /* .. */
14091 /* .. Intrinsic Functions .. */
14092 /* .. */
14093 /* .. Executable Statements .. */
14094
14095 /* Decode and test the input parameters */
14096
14097 /* Parameter adjustments */
14098 --select;
14099 t_dim1 = *ldt;
14100 t_offset = 1 + t_dim1;
14101 t -= t_offset;
14102 vl_dim1 = *ldvl;
14103 vl_offset = 1 + vl_dim1;
14104 vl -= vl_offset;
14105 vr_dim1 = *ldvr;
14106 vr_offset = 1 + vr_dim1;
14107 vr -= vr_offset;
14108 --s;
14109 --sep;
14110 work_dim1 = *ldwork;
14111 work_offset = 1 + work_dim1;
14112 work -= work_offset;
14113 --iwork;
14114
14115 /* Function Body */
14116 wantbh = lsame_(job, "B");
14117 wants = lsame_(job, "E") || wantbh;
14118 wantsp = lsame_(job, "V") || wantbh;
14119
14120 somcon = lsame_(howmny, "S");
14121
14122 *info = 0;
14123 if (! wants && ! wantsp) {
14124 *info = -1;
14125 } else if (! lsame_(howmny, "A") && ! somcon) {
14126 *info = -2;
14127 } else if (*n < 0) {
14128 *info = -4;
14129 } else if (*ldt < std::max(1_integer,*n)) {
14130 *info = -6;
14131 } else if (*ldvl < 1 || wants && *ldvl < *n) {
14132 *info = -8;
14133 } else if (*ldvr < 1 || wants && *ldvr < *n) {
14134 *info = -10;
14135 } else {
14136
14137 /* Set M to the number of eigenpairs for which condition numbers */
14138 /* are required, and test MM. */
14139
14140 if (somcon) {
14141 *m = 0;
14142 pair = false;
14143 i__1 = *n;
14144 for (k = 1; k <= i__1; ++k) {
14145 if (pair) {
14146 pair = false;
14147 } else {
14148 if (k < *n) {
14149 if (t[k + 1 + k * t_dim1] == 0.) {
14150 if (select[k]) {
14151 ++(*m);
14152 }
14153 } else {
14154 pair = true;
14155 if (select[k] || select[k + 1]) {
14156 *m += 2;
14157 }
14158 }
14159 } else {
14160 if (select[*n]) {
14161 ++(*m);
14162 }
14163 }
14164 }
14165 /* L10: */
14166 }
14167 } else {
14168 *m = *n;
14169 }
14170
14171 if (*mm < *m) {
14172 *info = -13;
14173 } else if (*ldwork < 1 || wantsp && *ldwork < *n) {
14174 *info = -16;
14175 }
14176 }
14177 if (*info != 0) {
14178 i__1 = -(*info);
14179 xerbla_("DTRSNA", &i__1);
14180 return 0;
14181 }
14182
14183 /* Quick return if possible */
14184
14185 if (*n == 0) {
14186 return 0;
14187 }
14188
14189 if (*n == 1) {
14190 if (somcon) {
14191 if (! select[1]) {
14192 return 0;
14193 }
14194 }
14195 if (wants) {
14196 s[1] = 1.;
14197 }
14198 if (wantsp) {
14199 sep[1] = (d__1 = t[t_dim1 + 1], abs(d__1));
14200 }
14201 return 0;
14202 }
14203
14204 /* Get machine constants */
14205
14206 eps = dlamch_("P");
14207 smlnum = dlamch_("S") / eps;
14208 bignum = 1. / smlnum;
14209 dlabad_(&smlnum, &bignum);
14210
14211 ks = 0;
14212 pair = false;
14213 i__1 = *n;
14214 for (k = 1; k <= i__1; ++k) {
14215
14216 /* Determine whether T(k,k) begins a 1-by-1 or 2-by-2 block. */
14217
14218 if (pair) {
14219 pair = false;
14220 goto L60;
14221 } else {
14222 if (k < *n) {
14223 pair = t[k + 1 + k * t_dim1] != 0.;
14224 }
14225 }
14226
14227 /* Determine whether condition numbers are required for the k-th */
14228 /* eigenpair. */
14229
14230 if (somcon) {
14231 if (pair) {
14232 if (! select[k] && ! select[k + 1]) {
14233 goto L60;
14234 }
14235 } else {
14236 if (! select[k]) {
14237 goto L60;
14238 }
14239 }
14240 }
14241
14242 ++ks;
14243
14244 if (wants) {
14245
14246 /* Compute the reciprocal condition number of the k-th */
14247 /* eigenvalue. */
14248
14249 if (! pair) {
14250
14251 /* Real eigenvalue. */
14252
14253 prod = ddot_(n, &vr[ks * vr_dim1 + 1], &c__1, &vl[ks *
14254 vl_dim1 + 1], &c__1);
14255 rnrm = dnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1);
14256 lnrm = dnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1);
14257 s[ks] = abs(prod) / (rnrm * lnrm);
14258 } else {
14259
14260 /* Complex eigenvalue. */
14261
14262 prod1 = ddot_(n, &vr[ks * vr_dim1 + 1], &c__1, &vl[ks *
14263 vl_dim1 + 1], &c__1);
14264 prod1 += ddot_(n, &vr[(ks + 1) * vr_dim1 + 1], &c__1, &vl[(ks
14265 + 1) * vl_dim1 + 1], &c__1);
14266 prod2 = ddot_(n, &vl[ks * vl_dim1 + 1], &c__1, &vr[(ks + 1) *
14267 vr_dim1 + 1], &c__1);
14268 prod2 -= ddot_(n, &vl[(ks + 1) * vl_dim1 + 1], &c__1, &vr[ks *
14269 vr_dim1 + 1], &c__1);
14270 d__1 = dnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1);
14271 d__2 = dnrm2_(n, &vr[(ks + 1) * vr_dim1 + 1], &c__1);
14272 rnrm = dlapy2_(&d__1, &d__2);
14273 d__1 = dnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1);
14274 d__2 = dnrm2_(n, &vl[(ks + 1) * vl_dim1 + 1], &c__1);
14275 lnrm = dlapy2_(&d__1, &d__2);
14276 cond = dlapy2_(&prod1, &prod2) / (rnrm * lnrm);
14277 s[ks] = cond;
14278 s[ks + 1] = cond;
14279 }
14280 }
14281
14282 if (wantsp) {
14283
14284 /* Estimate the reciprocal condition number of the k-th */
14285 /* eigenvector. */
14286
14287 /* Copy the matrix T to the array WORK and swap the diagonal */
14288 /* block beginning at T(k,k) to the (1,1) position. */
14289
14290 dlacpy_("Full", n, n, &t[t_offset], ldt, &work[work_offset],
14291 ldwork);
14292 ifst = k;
14293 ilst = 1;
14294 dtrexc_("No Q", n, &work[work_offset], ldwork, dummy, &c__1, &
14295 ifst, &ilst, &work[(*n + 1) * work_dim1 + 1], &ierr);
14296
14297 if (ierr == 1 || ierr == 2) {
14298
14299 /* Could not swap because blocks not well separated */
14300
14301 scale = 1.;
14302 est = bignum;
14303 } else {
14304
14305 /* Reordering successful */
14306
14307 if (work[work_dim1 + 2] == 0.) {
14308
14309 /* Form C = T22 - lambda*I in WORK(2:N,2:N). */
14310
14311 i__2 = *n;
14312 for (i__ = 2; i__ <= i__2; ++i__) {
14313 work[i__ + i__ * work_dim1] -= work[work_dim1 + 1];
14314 /* L20: */
14315 }
14316 n2 = 1;
14317 nn = *n - 1;
14318 } else {
14319
14320 /* Triangularize the 2 by 2 block by unitary */
14321 /* transformation U = [ cs i*ss ] */
14322 /* [ i*ss cs ]. */
14323 /* such that the (1,1) position of WORK is complex */
14324 /* eigenvalue lambda with positive imaginary part. (2,2) */
14325 /* position of WORK is the complex eigenvalue lambda */
14326 /* with negative imaginary part. */
14327
14328 mu = sqrt((d__1 = work[(work_dim1 << 1) + 1], abs(d__1)))
14329 * sqrt((d__2 = work[work_dim1 + 2], abs(d__2)));
14330 delta = dlapy2_(&mu, &work[work_dim1 + 2]);
14331 cs = mu / delta;
14332 sn = -work[work_dim1 + 2] / delta;
14333
14334 /* Form */
14335
14336 /* C' = WORK(2:N,2:N) + i*[rwork(1) ..... rwork(n-1) ] */
14337 /* [ mu ] */
14338 /* [ .. ] */
14339 /* [ .. ] */
14340 /* [ mu ] */
14341 /* where C' is conjugate transpose of complex matrix C, */
14342 /* and RWORK is stored starting in the N+1-st column of */
14343 /* WORK. */
14344
14345 i__2 = *n;
14346 for (j = 3; j <= i__2; ++j) {
14347 work[j * work_dim1 + 2] = cs * work[j * work_dim1 + 2]
14348 ;
14349 work[j + j * work_dim1] -= work[work_dim1 + 1];
14350 /* L30: */
14351 }
14352 work[(work_dim1 << 1) + 2] = 0.;
14353
14354 work[(*n + 1) * work_dim1 + 1] = mu * 2.;
14355 i__2 = *n - 1;
14356 for (i__ = 2; i__ <= i__2; ++i__) {
14357 work[i__ + (*n + 1) * work_dim1] = sn * work[(i__ + 1)
14358 * work_dim1 + 1];
14359 /* L40: */
14360 }
14361 n2 = 2;
14362 nn = *n - 1 << 1;
14363 }
14364
14365 /* Estimate norm(inv(C')) */
14366
14367 est = 0.;
14368 kase = 0;
14369 L50:
14370 dlacn2_(&nn, &work[(*n + 2) * work_dim1 + 1], &work[(*n + 4) *
14371 work_dim1 + 1], &iwork[1], &est, &kase, isave);
14372 if (kase != 0) {
14373 if (kase == 1) {
14374 if (n2 == 1) {
14375
14376 /* Real eigenvalue: solve C'*x = scale*c. */
14377
14378 i__2 = *n - 1;
14379 dlaqtr_(&c_true, &c_true, &i__2, &work[(work_dim1
14380 << 1) + 2], ldwork, dummy, &dumm, &scale,
14381 &work[(*n + 4) * work_dim1 + 1], &work[(*
14382 n + 6) * work_dim1 + 1], &ierr);
14383 } else {
14384
14385 /* Complex eigenvalue: solve */
14386 /* C'*(p+iq) = scale*(c+id) in real arithmetic. */
14387
14388 i__2 = *n - 1;
14389 dlaqtr_(&c_true, &c_false, &i__2, &work[(
14390 work_dim1 << 1) + 2], ldwork, &work[(*n +
14391 1) * work_dim1 + 1], &mu, &scale, &work[(*
14392 n + 4) * work_dim1 + 1], &work[(*n + 6) *
14393 work_dim1 + 1], &ierr);
14394 }
14395 } else {
14396 if (n2 == 1) {
14397
14398 /* Real eigenvalue: solve C*x = scale*c. */
14399
14400 i__2 = *n - 1;
14401 dlaqtr_(&c_false, &c_true, &i__2, &work[(
14402 work_dim1 << 1) + 2], ldwork, dummy, &
14403 dumm, &scale, &work[(*n + 4) * work_dim1
14404 + 1], &work[(*n + 6) * work_dim1 + 1], &
14405 ierr);
14406 } else {
14407
14408 /* Complex eigenvalue: solve */
14409 /* C*(p+iq) = scale*(c+id) in real arithmetic. */
14410
14411 i__2 = *n - 1;
14412 dlaqtr_(&c_false, &c_false, &i__2, &work[(
14413 work_dim1 << 1) + 2], ldwork, &work[(*n +
14414 1) * work_dim1 + 1], &mu, &scale, &work[(*
14415 n + 4) * work_dim1 + 1], &work[(*n + 6) *
14416 work_dim1 + 1], &ierr);
14417
14418 }
14419 }
14420
14421 goto L50;
14422 }
14423 }
14424
14425 sep[ks] = scale / std::max(est,smlnum);
14426 if (pair) {
14427 sep[ks + 1] = sep[ks];
14428 }
14429 }
14430
14431 if (pair) {
14432 ++ks;
14433 }
14434
14435 L60:
14436 ;
14437 }
14438 return 0;
14439
14440 /* End of DTRSNA */
14441
14442 } /* dtrsna_ */
14443
dtrsyl_(const char * trana,const char * tranb,integer * isgn,integer * m,integer * n,double * a,integer * lda,double * b,integer * ldb,double * c__,integer * ldc,double * scale,integer * info)14444 /* Subroutine */ int dtrsyl_(const char *trana, const char *tranb, integer *isgn, integer
14445 *m, integer *n, double *a, integer *lda, double *b, integer *
14446 ldb, double *c__, integer *ldc, double *scale, integer *info)
14447 {
14448 /* Table of constant values */
14449 static integer c__1 = 1;
14450 static bool c_false = false;
14451 static integer c__2 = 2;
14452 static double c_b26 = 1.;
14453 static double c_b30 = 0.;
14454 static bool c_true = true;
14455
14456 /* System generated locals */
14457 integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
14458 i__3, i__4;
14459 double d__1, d__2;
14460
14461 /* Local variables */
14462 integer j, k, l;
14463 double x[4] /* was [2][2] */;
14464 integer k1, k2, l1, l2;
14465 double a11, db, da11, vec[4] /* was [2][2] */, dum[1], eps, sgn;
14466 integer ierr;
14467 double smin, suml, sumr;
14468 integer knext, lnext;
14469 double xnorm;
14470 double scaloc;
14471 double bignum;
14472 bool notrna, notrnb;
14473 double smlnum;
14474
14475
14476 /* -- LAPACK routine (version 3.1) -- */
14477 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
14478 /* November 2006 */
14479
14480 /* .. Scalar Arguments .. */
14481 /* .. */
14482 /* .. Array Arguments .. */
14483 /* .. */
14484
14485 /* Purpose */
14486 /* ======= */
14487
14488 /* DTRSYL solves the real Sylvester matrix equation: */
14489
14490 /* op(A)*X + X*op(B) = scale*C or */
14491 /* op(A)*X - X*op(B) = scale*C, */
14492
14493 /* where op(A) = A or A**T, and A and B are both upper quasi- */
14494 /* triangular. A is M-by-M and B is N-by-N; the right hand side C and */
14495 /* the solution X are M-by-N; and scale is an output scale factor, set */
14496 /* <= 1 to avoid overflow in X. */
14497
14498 /* A and B must be in Schur canonical form (as returned by DHSEQR), that */
14499 /* is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; */
14500 /* each 2-by-2 diagonal block has its diagonal elements equal and its */
14501 /* off-diagonal elements of opposite sign. */
14502
14503 /* Arguments */
14504 /* ========= */
14505
14506 /* TRANA (input) CHARACTER*1 */
14507 /* Specifies the option op(A): */
14508 /* = 'N': op(A) = A (No transpose) */
14509 /* = 'T': op(A) = A**T (Transpose) */
14510 /* = 'C': op(A) = A**H (Conjugate transpose = Transpose) */
14511
14512 /* TRANB (input) CHARACTER*1 */
14513 /* Specifies the option op(B): */
14514 /* = 'N': op(B) = B (No transpose) */
14515 /* = 'T': op(B) = B**T (Transpose) */
14516 /* = 'C': op(B) = B**H (Conjugate transpose = Transpose) */
14517
14518 /* ISGN (input) INTEGER */
14519 /* Specifies the sign in the equation: */
14520 /* = +1: solve op(A)*X + X*op(B) = scale*C */
14521 /* = -1: solve op(A)*X - X*op(B) = scale*C */
14522
14523 /* M (input) INTEGER */
14524 /* The order of the matrix A, and the number of rows in the */
14525 /* matrices X and C. M >= 0. */
14526
14527 /* N (input) INTEGER */
14528 /* The order of the matrix B, and the number of columns in the */
14529 /* matrices X and C. N >= 0. */
14530
14531 /* A (input) DOUBLE PRECISION array, dimension (LDA,M) */
14532 /* The upper quasi-triangular matrix A, in Schur canonical form. */
14533
14534 /* LDA (input) INTEGER */
14535 /* The leading dimension of the array A. LDA >= max(1,M). */
14536
14537 /* B (input) DOUBLE PRECISION array, dimension (LDB,N) */
14538 /* The upper quasi-triangular matrix B, in Schur canonical form. */
14539
14540 /* LDB (input) INTEGER */
14541 /* The leading dimension of the array B. LDB >= max(1,N). */
14542
14543 /* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
14544 /* On entry, the M-by-N right hand side matrix C. */
14545 /* On exit, C is overwritten by the solution matrix X. */
14546
14547 /* LDC (input) INTEGER */
14548 /* The leading dimension of the array C. LDC >= max(1,M) */
14549
14550 /* SCALE (output) DOUBLE PRECISION */
14551 /* The scale factor, scale, set <= 1 to avoid overflow in X. */
14552
14553 /* INFO (output) INTEGER */
14554 /* = 0: successful exit */
14555 /* < 0: if INFO = -i, the i-th argument had an illegal value */
14556 /* = 1: A and B have common or very close eigenvalues; perturbed */
14557 /* values were used to solve the equation (but the matrices */
14558 /* A and B are unchanged). */
14559
14560 /* ===================================================================== */
14561
14562 /* .. Parameters .. */
14563 /* .. */
14564 /* .. Local Scalars .. */
14565 /* .. */
14566 /* .. Local Arrays .. */
14567 /* .. */
14568 /* .. External Functions .. */
14569 /* .. */
14570 /* .. External Subroutines .. */
14571 /* .. */
14572 /* .. Intrinsic Functions .. */
14573 /* .. */
14574 /* .. Executable Statements .. */
14575
14576 /* Decode and Test input parameters */
14577
14578 /* Parameter adjustments */
14579 a_dim1 = *lda;
14580 a_offset = 1 + a_dim1;
14581 a -= a_offset;
14582 b_dim1 = *ldb;
14583 b_offset = 1 + b_dim1;
14584 b -= b_offset;
14585 c_dim1 = *ldc;
14586 c_offset = 1 + c_dim1;
14587 c__ -= c_offset;
14588
14589 /* Function Body */
14590 notrna = lsame_(trana, "N");
14591 notrnb = lsame_(tranb, "N");
14592
14593 *info = 0;
14594 if (! notrna && ! lsame_(trana, "T") && ! lsame_(
14595 trana, "C")) {
14596 *info = -1;
14597 } else if (! notrnb && ! lsame_(tranb, "T") && !
14598 lsame_(tranb, "C")) {
14599 *info = -2;
14600 } else if (*isgn != 1 && *isgn != -1) {
14601 *info = -3;
14602 } else if (*m < 0) {
14603 *info = -4;
14604 } else if (*n < 0) {
14605 *info = -5;
14606 } else if (*lda < std::max(1_integer,*m)) {
14607 *info = -7;
14608 } else if (*ldb < std::max(1_integer,*n)) {
14609 *info = -9;
14610 } else if (*ldc < std::max(1_integer,*m)) {
14611 *info = -11;
14612 }
14613 if (*info != 0) {
14614 i__1 = -(*info);
14615 xerbla_("DTRSYL", &i__1);
14616 return 0;
14617 }
14618
14619 /* Quick return if possible */
14620
14621 if (*m == 0 || *n == 0) {
14622 return 0;
14623 }
14624
14625 /* Set constants to control overflow */
14626
14627 eps = dlamch_("P");
14628 smlnum = dlamch_("S");
14629 bignum = 1. / smlnum;
14630 dlabad_(&smlnum, &bignum);
14631 smlnum = smlnum * (double) (*m * *n) / eps;
14632 bignum = 1. / smlnum;
14633
14634 /* Computing MAX */
14635 d__1 = smlnum, d__2 = eps * dlange_("M", m, m, &a[a_offset], lda, dum), d__1 = std::max(d__1,d__2), d__2 = eps * dlange_("M", n, n,
14636 &b[b_offset], ldb, dum);
14637 smin = std::max(d__1,d__2);
14638
14639 *scale = 1.;
14640 sgn = (double) (*isgn);
14641
14642 if (notrna && notrnb) {
14643
14644 /* Solve A*X + ISGN*X*B = scale*C. */
14645
14646 /* The (K,L)th block of X is determined starting from */
14647 /* bottom-left corner column by column by */
14648
14649 /* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) */
14650
14651 /* Where */
14652 /* M L-1 */
14653 /* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)]. */
14654 /* I=K+1 J=1 */
14655
14656 /* Start column loop (index = L) */
14657 /* L1 (L2) : column index of the first (first) row of X(K,L). */
14658
14659 lnext = 1;
14660 i__1 = *n;
14661 for (l = 1; l <= i__1; ++l) {
14662 if (l < lnext) {
14663 goto L60;
14664 }
14665 if (l == *n) {
14666 l1 = l;
14667 l2 = l;
14668 } else {
14669 if (b[l + 1 + l * b_dim1] != 0.) {
14670 l1 = l;
14671 l2 = l + 1;
14672 lnext = l + 2;
14673 } else {
14674 l1 = l;
14675 l2 = l;
14676 lnext = l + 1;
14677 }
14678 }
14679
14680 /* Start row loop (index = K) */
14681 /* K1 (K2): row index of the first (last) row of X(K,L). */
14682
14683 knext = *m;
14684 for (k = *m; k >= 1; --k) {
14685 if (k > knext) {
14686 goto L50;
14687 }
14688 if (k == 1) {
14689 k1 = k;
14690 k2 = k;
14691 } else {
14692 if (a[k + (k - 1) * a_dim1] != 0.) {
14693 k1 = k - 1;
14694 k2 = k;
14695 knext = k - 2;
14696 } else {
14697 k1 = k;
14698 k2 = k;
14699 knext = k - 1;
14700 }
14701 }
14702
14703 if (l1 == l2 && k1 == k2) {
14704 i__2 = *m - k1;
14705 /* Computing MIN */
14706 i__3 = k1 + 1;
14707 /* Computing MIN */
14708 i__4 = k1 + 1;
14709 suml = ddot_(&i__2, &a[k1 + std::min(i__3, *m)* a_dim1], lda, &
14710 c__[std::min(i__4, *m)+ l1 * c_dim1], &c__1);
14711 i__2 = l1 - 1;
14712 sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 *
14713 b_dim1 + 1], &c__1);
14714 vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
14715 scaloc = 1.;
14716
14717 a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1];
14718 da11 = abs(a11);
14719 if (da11 <= smin) {
14720 a11 = smin;
14721 da11 = smin;
14722 *info = 1;
14723 }
14724 db = abs(vec[0]);
14725 if (da11 < 1. && db > 1.) {
14726 if (db > bignum * da11) {
14727 scaloc = 1. / db;
14728 }
14729 }
14730 x[0] = vec[0] * scaloc / a11;
14731
14732 if (scaloc != 1.) {
14733 i__2 = *n;
14734 for (j = 1; j <= i__2; ++j) {
14735 dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
14736 /* L10: */
14737 }
14738 *scale *= scaloc;
14739 }
14740 c__[k1 + l1 * c_dim1] = x[0];
14741
14742 } else if (l1 == l2 && k1 != k2) {
14743
14744 i__2 = *m - k2;
14745 /* Computing MIN */
14746 i__3 = k2 + 1;
14747 /* Computing MIN */
14748 i__4 = k2 + 1;
14749 suml = ddot_(&i__2, &a[k1 + std::min(i__3, *m)* a_dim1], lda, &
14750 c__[std::min(i__4, *m)+ l1 * c_dim1], &c__1);
14751 i__2 = l1 - 1;
14752 sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 *
14753 b_dim1 + 1], &c__1);
14754 vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
14755
14756 i__2 = *m - k2;
14757 /* Computing MIN */
14758 i__3 = k2 + 1;
14759 /* Computing MIN */
14760 i__4 = k2 + 1;
14761 suml = ddot_(&i__2, &a[k2 + std::min(i__3, *m)* a_dim1], lda, &
14762 c__[std::min(i__4, *m)+ l1 * c_dim1], &c__1);
14763 i__2 = l1 - 1;
14764 sumr = ddot_(&i__2, &c__[k2 + c_dim1], ldc, &b[l1 *
14765 b_dim1 + 1], &c__1);
14766 vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr);
14767
14768 d__1 = -sgn * b[l1 + l1 * b_dim1];
14769 dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1
14770 * a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &d__1,
14771 &c_b30, x, &c__2, &scaloc, &xnorm, &ierr);
14772 if (ierr != 0) {
14773 *info = 1;
14774 }
14775
14776 if (scaloc != 1.) {
14777 i__2 = *n;
14778 for (j = 1; j <= i__2; ++j) {
14779 dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
14780 /* L20: */
14781 }
14782 *scale *= scaloc;
14783 }
14784 c__[k1 + l1 * c_dim1] = x[0];
14785 c__[k2 + l1 * c_dim1] = x[1];
14786
14787 } else if (l1 != l2 && k1 == k2) {
14788
14789 i__2 = *m - k1;
14790 /* Computing MIN */
14791 i__3 = k1 + 1;
14792 /* Computing MIN */
14793 i__4 = k1 + 1;
14794 suml = ddot_(&i__2, &a[k1 + std::min(i__3, *m)* a_dim1], lda, &
14795 c__[std::min(i__4, *m)+ l1 * c_dim1], &c__1);
14796 i__2 = l1 - 1;
14797 sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 *
14798 b_dim1 + 1], &c__1);
14799 vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn *
14800 sumr));
14801
14802 i__2 = *m - k1;
14803 /* Computing MIN */
14804 i__3 = k1 + 1;
14805 /* Computing MIN */
14806 i__4 = k1 + 1;
14807 suml = ddot_(&i__2, &a[k1 + std::min(i__3, *m)* a_dim1], lda, &
14808 c__[std::min(i__4, *m)+ l2 * c_dim1], &c__1);
14809 i__2 = l1 - 1;
14810 sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l2 *
14811 b_dim1 + 1], &c__1);
14812 vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn *
14813 sumr));
14814
14815 d__1 = -sgn * a[k1 + k1 * a_dim1];
14816 dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 *
14817 b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &d__1,
14818 &c_b30, x, &c__2, &scaloc, &xnorm, &ierr);
14819 if (ierr != 0) {
14820 *info = 1;
14821 }
14822
14823 if (scaloc != 1.) {
14824 i__2 = *n;
14825 for (j = 1; j <= i__2; ++j) {
14826 dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
14827 /* L30: */
14828 }
14829 *scale *= scaloc;
14830 }
14831 c__[k1 + l1 * c_dim1] = x[0];
14832 c__[k1 + l2 * c_dim1] = x[1];
14833
14834 } else if (l1 != l2 && k1 != k2) {
14835
14836 i__2 = *m - k2;
14837 /* Computing MIN */
14838 i__3 = k2 + 1;
14839 /* Computing MIN */
14840 i__4 = k2 + 1;
14841 suml = ddot_(&i__2, &a[k1 + std::min(i__3, *m)* a_dim1], lda, &
14842 c__[std::min(i__4, *m)+ l1 * c_dim1], &c__1);
14843 i__2 = l1 - 1;
14844 sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 *
14845 b_dim1 + 1], &c__1);
14846 vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
14847
14848 i__2 = *m - k2;
14849 /* Computing MIN */
14850 i__3 = k2 + 1;
14851 /* Computing MIN */
14852 i__4 = k2 + 1;
14853 suml = ddot_(&i__2, &a[k1 + std::min(i__3, *m)* a_dim1], lda, &
14854 c__[std::min(i__4, *m)+ l2 * c_dim1], &c__1);
14855 i__2 = l1 - 1;
14856 sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l2 *
14857 b_dim1 + 1], &c__1);
14858 vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr);
14859
14860 i__2 = *m - k2;
14861 /* Computing MIN */
14862 i__3 = k2 + 1;
14863 /* Computing MIN */
14864 i__4 = k2 + 1;
14865 suml = ddot_(&i__2, &a[k2 + std::min(i__3, *m)* a_dim1], lda, &
14866 c__[std::min(i__4, *m)+ l1 * c_dim1], &c__1);
14867 i__2 = l1 - 1;
14868 sumr = ddot_(&i__2, &c__[k2 + c_dim1], ldc, &b[l1 *
14869 b_dim1 + 1], &c__1);
14870 vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr);
14871
14872 i__2 = *m - k2;
14873 /* Computing MIN */
14874 i__3 = k2 + 1;
14875 /* Computing MIN */
14876 i__4 = k2 + 1;
14877 suml = ddot_(&i__2, &a[k2 + std::min(i__3, *m)* a_dim1], lda, &
14878 c__[std::min(i__4, *m)+ l2 * c_dim1], &c__1);
14879 i__2 = l1 - 1;
14880 sumr = ddot_(&i__2, &c__[k2 + c_dim1], ldc, &b[l2 *
14881 b_dim1 + 1], &c__1);
14882 vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr);
14883
14884 dlasy2_(&c_false, &c_false, isgn, &c__2, &c__2, &a[k1 +
14885 k1 * a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec,
14886 &c__2, &scaloc, x, &c__2, &xnorm, &ierr);
14887 if (ierr != 0) {
14888 *info = 1;
14889 }
14890
14891 if (scaloc != 1.) {
14892 i__2 = *n;
14893 for (j = 1; j <= i__2; ++j) {
14894 dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
14895 /* L40: */
14896 }
14897 *scale *= scaloc;
14898 }
14899 c__[k1 + l1 * c_dim1] = x[0];
14900 c__[k1 + l2 * c_dim1] = x[2];
14901 c__[k2 + l1 * c_dim1] = x[1];
14902 c__[k2 + l2 * c_dim1] = x[3];
14903 }
14904
14905 L50:
14906 ;
14907 }
14908
14909 L60:
14910 ;
14911 }
14912
14913 } else if (! notrna && notrnb) {
14914
14915 /* Solve A' *X + ISGN*X*B = scale*C. */
14916
14917 /* The (K,L)th block of X is determined starting from */
14918 /* upper-left corner column by column by */
14919
14920 /* A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) */
14921
14922 /* Where */
14923 /* K-1 L-1 */
14924 /* R(K,L) = SUM [A(I,K)'*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)] */
14925 /* I=1 J=1 */
14926
14927 /* Start column loop (index = L) */
14928 /* L1 (L2): column index of the first (last) row of X(K,L) */
14929
14930 lnext = 1;
14931 i__1 = *n;
14932 for (l = 1; l <= i__1; ++l) {
14933 if (l < lnext) {
14934 goto L120;
14935 }
14936 if (l == *n) {
14937 l1 = l;
14938 l2 = l;
14939 } else {
14940 if (b[l + 1 + l * b_dim1] != 0.) {
14941 l1 = l;
14942 l2 = l + 1;
14943 lnext = l + 2;
14944 } else {
14945 l1 = l;
14946 l2 = l;
14947 lnext = l + 1;
14948 }
14949 }
14950
14951 /* Start row loop (index = K) */
14952 /* K1 (K2): row index of the first (last) row of X(K,L) */
14953
14954 knext = 1;
14955 i__2 = *m;
14956 for (k = 1; k <= i__2; ++k) {
14957 if (k < knext) {
14958 goto L110;
14959 }
14960 if (k == *m) {
14961 k1 = k;
14962 k2 = k;
14963 } else {
14964 if (a[k + 1 + k * a_dim1] != 0.) {
14965 k1 = k;
14966 k2 = k + 1;
14967 knext = k + 2;
14968 } else {
14969 k1 = k;
14970 k2 = k;
14971 knext = k + 1;
14972 }
14973 }
14974
14975 if (l1 == l2 && k1 == k2) {
14976 i__3 = k1 - 1;
14977 suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 *
14978 c_dim1 + 1], &c__1);
14979 i__3 = l1 - 1;
14980 sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 *
14981 b_dim1 + 1], &c__1);
14982 vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
14983 scaloc = 1.;
14984
14985 a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1];
14986 da11 = abs(a11);
14987 if (da11 <= smin) {
14988 a11 = smin;
14989 da11 = smin;
14990 *info = 1;
14991 }
14992 db = abs(vec[0]);
14993 if (da11 < 1. && db > 1.) {
14994 if (db > bignum * da11) {
14995 scaloc = 1. / db;
14996 }
14997 }
14998 x[0] = vec[0] * scaloc / a11;
14999
15000 if (scaloc != 1.) {
15001 i__3 = *n;
15002 for (j = 1; j <= i__3; ++j) {
15003 dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
15004 /* L70: */
15005 }
15006 *scale *= scaloc;
15007 }
15008 c__[k1 + l1 * c_dim1] = x[0];
15009
15010 } else if (l1 == l2 && k1 != k2) {
15011
15012 i__3 = k1 - 1;
15013 suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 *
15014 c_dim1 + 1], &c__1);
15015 i__3 = l1 - 1;
15016 sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 *
15017 b_dim1 + 1], &c__1);
15018 vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
15019
15020 i__3 = k1 - 1;
15021 suml = ddot_(&i__3, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 *
15022 c_dim1 + 1], &c__1);
15023 i__3 = l1 - 1;
15024 sumr = ddot_(&i__3, &c__[k2 + c_dim1], ldc, &b[l1 *
15025 b_dim1 + 1], &c__1);
15026 vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr);
15027
15028 d__1 = -sgn * b[l1 + l1 * b_dim1];
15029 dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 *
15030 a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &d__1,
15031 &c_b30, x, &c__2, &scaloc, &xnorm, &ierr);
15032 if (ierr != 0) {
15033 *info = 1;
15034 }
15035
15036 if (scaloc != 1.) {
15037 i__3 = *n;
15038 for (j = 1; j <= i__3; ++j) {
15039 dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
15040 /* L80: */
15041 }
15042 *scale *= scaloc;
15043 }
15044 c__[k1 + l1 * c_dim1] = x[0];
15045 c__[k2 + l1 * c_dim1] = x[1];
15046
15047 } else if (l1 != l2 && k1 == k2) {
15048
15049 i__3 = k1 - 1;
15050 suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 *
15051 c_dim1 + 1], &c__1);
15052 i__3 = l1 - 1;
15053 sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 *
15054 b_dim1 + 1], &c__1);
15055 vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn *
15056 sumr));
15057
15058 i__3 = k1 - 1;
15059 suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 *
15060 c_dim1 + 1], &c__1);
15061 i__3 = l1 - 1;
15062 sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l2 *
15063 b_dim1 + 1], &c__1);
15064 vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn *
15065 sumr));
15066
15067 d__1 = -sgn * a[k1 + k1 * a_dim1];
15068 dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 *
15069 b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &d__1,
15070 &c_b30, x, &c__2, &scaloc, &xnorm, &ierr);
15071 if (ierr != 0) {
15072 *info = 1;
15073 }
15074
15075 if (scaloc != 1.) {
15076 i__3 = *n;
15077 for (j = 1; j <= i__3; ++j) {
15078 dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
15079 /* L90: */
15080 }
15081 *scale *= scaloc;
15082 }
15083 c__[k1 + l1 * c_dim1] = x[0];
15084 c__[k1 + l2 * c_dim1] = x[1];
15085
15086 } else if (l1 != l2 && k1 != k2) {
15087
15088 i__3 = k1 - 1;
15089 suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 *
15090 c_dim1 + 1], &c__1);
15091 i__3 = l1 - 1;
15092 sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 *
15093 b_dim1 + 1], &c__1);
15094 vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
15095
15096 i__3 = k1 - 1;
15097 suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 *
15098 c_dim1 + 1], &c__1);
15099 i__3 = l1 - 1;
15100 sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l2 *
15101 b_dim1 + 1], &c__1);
15102 vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr);
15103
15104 i__3 = k1 - 1;
15105 suml = ddot_(&i__3, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 *
15106 c_dim1 + 1], &c__1);
15107 i__3 = l1 - 1;
15108 sumr = ddot_(&i__3, &c__[k2 + c_dim1], ldc, &b[l1 *
15109 b_dim1 + 1], &c__1);
15110 vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr);
15111
15112 i__3 = k1 - 1;
15113 suml = ddot_(&i__3, &a[k2 * a_dim1 + 1], &c__1, &c__[l2 *
15114 c_dim1 + 1], &c__1);
15115 i__3 = l1 - 1;
15116 sumr = ddot_(&i__3, &c__[k2 + c_dim1], ldc, &b[l2 *
15117 b_dim1 + 1], &c__1);
15118 vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr);
15119
15120 dlasy2_(&c_true, &c_false, isgn, &c__2, &c__2, &a[k1 + k1
15121 * a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, &
15122 c__2, &scaloc, x, &c__2, &xnorm, &ierr);
15123 if (ierr != 0) {
15124 *info = 1;
15125 }
15126
15127 if (scaloc != 1.) {
15128 i__3 = *n;
15129 for (j = 1; j <= i__3; ++j) {
15130 dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
15131 /* L100: */
15132 }
15133 *scale *= scaloc;
15134 }
15135 c__[k1 + l1 * c_dim1] = x[0];
15136 c__[k1 + l2 * c_dim1] = x[2];
15137 c__[k2 + l1 * c_dim1] = x[1];
15138 c__[k2 + l2 * c_dim1] = x[3];
15139 }
15140
15141 L110:
15142 ;
15143 }
15144 L120:
15145 ;
15146 }
15147
15148 } else if (! notrna && ! notrnb) {
15149
15150 /* Solve A'*X + ISGN*X*B' = scale*C. */
15151
15152 /* The (K,L)th block of X is determined starting from */
15153 /* top-right corner column by column by */
15154
15155 /* A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L)' = C(K,L) - R(K,L) */
15156
15157 /* Where */
15158 /* K-1 N */
15159 /* R(K,L) = SUM [A(I,K)'*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)']. */
15160 /* I=1 J=L+1 */
15161
15162 /* Start column loop (index = L) */
15163 /* L1 (L2): column index of the first (last) row of X(K,L) */
15164
15165 lnext = *n;
15166 for (l = *n; l >= 1; --l) {
15167 if (l > lnext) {
15168 goto L180;
15169 }
15170 if (l == 1) {
15171 l1 = l;
15172 l2 = l;
15173 } else {
15174 if (b[l + (l - 1) * b_dim1] != 0.) {
15175 l1 = l - 1;
15176 l2 = l;
15177 lnext = l - 2;
15178 } else {
15179 l1 = l;
15180 l2 = l;
15181 lnext = l - 1;
15182 }
15183 }
15184
15185 /* Start row loop (index = K) */
15186 /* K1 (K2): row index of the first (last) row of X(K,L) */
15187
15188 knext = 1;
15189 i__1 = *m;
15190 for (k = 1; k <= i__1; ++k) {
15191 if (k < knext) {
15192 goto L170;
15193 }
15194 if (k == *m) {
15195 k1 = k;
15196 k2 = k;
15197 } else {
15198 if (a[k + 1 + k * a_dim1] != 0.) {
15199 k1 = k;
15200 k2 = k + 1;
15201 knext = k + 2;
15202 } else {
15203 k1 = k;
15204 k2 = k;
15205 knext = k + 1;
15206 }
15207 }
15208
15209 if (l1 == l2 && k1 == k2) {
15210 i__2 = k1 - 1;
15211 suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 *
15212 c_dim1 + 1], &c__1);
15213 i__2 = *n - l1;
15214 /* Computing MIN */
15215 i__3 = l1 + 1;
15216 /* Computing MIN */
15217 i__4 = l1 + 1;
15218 sumr = ddot_(&i__2, &c__[k1 + std::min(i__3, *n)* c_dim1], ldc,
15219 &b[l1 + std::min(i__4, *n)* b_dim1], ldb);
15220 vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
15221 scaloc = 1.;
15222
15223 a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1];
15224 da11 = abs(a11);
15225 if (da11 <= smin) {
15226 a11 = smin;
15227 da11 = smin;
15228 *info = 1;
15229 }
15230 db = abs(vec[0]);
15231 if (da11 < 1. && db > 1.) {
15232 if (db > bignum * da11) {
15233 scaloc = 1. / db;
15234 }
15235 }
15236 x[0] = vec[0] * scaloc / a11;
15237
15238 if (scaloc != 1.) {
15239 i__2 = *n;
15240 for (j = 1; j <= i__2; ++j) {
15241 dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
15242 /* L130: */
15243 }
15244 *scale *= scaloc;
15245 }
15246 c__[k1 + l1 * c_dim1] = x[0];
15247
15248 } else if (l1 == l2 && k1 != k2) {
15249
15250 i__2 = k1 - 1;
15251 suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 *
15252 c_dim1 + 1], &c__1);
15253 i__2 = *n - l2;
15254 /* Computing MIN */
15255 i__3 = l2 + 1;
15256 /* Computing MIN */
15257 i__4 = l2 + 1;
15258 sumr = ddot_(&i__2, &c__[k1 + std::min(i__3, *n)* c_dim1], ldc,
15259 &b[l1 + std::min(i__4, *n)* b_dim1], ldb);
15260 vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
15261
15262 i__2 = k1 - 1;
15263 suml = ddot_(&i__2, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 *
15264 c_dim1 + 1], &c__1);
15265 i__2 = *n - l2;
15266 /* Computing MIN */
15267 i__3 = l2 + 1;
15268 /* Computing MIN */
15269 i__4 = l2 + 1;
15270 sumr = ddot_(&i__2, &c__[k2 + std::min(i__3, *n)* c_dim1], ldc,
15271 &b[l1 + std::min(i__4, *n)* b_dim1], ldb);
15272 vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr);
15273
15274 d__1 = -sgn * b[l1 + l1 * b_dim1];
15275 dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 *
15276 a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &d__1,
15277 &c_b30, x, &c__2, &scaloc, &xnorm, &ierr);
15278 if (ierr != 0) {
15279 *info = 1;
15280 }
15281
15282 if (scaloc != 1.) {
15283 i__2 = *n;
15284 for (j = 1; j <= i__2; ++j) {
15285 dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
15286 /* L140: */
15287 }
15288 *scale *= scaloc;
15289 }
15290 c__[k1 + l1 * c_dim1] = x[0];
15291 c__[k2 + l1 * c_dim1] = x[1];
15292
15293 } else if (l1 != l2 && k1 == k2) {
15294
15295 i__2 = k1 - 1;
15296 suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 *
15297 c_dim1 + 1], &c__1);
15298 i__2 = *n - l2;
15299 /* Computing MIN */
15300 i__3 = l2 + 1;
15301 /* Computing MIN */
15302 i__4 = l2 + 1;
15303 sumr = ddot_(&i__2, &c__[k1 + std::min(i__3, *n)* c_dim1], ldc,
15304 &b[l1 + std::min(i__4, *n)* b_dim1], ldb);
15305 vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn *
15306 sumr));
15307
15308 i__2 = k1 - 1;
15309 suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 *
15310 c_dim1 + 1], &c__1);
15311 i__2 = *n - l2;
15312 /* Computing MIN */
15313 i__3 = l2 + 1;
15314 /* Computing MIN */
15315 i__4 = l2 + 1;
15316 sumr = ddot_(&i__2, &c__[k1 + std::min(i__3, *n)* c_dim1], ldc,
15317 &b[l2 + std::min(i__4, *n)* b_dim1], ldb);
15318 vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn *
15319 sumr));
15320
15321 d__1 = -sgn * a[k1 + k1 * a_dim1];
15322 dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1
15323 * b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &d__1,
15324 &c_b30, x, &c__2, &scaloc, &xnorm, &ierr);
15325 if (ierr != 0) {
15326 *info = 1;
15327 }
15328
15329 if (scaloc != 1.) {
15330 i__2 = *n;
15331 for (j = 1; j <= i__2; ++j) {
15332 dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
15333 /* L150: */
15334 }
15335 *scale *= scaloc;
15336 }
15337 c__[k1 + l1 * c_dim1] = x[0];
15338 c__[k1 + l2 * c_dim1] = x[1];
15339
15340 } else if (l1 != l2 && k1 != k2) {
15341
15342 i__2 = k1 - 1;
15343 suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 *
15344 c_dim1 + 1], &c__1);
15345 i__2 = *n - l2;
15346 /* Computing MIN */
15347 i__3 = l2 + 1;
15348 /* Computing MIN */
15349 i__4 = l2 + 1;
15350 sumr = ddot_(&i__2, &c__[k1 + std::min(i__3, *n)* c_dim1], ldc,
15351 &b[l1 + std::min(i__4, *n)* b_dim1], ldb);
15352 vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
15353
15354 i__2 = k1 - 1;
15355 suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 *
15356 c_dim1 + 1], &c__1);
15357 i__2 = *n - l2;
15358 /* Computing MIN */
15359 i__3 = l2 + 1;
15360 /* Computing MIN */
15361 i__4 = l2 + 1;
15362 sumr = ddot_(&i__2, &c__[k1 + std::min(i__3, *n)* c_dim1], ldc,
15363 &b[l2 + std::min(i__4, *n)* b_dim1], ldb);
15364 vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr);
15365
15366 i__2 = k1 - 1;
15367 suml = ddot_(&i__2, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 *
15368 c_dim1 + 1], &c__1);
15369 i__2 = *n - l2;
15370 /* Computing MIN */
15371 i__3 = l2 + 1;
15372 /* Computing MIN */
15373 i__4 = l2 + 1;
15374 sumr = ddot_(&i__2, &c__[k2 + std::min(i__3, *n)* c_dim1], ldc,
15375 &b[l1 + std::min(i__4, *n)* b_dim1], ldb);
15376 vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr);
15377
15378 i__2 = k1 - 1;
15379 suml = ddot_(&i__2, &a[k2 * a_dim1 + 1], &c__1, &c__[l2 *
15380 c_dim1 + 1], &c__1);
15381 i__2 = *n - l2;
15382 /* Computing MIN */
15383 i__3 = l2 + 1;
15384 /* Computing MIN */
15385 i__4 = l2 + 1;
15386 sumr = ddot_(&i__2, &c__[k2 + std::min(i__3, *n)* c_dim1], ldc,
15387 &b[l2 + std::min(i__4, *n)* b_dim1], ldb);
15388 vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr);
15389
15390 dlasy2_(&c_true, &c_true, isgn, &c__2, &c__2, &a[k1 + k1 *
15391 a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, &
15392 c__2, &scaloc, x, &c__2, &xnorm, &ierr);
15393 if (ierr != 0) {
15394 *info = 1;
15395 }
15396
15397 if (scaloc != 1.) {
15398 i__2 = *n;
15399 for (j = 1; j <= i__2; ++j) {
15400 dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
15401 /* L160: */
15402 }
15403 *scale *= scaloc;
15404 }
15405 c__[k1 + l1 * c_dim1] = x[0];
15406 c__[k1 + l2 * c_dim1] = x[2];
15407 c__[k2 + l1 * c_dim1] = x[1];
15408 c__[k2 + l2 * c_dim1] = x[3];
15409 }
15410
15411 L170:
15412 ;
15413 }
15414 L180:
15415 ;
15416 }
15417
15418 } else if (notrna && ! notrnb) {
15419
15420 /* Solve A*X + ISGN*X*B' = scale*C. */
15421
15422 /* The (K,L)th block of X is determined starting from */
15423 /* bottom-right corner column by column by */
15424
15425 /* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L)' = C(K,L) - R(K,L) */
15426
15427 /* Where */
15428 /* M N */
15429 /* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)']. */
15430 /* I=K+1 J=L+1 */
15431
15432 /* Start column loop (index = L) */
15433 /* L1 (L2): column index of the first (last) row of X(K,L) */
15434
15435 lnext = *n;
15436 for (l = *n; l >= 1; --l) {
15437 if (l > lnext) {
15438 goto L240;
15439 }
15440 if (l == 1) {
15441 l1 = l;
15442 l2 = l;
15443 } else {
15444 if (b[l + (l - 1) * b_dim1] != 0.) {
15445 l1 = l - 1;
15446 l2 = l;
15447 lnext = l - 2;
15448 } else {
15449 l1 = l;
15450 l2 = l;
15451 lnext = l - 1;
15452 }
15453 }
15454
15455 /* Start row loop (index = K) */
15456 /* K1 (K2): row index of the first (last) row of X(K,L) */
15457
15458 knext = *m;
15459 for (k = *m; k >= 1; --k) {
15460 if (k > knext) {
15461 goto L230;
15462 }
15463 if (k == 1) {
15464 k1 = k;
15465 k2 = k;
15466 } else {
15467 if (a[k + (k - 1) * a_dim1] != 0.) {
15468 k1 = k - 1;
15469 k2 = k;
15470 knext = k - 2;
15471 } else {
15472 k1 = k;
15473 k2 = k;
15474 knext = k - 1;
15475 }
15476 }
15477
15478 if (l1 == l2 && k1 == k2) {
15479 i__1 = *m - k1;
15480 /* Computing MIN */
15481 i__2 = k1 + 1;
15482 /* Computing MIN */
15483 i__3 = k1 + 1;
15484 suml = ddot_(&i__1, &a[k1 + std::min(i__2, *m)* a_dim1], lda, &
15485 c__[std::min(i__3, *m)+ l1 * c_dim1], &c__1);
15486 i__1 = *n - l1;
15487 /* Computing MIN */
15488 i__2 = l1 + 1;
15489 /* Computing MIN */
15490 i__3 = l1 + 1;
15491 sumr = ddot_(&i__1, &c__[k1 + std::min(i__2, *n)* c_dim1], ldc,
15492 &b[l1 + std::min(i__3, *n)* b_dim1], ldb);
15493 vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
15494 scaloc = 1.;
15495
15496 a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1];
15497 da11 = abs(a11);
15498 if (da11 <= smin) {
15499 a11 = smin;
15500 da11 = smin;
15501 *info = 1;
15502 }
15503 db = abs(vec[0]);
15504 if (da11 < 1. && db > 1.) {
15505 if (db > bignum * da11) {
15506 scaloc = 1. / db;
15507 }
15508 }
15509 x[0] = vec[0] * scaloc / a11;
15510
15511 if (scaloc != 1.) {
15512 i__1 = *n;
15513 for (j = 1; j <= i__1; ++j) {
15514 dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
15515 /* L190: */
15516 }
15517 *scale *= scaloc;
15518 }
15519 c__[k1 + l1 * c_dim1] = x[0];
15520
15521 } else if (l1 == l2 && k1 != k2) {
15522
15523 i__1 = *m - k2;
15524 /* Computing MIN */
15525 i__2 = k2 + 1;
15526 /* Computing MIN */
15527 i__3 = k2 + 1;
15528 suml = ddot_(&i__1, &a[k1 + std::min(i__2, *m)* a_dim1], lda, &
15529 c__[std::min(i__3, *m)+ l1 * c_dim1], &c__1);
15530 i__1 = *n - l2;
15531 /* Computing MIN */
15532 i__2 = l2 + 1;
15533 /* Computing MIN */
15534 i__3 = l2 + 1;
15535 sumr = ddot_(&i__1, &c__[k1 + std::min(i__2, *n)* c_dim1], ldc,
15536 &b[l1 + std::min(i__3, *n)* b_dim1], ldb);
15537 vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
15538
15539 i__1 = *m - k2;
15540 /* Computing MIN */
15541 i__2 = k2 + 1;
15542 /* Computing MIN */
15543 i__3 = k2 + 1;
15544 suml = ddot_(&i__1, &a[k2 + std::min(i__2, *m)* a_dim1], lda, &
15545 c__[std::min(i__3, *m)+ l1 * c_dim1], &c__1);
15546 i__1 = *n - l2;
15547 /* Computing MIN */
15548 i__2 = l2 + 1;
15549 /* Computing MIN */
15550 i__3 = l2 + 1;
15551 sumr = ddot_(&i__1, &c__[k2 + std::min(i__2, *n)* c_dim1], ldc,
15552 &b[l1 + std::min(i__3, *n)* b_dim1], ldb);
15553 vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr);
15554
15555 d__1 = -sgn * b[l1 + l1 * b_dim1];
15556 dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1
15557 * a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &d__1,
15558 &c_b30, x, &c__2, &scaloc, &xnorm, &ierr);
15559 if (ierr != 0) {
15560 *info = 1;
15561 }
15562
15563 if (scaloc != 1.) {
15564 i__1 = *n;
15565 for (j = 1; j <= i__1; ++j) {
15566 dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
15567 /* L200: */
15568 }
15569 *scale *= scaloc;
15570 }
15571 c__[k1 + l1 * c_dim1] = x[0];
15572 c__[k2 + l1 * c_dim1] = x[1];
15573
15574 } else if (l1 != l2 && k1 == k2) {
15575
15576 i__1 = *m - k1;
15577 /* Computing MIN */
15578 i__2 = k1 + 1;
15579 /* Computing MIN */
15580 i__3 = k1 + 1;
15581 suml = ddot_(&i__1, &a[k1 + std::min(i__2, *m)* a_dim1], lda, &
15582 c__[std::min(i__3, *m)+ l1 * c_dim1], &c__1);
15583 i__1 = *n - l2;
15584 /* Computing MIN */
15585 i__2 = l2 + 1;
15586 /* Computing MIN */
15587 i__3 = l2 + 1;
15588 sumr = ddot_(&i__1, &c__[k1 + std::min(i__2, *n)* c_dim1], ldc,
15589 &b[l1 + std::min(i__3, *n)* b_dim1], ldb);
15590 vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn *
15591 sumr));
15592
15593 i__1 = *m - k1;
15594 /* Computing MIN */
15595 i__2 = k1 + 1;
15596 /* Computing MIN */
15597 i__3 = k1 + 1;
15598 suml = ddot_(&i__1, &a[k1 + std::min(i__2, *m)* a_dim1], lda, &
15599 c__[std::min(i__3, *m)+ l2 * c_dim1], &c__1);
15600 i__1 = *n - l2;
15601 /* Computing MIN */
15602 i__2 = l2 + 1;
15603 /* Computing MIN */
15604 i__3 = l2 + 1;
15605 sumr = ddot_(&i__1, &c__[k1 + std::min(i__2, *n)* c_dim1], ldc,
15606 &b[l2 + std::min(i__3, *n)* b_dim1], ldb);
15607 vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn *
15608 sumr));
15609
15610 d__1 = -sgn * a[k1 + k1 * a_dim1];
15611 dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1
15612 * b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &d__1,
15613 &c_b30, x, &c__2, &scaloc, &xnorm, &ierr);
15614 if (ierr != 0) {
15615 *info = 1;
15616 }
15617
15618 if (scaloc != 1.) {
15619 i__1 = *n;
15620 for (j = 1; j <= i__1; ++j) {
15621 dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
15622 /* L210: */
15623 }
15624 *scale *= scaloc;
15625 }
15626 c__[k1 + l1 * c_dim1] = x[0];
15627 c__[k1 + l2 * c_dim1] = x[1];
15628
15629 } else if (l1 != l2 && k1 != k2) {
15630
15631 i__1 = *m - k2;
15632 /* Computing MIN */
15633 i__2 = k2 + 1;
15634 /* Computing MIN */
15635 i__3 = k2 + 1;
15636 suml = ddot_(&i__1, &a[k1 + std::min(i__2, *m)* a_dim1], lda, &
15637 c__[std::min(i__3, *m)+ l1 * c_dim1], &c__1);
15638 i__1 = *n - l2;
15639 /* Computing MIN */
15640 i__2 = l2 + 1;
15641 /* Computing MIN */
15642 i__3 = l2 + 1;
15643 sumr = ddot_(&i__1, &c__[k1 + std::min(i__2, *n)* c_dim1], ldc,
15644 &b[l1 + std::min(i__3, *n)* b_dim1], ldb);
15645 vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
15646
15647 i__1 = *m - k2;
15648 /* Computing MIN */
15649 i__2 = k2 + 1;
15650 /* Computing MIN */
15651 i__3 = k2 + 1;
15652 suml = ddot_(&i__1, &a[k1 + std::min(i__2, *m)* a_dim1], lda, &
15653 c__[std::min(i__3, *m)+ l2 * c_dim1], &c__1);
15654 i__1 = *n - l2;
15655 /* Computing MIN */
15656 i__2 = l2 + 1;
15657 /* Computing MIN */
15658 i__3 = l2 + 1;
15659 sumr = ddot_(&i__1, &c__[k1 + std::min(i__2, *n)* c_dim1], ldc,
15660 &b[l2 + std::min(i__3, *n)* b_dim1], ldb);
15661 vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr);
15662
15663 i__1 = *m - k2;
15664 /* Computing MIN */
15665 i__2 = k2 + 1;
15666 /* Computing MIN */
15667 i__3 = k2 + 1;
15668 suml = ddot_(&i__1, &a[k2 + std::min(i__2, *m)* a_dim1], lda, &
15669 c__[std::min(i__3, *m)+ l1 * c_dim1], &c__1);
15670 i__1 = *n - l2;
15671 /* Computing MIN */
15672 i__2 = l2 + 1;
15673 /* Computing MIN */
15674 i__3 = l2 + 1;
15675 sumr = ddot_(&i__1, &c__[k2 + std::min(i__2, *n)* c_dim1], ldc,
15676 &b[l1 + std::min(i__3, *n)* b_dim1], ldb);
15677 vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr);
15678
15679 i__1 = *m - k2;
15680 /* Computing MIN */
15681 i__2 = k2 + 1;
15682 /* Computing MIN */
15683 i__3 = k2 + 1;
15684 suml = ddot_(&i__1, &a[k2 + std::min(i__2, *m)* a_dim1], lda, &
15685 c__[std::min(i__3, *m)+ l2 * c_dim1], &c__1);
15686 i__1 = *n - l2;
15687 /* Computing MIN */
15688 i__2 = l2 + 1;
15689 /* Computing MIN */
15690 i__3 = l2 + 1;
15691 sumr = ddot_(&i__1, &c__[k2 + std::min(i__2, *n)* c_dim1], ldc,
15692 &b[l2 + std::min(i__3, *n)* b_dim1], ldb);
15693 vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr);
15694
15695 dlasy2_(&c_false, &c_true, isgn, &c__2, &c__2, &a[k1 + k1
15696 * a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, &
15697 c__2, &scaloc, x, &c__2, &xnorm, &ierr);
15698 if (ierr != 0) {
15699 *info = 1;
15700 }
15701
15702 if (scaloc != 1.) {
15703 i__1 = *n;
15704 for (j = 1; j <= i__1; ++j) {
15705 dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
15706 /* L220: */
15707 }
15708 *scale *= scaloc;
15709 }
15710 c__[k1 + l1 * c_dim1] = x[0];
15711 c__[k1 + l2 * c_dim1] = x[2];
15712 c__[k2 + l1 * c_dim1] = x[1];
15713 c__[k2 + l2 * c_dim1] = x[3];
15714 }
15715
15716 L230:
15717 ;
15718 }
15719 L240:
15720 ;
15721 }
15722
15723 }
15724
15725 return 0;
15726
15727 /* End of DTRSYL */
15728
15729 } /* dtrsyl_ */
15730
dtrti2_(const char * uplo,const char * diag,integer * n,double * a,integer * lda,integer * info)15731 /* Subroutine */ int dtrti2_(const char *uplo, const char *diag, integer *n, double *
15732 a, integer *lda, integer *info)
15733 {
15734 /* Table of constant values */
15735 static integer c__1 = 1;
15736
15737 /* System generated locals */
15738 integer a_dim1, a_offset, i__1, i__2;
15739
15740 /* Local variables */
15741 integer j;
15742 double ajj;
15743 bool upper;
15744 bool nounit;
15745
15746 /* -- LAPACK routine (version 3.2) -- */
15747 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
15748 /* November 2006 */
15749
15750 /* .. Scalar Arguments .. */
15751 /* .. */
15752 /* .. Array Arguments .. */
15753 /* .. */
15754
15755 /* Purpose */
15756 /* ======= */
15757
15758 /* DTRTI2 computes the inverse of a real upper or lower triangular */
15759 /* matrix. */
15760
15761 /* This is the Level 2 BLAS version of the algorithm. */
15762
15763 /* Arguments */
15764 /* ========= */
15765
15766 /* UPLO (input) CHARACTER*1 */
15767 /* Specifies whether the matrix A is upper or lower triangular. */
15768 /* = 'U': Upper triangular */
15769 /* = 'L': Lower triangular */
15770
15771 /* DIAG (input) CHARACTER*1 */
15772 /* Specifies whether or not the matrix A is unit triangular. */
15773 /* = 'N': Non-unit triangular */
15774 /* = 'U': Unit triangular */
15775
15776 /* N (input) INTEGER */
15777 /* The order of the matrix A. N >= 0. */
15778
15779 /* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
15780 /* On entry, the triangular matrix A. If UPLO = 'U', the */
15781 /* leading n by n upper triangular part of the array A contains */
15782 /* the upper triangular matrix, and the strictly lower */
15783 /* triangular part of A is not referenced. If UPLO = 'L', the */
15784 /* leading n by n lower triangular part of the array A contains */
15785 /* the lower triangular matrix, and the strictly upper */
15786 /* triangular part of A is not referenced. If DIAG = 'U', the */
15787 /* diagonal elements of A are also not referenced and are */
15788 /* assumed to be 1. */
15789
15790 /* On exit, the (triangular) inverse of the original matrix, in */
15791 /* the same storage format. */
15792
15793 /* LDA (input) INTEGER */
15794 /* The leading dimension of the array A. LDA >= max(1,N). */
15795
15796 /* INFO (output) INTEGER */
15797 /* = 0: successful exit */
15798 /* < 0: if INFO = -k, the k-th argument had an illegal value */
15799
15800 /* ===================================================================== */
15801
15802 /* .. Parameters .. */
15803 /* .. */
15804 /* .. Local Scalars .. */
15805 /* .. */
15806 /* .. External Functions .. */
15807 /* .. */
15808 /* .. External Subroutines .. */
15809 /* .. */
15810 /* .. Intrinsic Functions .. */
15811 /* .. */
15812 /* .. Executable Statements .. */
15813
15814 /* Test the input parameters. */
15815
15816 /* Parameter adjustments */
15817 a_dim1 = *lda;
15818 a_offset = 1 + a_dim1;
15819 a -= a_offset;
15820
15821 /* Function Body */
15822 *info = 0;
15823 upper = lsame_(uplo, "U");
15824 nounit = lsame_(diag, "N");
15825 if (! upper && ! lsame_(uplo, "L")) {
15826 *info = -1;
15827 } else if (! nounit && ! lsame_(diag, "U")) {
15828 *info = -2;
15829 } else if (*n < 0) {
15830 *info = -3;
15831 } else if (*lda < std::max(1_integer,*n)) {
15832 *info = -5;
15833 }
15834 if (*info != 0) {
15835 i__1 = -(*info);
15836 xerbla_("DTRTI2", &i__1);
15837 return 0;
15838 }
15839
15840 if (upper) {
15841
15842 /* Compute inverse of upper triangular matrix. */
15843
15844 i__1 = *n;
15845 for (j = 1; j <= i__1; ++j) {
15846 if (nounit) {
15847 a[j + j * a_dim1] = 1. / a[j + j * a_dim1];
15848 ajj = -a[j + j * a_dim1];
15849 } else {
15850 ajj = -1.;
15851 }
15852
15853 /* Compute elements 1:j-1 of j-th column. */
15854
15855 i__2 = j - 1;
15856 dtrmv_("Upper", "No transpose", diag, &i__2, &a[a_offset], lda, &
15857 a[j * a_dim1 + 1], &c__1);
15858 i__2 = j - 1;
15859 dscal_(&i__2, &ajj, &a[j * a_dim1 + 1], &c__1);
15860 /* L10: */
15861 }
15862 } else {
15863
15864 /* Compute inverse of lower triangular matrix. */
15865
15866 for (j = *n; j >= 1; --j) {
15867 if (nounit) {
15868 a[j + j * a_dim1] = 1. / a[j + j * a_dim1];
15869 ajj = -a[j + j * a_dim1];
15870 } else {
15871 ajj = -1.;
15872 }
15873 if (j < *n) {
15874
15875 /* Compute elements j+1:n of j-th column. */
15876
15877 i__1 = *n - j;
15878 dtrmv_("Lower", "No transpose", diag, &i__1, &a[j + 1 + (j +
15879 1) * a_dim1], lda, &a[j + 1 + j * a_dim1], &c__1);
15880 i__1 = *n - j;
15881 dscal_(&i__1, &ajj, &a[j + 1 + j * a_dim1], &c__1);
15882 }
15883 /* L20: */
15884 }
15885 }
15886
15887 return 0;
15888
15889 /* End of DTRTI2 */
15890
15891 } /* dtrti2_ */
15892
dtrtri_(const char * uplo,const char * diag,integer * n,double * a,integer * lda,integer * info)15893 /* Subroutine */ int dtrtri_(const char *uplo, const char *diag, integer *n, double *
15894 a, integer *lda, integer *info)
15895 {
15896 /* Table of constant values */
15897 static integer c__1 = 1;
15898 static integer c_n1 = -1;
15899 static integer c__2 = 2;
15900 static double c_b18 = 1.;
15901 static double c_b22 = -1.;
15902
15903 /* System generated locals */
15904 char * a__1[2];
15905 integer a_dim1, a_offset, i__1, i__2[2], i__3, i__4, i__5;
15906 char ch__1[3] = { 0 };
15907
15908 /* Local variables */
15909 integer j, jb, nb, nn;
15910 bool upper;
15911 bool nounit;
15912
15913
15914 /* -- LAPACK routine (version 3.1) -- */
15915 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
15916 /* November 2006 */
15917
15918 /* .. Scalar Arguments .. */
15919 /* .. */
15920 /* .. Array Arguments .. */
15921 /* .. */
15922
15923 /* Purpose */
15924 /* ======= */
15925
15926 /* DTRTRI computes the inverse of a real upper or lower triangular */
15927 /* matrix A. */
15928
15929 /* This is the Level 3 BLAS version of the algorithm. */
15930
15931 /* Arguments */
15932 /* ========= */
15933
15934 /* UPLO (input) CHARACTER*1 */
15935 /* = 'U': A is upper triangular; */
15936 /* = 'L': A is lower triangular. */
15937
15938 /* DIAG (input) CHARACTER*1 */
15939 /* = 'N': A is non-unit triangular; */
15940 /* = 'U': A is unit triangular. */
15941
15942 /* N (input) INTEGER */
15943 /* The order of the matrix A. N >= 0. */
15944
15945 /* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
15946 /* On entry, the triangular matrix A. If UPLO = 'U', the */
15947 /* leading N-by-N upper triangular part of the array A contains */
15948 /* the upper triangular matrix, and the strictly lower */
15949 /* triangular part of A is not referenced. If UPLO = 'L', the */
15950 /* leading N-by-N lower triangular part of the array A contains */
15951 /* the lower triangular matrix, and the strictly upper */
15952 /* triangular part of A is not referenced. If DIAG = 'U', the */
15953 /* diagonal elements of A are also not referenced and are */
15954 /* assumed to be 1. */
15955 /* On exit, the (triangular) inverse of the original matrix, in */
15956 /* the same storage format. */
15957
15958 /* LDA (input) INTEGER */
15959 /* The leading dimension of the array A. LDA >= max(1,N). */
15960
15961 /* INFO (output) INTEGER */
15962 /* = 0: successful exit */
15963 /* < 0: if INFO = -i, the i-th argument had an illegal value */
15964 /* > 0: if INFO = i, A(i,i) is exactly zero. The triangular */
15965 /* matrix is singular and its inverse can not be computed. */
15966
15967 /* ===================================================================== */
15968
15969 /* .. Parameters .. */
15970 /* .. */
15971 /* .. Local Scalars .. */
15972 /* .. */
15973 /* .. External Functions .. */
15974 /* .. */
15975 /* .. External Subroutines .. */
15976 /* .. */
15977 /* .. Intrinsic Functions .. */
15978 /* .. */
15979 /* .. Executable Statements .. */
15980
15981 /* Test the input parameters. */
15982
15983 /* Parameter adjustments */
15984 a_dim1 = *lda;
15985 a_offset = 1 + a_dim1;
15986 a -= a_offset;
15987
15988 /* Function Body */
15989 *info = 0;
15990 upper = lsame_(uplo, "U");
15991 nounit = lsame_(diag, "N");
15992 if (! upper && ! lsame_(uplo, "L")) {
15993 *info = -1;
15994 } else if (! nounit && ! lsame_(diag, "U")) {
15995 *info = -2;
15996 } else if (*n < 0) {
15997 *info = -3;
15998 } else if (*lda < std::max(1_integer,*n)) {
15999 *info = -5;
16000 }
16001 if (*info != 0) {
16002 i__1 = -(*info);
16003 xerbla_("DTRTRI", &i__1);
16004 return 0;
16005 }
16006
16007 /* Quick return if possible */
16008
16009 if (*n == 0) {
16010 return 0;
16011 }
16012
16013 /* Check for singularity if non-unit. */
16014
16015 if (nounit) {
16016 i__1 = *n;
16017 for (*info = 1; *info <= i__1; ++(*info)) {
16018 if (a[*info + *info * a_dim1] == 0.) {
16019 return 0;
16020 }
16021 /* L10: */
16022 }
16023 *info = 0;
16024 }
16025
16026 /* Determine the block size for this environment. */
16027
16028 /* Writing concatenation */
16029 i__2[0] = 1, a__1[0] = const_cast<char *> (uplo);
16030 i__2[1] = 1, a__1[1] = const_cast<char *> (diag);
16031 s_cat(ch__1, a__1, i__2, &c__2, 2_integer);
16032 nb = ilaenv_(&c__1, "DTRTRI", ch__1, n, &c_n1, &c_n1, &c_n1);
16033 if (nb <= 1 || nb >= *n) {
16034
16035 /* Use unblocked code */
16036
16037 dtrti2_(uplo, diag, n, &a[a_offset], lda, info);
16038 } else {
16039
16040 /* Use blocked code */
16041
16042 if (upper) {
16043
16044 /* Compute inverse of upper triangular matrix */
16045
16046 i__1 = *n;
16047 i__3 = nb;
16048 for (j = 1; i__3 < 0 ? j >= i__1 : j <= i__1; j += i__3) {
16049 /* Computing MIN */
16050 i__4 = nb, i__5 = *n - j + 1;
16051 jb = std::min(i__4,i__5);
16052
16053 /* Compute rows 1:j-1 of current block column */
16054
16055 i__4 = j - 1;
16056 dtrmm_("Left", "Upper", "No transpose", diag, &i__4, &jb, &
16057 c_b18, &a[a_offset], lda, &a[j * a_dim1 + 1], lda);
16058 i__4 = j - 1;
16059 dtrsm_("Right", "Upper", "No transpose", diag, &i__4, &jb, &
16060 c_b22, &a[j + j * a_dim1], lda, &a[j * a_dim1 + 1],
16061 lda);
16062
16063 /* Compute inverse of current diagonal block */
16064
16065 dtrti2_("Upper", diag, &jb, &a[j + j * a_dim1], lda, info);
16066 /* L20: */
16067 }
16068 } else {
16069
16070 /* Compute inverse of lower triangular matrix */
16071
16072 nn = (*n - 1) / nb * nb + 1;
16073 i__3 = -nb;
16074 for (j = nn; i__3 < 0 ? j >= 1 : j <= 1; j += i__3) {
16075 /* Computing MIN */
16076 i__1 = nb, i__4 = *n - j + 1;
16077 jb = std::min(i__1,i__4);
16078 if (j + jb <= *n) {
16079
16080 /* Compute rows j+jb:n of current block column */
16081
16082 i__1 = *n - j - jb + 1;
16083 dtrmm_("Left", "Lower", "No transpose", diag, &i__1, &jb,
16084 &c_b18, &a[j + jb + (j + jb) * a_dim1], lda, &a[j
16085 + jb + j * a_dim1], lda);
16086 i__1 = *n - j - jb + 1;
16087 dtrsm_("Right", "Lower", "No transpose", diag, &i__1, &jb,
16088 &c_b22, &a[j + j * a_dim1], lda, &a[j + jb + j *
16089 a_dim1], lda);
16090 }
16091
16092 /* Compute inverse of current diagonal block */
16093
16094 dtrti2_("Lower", diag, &jb, &a[j + j * a_dim1], lda, info);
16095 /* L30: */
16096 }
16097 }
16098 }
16099
16100 return 0;
16101
16102 /* End of DTRTRI */
16103
16104 } /* dtrtri_ */
16105
dtrtrs_(const char * uplo,const char * trans,const char * diag,integer * n,integer * nrhs,double * a,integer * lda,double * b,integer * ldb,integer * info)16106 /* Subroutine */ int dtrtrs_(const char *uplo, const char *trans, const char *diag, integer *n,
16107 integer *nrhs, double *a, integer *lda, double *b, integer *
16108 ldb, integer *info)
16109 {
16110 /* Table of constant values */
16111 static double c_b12 = 1.;
16112
16113 /* System generated locals */
16114 integer a_dim1, a_offset, b_dim1, b_offset, i__1;
16115
16116 /* Local variables */
16117 bool nounit;
16118
16119
16120 /* -- LAPACK routine (version 3.1) -- */
16121 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
16122 /* November 2006 */
16123
16124 /* .. Scalar Arguments .. */
16125 /* .. */
16126 /* .. Array Arguments .. */
16127 /* .. */
16128
16129 /* Purpose */
16130 /* ======= */
16131
16132 /* DTRTRS solves a triangular system of the form */
16133
16134 /* A * X = B or A**T * X = B, */
16135
16136 /* where A is a triangular matrix of order N, and B is an N-by-NRHS */
16137 /* matrix. A check is made to verify that A is nonsingular. */
16138
16139 /* Arguments */
16140 /* ========= */
16141
16142 /* UPLO (input) CHARACTER*1 */
16143 /* = 'U': A is upper triangular; */
16144 /* = 'L': A is lower triangular. */
16145
16146 /* TRANS (input) CHARACTER*1 */
16147 /* Specifies the form of the system of equations: */
16148 /* = 'N': A * X = B (No transpose) */
16149 /* = 'T': A**T * X = B (Transpose) */
16150 /* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
16151
16152 /* DIAG (input) CHARACTER*1 */
16153 /* = 'N': A is non-unit triangular; */
16154 /* = 'U': A is unit triangular. */
16155
16156 /* N (input) INTEGER */
16157 /* The order of the matrix A. N >= 0. */
16158
16159 /* NRHS (input) INTEGER */
16160 /* The number of right hand sides, i.e., the number of columns */
16161 /* of the matrix B. NRHS >= 0. */
16162
16163 /* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
16164 /* The triangular matrix A. If UPLO = 'U', the leading N-by-N */
16165 /* upper triangular part of the array A contains the upper */
16166 /* triangular matrix, and the strictly lower triangular part of */
16167 /* A is not referenced. If UPLO = 'L', the leading N-by-N lower */
16168 /* triangular part of the array A contains the lower triangular */
16169 /* matrix, and the strictly upper triangular part of A is not */
16170 /* referenced. If DIAG = 'U', the diagonal elements of A are */
16171 /* also not referenced and are assumed to be 1. */
16172
16173 /* LDA (input) INTEGER */
16174 /* The leading dimension of the array A. LDA >= max(1,N). */
16175
16176 /* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
16177 /* On entry, the right hand side matrix B. */
16178 /* On exit, if INFO = 0, the solution matrix X. */
16179
16180 /* LDB (input) INTEGER */
16181 /* The leading dimension of the array B. LDB >= max(1,N). */
16182
16183 /* INFO (output) INTEGER */
16184 /* = 0: successful exit */
16185 /* < 0: if INFO = -i, the i-th argument had an illegal value */
16186 /* > 0: if INFO = i, the i-th diagonal element of A is zero, */
16187 /* indicating that the matrix is singular and the solutions */
16188 /* X have not been computed. */
16189
16190 /* ===================================================================== */
16191
16192 /* .. Parameters .. */
16193 /* .. */
16194 /* .. Local Scalars .. */
16195 /* .. */
16196 /* .. External Functions .. */
16197 /* .. */
16198 /* .. External Subroutines .. */
16199 /* .. */
16200 /* .. Intrinsic Functions .. */
16201 /* .. */
16202 /* .. Executable Statements .. */
16203
16204 /* Test the input parameters. */
16205
16206 /* Parameter adjustments */
16207 a_dim1 = *lda;
16208 a_offset = 1 + a_dim1;
16209 a -= a_offset;
16210 b_dim1 = *ldb;
16211 b_offset = 1 + b_dim1;
16212 b -= b_offset;
16213
16214 /* Function Body */
16215 *info = 0;
16216 nounit = lsame_(diag, "N");
16217 if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
16218 *info = -1;
16219 } else if (! lsame_(trans, "N") && ! lsame_(trans,
16220 "T") && ! lsame_(trans, "C")) {
16221 *info = -2;
16222 } else if (! nounit && ! lsame_(diag, "U")) {
16223 *info = -3;
16224 } else if (*n < 0) {
16225 *info = -4;
16226 } else if (*nrhs < 0) {
16227 *info = -5;
16228 } else if (*lda < std::max(1_integer,*n)) {
16229 *info = -7;
16230 } else if (*ldb < std::max(1_integer,*n)) {
16231 *info = -9;
16232 }
16233 if (*info != 0) {
16234 i__1 = -(*info);
16235 xerbla_("DTRTRS", &i__1);
16236 return 0;
16237 }
16238
16239 /* Quick return if possible */
16240
16241 if (*n == 0) {
16242 return 0;
16243 }
16244
16245 /* Check for singularity. */
16246
16247 if (nounit) {
16248 i__1 = *n;
16249 for (*info = 1; *info <= i__1; ++(*info)) {
16250 if (a[*info + *info * a_dim1] == 0.) {
16251 return 0;
16252 }
16253 /* L10: */
16254 }
16255 }
16256 *info = 0;
16257
16258 /* Solve A * x = b or A' * x = b. */
16259
16260 dtrsm_("Left", uplo, trans, diag, n, nrhs, &c_b12, &a[a_offset], lda, &b[
16261 b_offset], ldb);
16262
16263 return 0;
16264
16265 /* End of DTRTRS */
16266
16267 } /* dtrtrs_ */
16268
dtrttf_(const char * transr,const char * uplo,integer * n,double * a,integer * lda,double * arf,integer * info)16269 int dtrttf_(const char *transr, const char *uplo, integer *n, double *a, integer *lda, double *arf, integer *info)
16270 {
16271 /* System generated locals */
16272 integer a_dim1, a_offset, i__1, i__2;
16273
16274 /* Local variables */
16275 integer i__, j, k, l, n1, n2, ij, nt, nx2, np1x2;
16276 bool normaltransr, lower, nisodd;
16277
16278
16279 /* -- LAPACK routine (version 3.2) -- */
16280
16281 /* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
16282 /* -- November 2008 -- */
16283
16284 /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
16285 /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
16286
16287 /* .. Scalar Arguments .. */
16288 /* .. */
16289 /* .. Array Arguments .. */
16290 /* .. */
16291
16292 /* Purpose */
16293 /* ======= */
16294
16295 /* DTRTTF copies a triangular matrix A from standard full format (TR) */
16296 /* to rectangular full packed format (TF) . */
16297
16298 /* Arguments */
16299 /* ========= */
16300
16301 /* TRANSR (input) CHARACTER */
16302 /* = 'N': ARF in Normal form is wanted; */
16303 /* = 'T': ARF in Transpose form is wanted. */
16304
16305 /* UPLO (input) CHARACTER */
16306 /* = 'U': Upper triangle of A is stored; */
16307 /* = 'L': Lower triangle of A is stored. */
16308
16309 /* N (input) INTEGER */
16310 /* The order of the matrix A. N >= 0. */
16311
16312 /* A (input) DOUBLE PRECISION array, dimension (LDA,N). */
16313 /* On entry, the triangular matrix A. If UPLO = 'U', the */
16314 /* leading N-by-N upper triangular part of the array A contains */
16315 /* the upper triangular matrix, and the strictly lower */
16316 /* triangular part of A is not referenced. If UPLO = 'L', the */
16317 /* leading N-by-N lower triangular part of the array A contains */
16318 /* the lower triangular matrix, and the strictly upper */
16319 /* triangular part of A is not referenced. */
16320
16321 /* LDA (input) INTEGER */
16322 /* The leading dimension of the matrix A. LDA >= max(1,N). */
16323
16324 /* ARF (output) DOUBLE PRECISION array, dimension (NT). */
16325 /* NT=N*(N+1)/2. On exit, the triangular matrix A in RFP format. */
16326
16327 /* INFO (output) INTEGER */
16328 /* = 0: successful exit */
16329 /* < 0: if INFO = -i, the i-th argument had an illegal value */
16330
16331 /* Notes */
16332 /* ===== */
16333
16334 /* We first consider Rectangular Full Packed (RFP) Format when N is */
16335 /* even. We give an example where N = 6. */
16336
16337 /* AP is Upper AP is Lower */
16338
16339 /* 00 01 02 03 04 05 00 */
16340 /* 11 12 13 14 15 10 11 */
16341 /* 22 23 24 25 20 21 22 */
16342 /* 33 34 35 30 31 32 33 */
16343 /* 44 45 40 41 42 43 44 */
16344 /* 55 50 51 52 53 54 55 */
16345
16346
16347 /* Let TRANSR = 'N'. RFP holds AP as follows: */
16348 /* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
16349 /* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
16350 /* the transpose of the first three columns of AP upper. */
16351 /* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
16352 /* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
16353 /* the transpose of the last three columns of AP lower. */
16354 /* This covers the case N even and TRANSR = 'N'. */
16355
16356 /* RFP A RFP A */
16357
16358 /* 03 04 05 33 43 53 */
16359 /* 13 14 15 00 44 54 */
16360 /* 23 24 25 10 11 55 */
16361 /* 33 34 35 20 21 22 */
16362 /* 00 44 45 30 31 32 */
16363 /* 01 11 55 40 41 42 */
16364 /* 02 12 22 50 51 52 */
16365
16366 /* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
16367 /* transpose of RFP A above. One therefore gets: */
16368
16369
16370 /* RFP A RFP A */
16371
16372 /* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
16373 /* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
16374 /* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
16375
16376
16377 /* We first consider Rectangular Full Packed (RFP) Format when N is */
16378 /* odd. We give an example where N = 5. */
16379
16380 /* AP is Upper AP is Lower */
16381
16382 /* 00 01 02 03 04 00 */
16383 /* 11 12 13 14 10 11 */
16384 /* 22 23 24 20 21 22 */
16385 /* 33 34 30 31 32 33 */
16386 /* 44 40 41 42 43 44 */
16387
16388
16389 /* Let TRANSR = 'N'. RFP holds AP as follows: */
16390 /* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
16391 /* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
16392 /* the transpose of the first two columns of AP upper. */
16393 /* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
16394 /* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
16395 /* the transpose of the last two columns of AP lower. */
16396 /* This covers the case N odd and TRANSR = 'N'. */
16397
16398 /* RFP A RFP A */
16399
16400 /* 02 03 04 00 33 43 */
16401 /* 12 13 14 10 11 44 */
16402 /* 22 23 24 20 21 22 */
16403 /* 00 33 34 30 31 32 */
16404 /* 01 11 44 40 41 42 */
16405
16406 /* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
16407 /* transpose of RFP A above. One therefore gets: */
16408
16409 /* RFP A RFP A */
16410
16411 /* 02 12 22 00 01 00 10 20 30 40 50 */
16412 /* 03 13 23 33 11 33 11 21 31 41 51 */
16413 /* 04 14 24 34 44 43 44 22 32 42 52 */
16414
16415 /* Reference */
16416 /* ========= */
16417
16418 /* ===================================================================== */
16419
16420 /* .. */
16421 /* .. Local Scalars .. */
16422 /* .. */
16423 /* .. External Functions .. */
16424 /* .. */
16425 /* .. External Subroutines .. */
16426 /* .. */
16427 /* .. Intrinsic Functions .. */
16428 /* .. */
16429 /* .. Executable Statements .. */
16430
16431 /* Test the input parameters. */
16432
16433 /* Parameter adjustments */
16434 a_dim1 = *lda - 1 - 0 + 1;
16435 a_offset = 0 + a_dim1 * 0;
16436 a -= a_offset;
16437
16438 /* Function Body */
16439 *info = 0;
16440 normaltransr = lsame_(transr, "N");
16441 lower = lsame_(uplo, "L");
16442 if (! normaltransr && ! lsame_(transr, "T")) {
16443 *info = -1;
16444 } else if (! lower && ! lsame_(uplo, "U")) {
16445 *info = -2;
16446 } else if (*n < 0) {
16447 *info = -3;
16448 } else if (*lda < std::max(1_integer,*n)) {
16449 *info = -5;
16450 }
16451 if (*info != 0) {
16452 i__1 = -(*info);
16453 xerbla_("DTRTTF", &i__1);
16454 return 0;
16455 }
16456
16457 /* Quick return if possible */
16458
16459 if (*n <= 1) {
16460 if (*n == 1) {
16461 arf[0] = a[0];
16462 }
16463 return 0;
16464 }
16465
16466 /* Size of array ARF(0:nt-1) */
16467
16468 nt = *n * (*n + 1) / 2;
16469
16470 /* Set N1 and N2 depending on LOWER: for N even N1=N2=K */
16471
16472 if (lower) {
16473 n2 = *n / 2;
16474 n1 = *n - n2;
16475 } else {
16476 n1 = *n / 2;
16477 n2 = *n - n1;
16478 }
16479
16480 /* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. */
16481 /* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is */
16482 /* N--by--(N+1)/2. */
16483
16484 if (*n % 2 == 0) {
16485 k = *n / 2;
16486 nisodd = false;
16487 if (! lower) {
16488 np1x2 = *n + *n + 2;
16489 }
16490 } else {
16491 nisodd = true;
16492 if (! lower) {
16493 nx2 = *n + *n;
16494 }
16495 }
16496
16497 if (nisodd) {
16498
16499 /* N is odd */
16500
16501 if (normaltransr) {
16502
16503 /* N is odd and TRANSR = 'N' */
16504
16505 if (lower) {
16506
16507 /* N is odd, TRANSR = 'N', and UPLO = 'L' */
16508
16509 ij = 0;
16510 i__1 = n2;
16511 for (j = 0; j <= i__1; ++j) {
16512 i__2 = n2 + j;
16513 for (i__ = n1; i__ <= i__2; ++i__) {
16514 arf[ij] = a[n2 + j + i__ * a_dim1];
16515 ++ij;
16516 }
16517 i__2 = *n - 1;
16518 for (i__ = j; i__ <= i__2; ++i__) {
16519 arf[ij] = a[i__ + j * a_dim1];
16520 ++ij;
16521 }
16522 }
16523
16524 } else {
16525
16526 /* N is odd, TRANSR = 'N', and UPLO = 'U' */
16527
16528 ij = nt - *n;
16529 i__1 = n1;
16530 for (j = *n - 1; j >= i__1; --j) {
16531 i__2 = j;
16532 for (i__ = 0; i__ <= i__2; ++i__) {
16533 arf[ij] = a[i__ + j * a_dim1];
16534 ++ij;
16535 }
16536 i__2 = n1 - 1;
16537 for (l = j - n1; l <= i__2; ++l) {
16538 arf[ij] = a[j - n1 + l * a_dim1];
16539 ++ij;
16540 }
16541 ij -= nx2;
16542 }
16543
16544 }
16545
16546 } else {
16547
16548 /* N is odd and TRANSR = 'T' */
16549
16550 if (lower) {
16551
16552 /* N is odd, TRANSR = 'T', and UPLO = 'L' */
16553
16554 ij = 0;
16555 i__1 = n2 - 1;
16556 for (j = 0; j <= i__1; ++j) {
16557 i__2 = j;
16558 for (i__ = 0; i__ <= i__2; ++i__) {
16559 arf[ij] = a[j + i__ * a_dim1];
16560 ++ij;
16561 }
16562 i__2 = *n - 1;
16563 for (i__ = n1 + j; i__ <= i__2; ++i__) {
16564 arf[ij] = a[i__ + (n1 + j) * a_dim1];
16565 ++ij;
16566 }
16567 }
16568 i__1 = *n - 1;
16569 for (j = n2; j <= i__1; ++j) {
16570 i__2 = n1 - 1;
16571 for (i__ = 0; i__ <= i__2; ++i__) {
16572 arf[ij] = a[j + i__ * a_dim1];
16573 ++ij;
16574 }
16575 }
16576
16577 } else {
16578
16579 /* N is odd, TRANSR = 'T', and UPLO = 'U' */
16580
16581 ij = 0;
16582 i__1 = n1;
16583 for (j = 0; j <= i__1; ++j) {
16584 i__2 = *n - 1;
16585 for (i__ = n1; i__ <= i__2; ++i__) {
16586 arf[ij] = a[j + i__ * a_dim1];
16587 ++ij;
16588 }
16589 }
16590 i__1 = n1 - 1;
16591 for (j = 0; j <= i__1; ++j) {
16592 i__2 = j;
16593 for (i__ = 0; i__ <= i__2; ++i__) {
16594 arf[ij] = a[i__ + j * a_dim1];
16595 ++ij;
16596 }
16597 i__2 = *n - 1;
16598 for (l = n2 + j; l <= i__2; ++l) {
16599 arf[ij] = a[n2 + j + l * a_dim1];
16600 ++ij;
16601 }
16602 }
16603
16604 }
16605
16606 }
16607
16608 } else {
16609
16610 /* N is even */
16611
16612 if (normaltransr) {
16613
16614 /* N is even and TRANSR = 'N' */
16615
16616 if (lower) {
16617
16618 /* N is even, TRANSR = 'N', and UPLO = 'L' */
16619
16620 ij = 0;
16621 i__1 = k - 1;
16622 for (j = 0; j <= i__1; ++j) {
16623 i__2 = k + j;
16624 for (i__ = k; i__ <= i__2; ++i__) {
16625 arf[ij] = a[k + j + i__ * a_dim1];
16626 ++ij;
16627 }
16628 i__2 = *n - 1;
16629 for (i__ = j; i__ <= i__2; ++i__) {
16630 arf[ij] = a[i__ + j * a_dim1];
16631 ++ij;
16632 }
16633 }
16634
16635 } else {
16636
16637 /* N is even, TRANSR = 'N', and UPLO = 'U' */
16638
16639 ij = nt - *n - 1;
16640 i__1 = k;
16641 for (j = *n - 1; j >= i__1; --j) {
16642 i__2 = j;
16643 for (i__ = 0; i__ <= i__2; ++i__) {
16644 arf[ij] = a[i__ + j * a_dim1];
16645 ++ij;
16646 }
16647 i__2 = k - 1;
16648 for (l = j - k; l <= i__2; ++l) {
16649 arf[ij] = a[j - k + l * a_dim1];
16650 ++ij;
16651 }
16652 ij -= np1x2;
16653 }
16654
16655 }
16656
16657 } else {
16658
16659 /* N is even and TRANSR = 'T' */
16660
16661 if (lower) {
16662
16663 /* N is even, TRANSR = 'T', and UPLO = 'L' */
16664
16665 ij = 0;
16666 j = k;
16667 i__1 = *n - 1;
16668 for (i__ = k; i__ <= i__1; ++i__) {
16669 arf[ij] = a[i__ + j * a_dim1];
16670 ++ij;
16671 }
16672 i__1 = k - 2;
16673 for (j = 0; j <= i__1; ++j) {
16674 i__2 = j;
16675 for (i__ = 0; i__ <= i__2; ++i__) {
16676 arf[ij] = a[j + i__ * a_dim1];
16677 ++ij;
16678 }
16679 i__2 = *n - 1;
16680 for (i__ = k + 1 + j; i__ <= i__2; ++i__) {
16681 arf[ij] = a[i__ + (k + 1 + j) * a_dim1];
16682 ++ij;
16683 }
16684 }
16685 i__1 = *n - 1;
16686 for (j = k - 1; j <= i__1; ++j) {
16687 i__2 = k - 1;
16688 for (i__ = 0; i__ <= i__2; ++i__) {
16689 arf[ij] = a[j + i__ * a_dim1];
16690 ++ij;
16691 }
16692 }
16693
16694 } else {
16695
16696 /* N is even, TRANSR = 'T', and UPLO = 'U' */
16697
16698 ij = 0;
16699 i__1 = k;
16700 for (j = 0; j <= i__1; ++j) {
16701 i__2 = *n - 1;
16702 for (i__ = k; i__ <= i__2; ++i__) {
16703 arf[ij] = a[j + i__ * a_dim1];
16704 ++ij;
16705 }
16706 }
16707 i__1 = k - 2;
16708 for (j = 0; j <= i__1; ++j) {
16709 i__2 = j;
16710 for (i__ = 0; i__ <= i__2; ++i__) {
16711 arf[ij] = a[i__ + j * a_dim1];
16712 ++ij;
16713 }
16714 i__2 = *n - 1;
16715 for (l = k + 1 + j; l <= i__2; ++l) {
16716 arf[ij] = a[k + 1 + j + l * a_dim1];
16717 ++ij;
16718 }
16719 }
16720 /* Note that here, on exit of the loop, J = K-1 */
16721 i__1 = j;
16722 for (i__ = 0; i__ <= i__1; ++i__) {
16723 arf[ij] = a[i__ + j * a_dim1];
16724 ++ij;
16725 }
16726
16727 }
16728
16729 }
16730
16731 }
16732
16733 return 0;
16734
16735 /* End of DTRTTF */
16736
16737 } /* dtrttf_ */
16738
dtrttp_(const char * uplo,integer * n,double * a,integer * lda,double * ap,integer * info)16739 int dtrttp_(const char *uplo, integer *n, double *a, integer *lda, double *ap, integer *info)
16740 {
16741 /* System generated locals */
16742 integer a_dim1, a_offset, i__1, i__2;
16743
16744 /* Local variables */
16745 integer i__, j, k;
16746 bool lower;
16747
16748
16749 /* -- LAPACK routine (version 3.2) -- */
16750 /* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
16751 /* -- and Julien Langou of the Univ. of Colorado Denver -- */
16752 /* -- November 2008 -- */
16753
16754 /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
16755 /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
16756
16757 /* .. Scalar Arguments .. */
16758 /* .. */
16759 /* .. Array Arguments .. */
16760 /* .. */
16761
16762 /* Purpose */
16763 /* ======= */
16764
16765 /* DTRTTP copies a triangular matrix A from full format (TR) to standard */
16766 /* packed format (TP). */
16767
16768 /* Arguments */
16769 /* ========= */
16770
16771 /* UPLO (input) CHARACTER */
16772 /* = 'U': A is upper triangular. */
16773 /* = 'L': A is lower triangular. */
16774
16775 /* N (input) INTEGER */
16776 /* The order of the matrices AP and A. N >= 0. */
16777
16778 /* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
16779 /* On exit, the triangular matrix A. If UPLO = 'U', the leading */
16780 /* N-by-N upper triangular part of A contains the upper */
16781 /* triangular part of the matrix A, and the strictly lower */
16782 /* triangular part of A is not referenced. If UPLO = 'L', the */
16783 /* leading N-by-N lower triangular part of A contains the lower */
16784 /* triangular part of the matrix A, and the strictly upper */
16785 /* triangular part of A is not referenced. */
16786
16787 /* LDA (input) INTEGER */
16788 /* The leading dimension of the array A. LDA >= max(1,N). */
16789
16790 /* AP (output) DOUBLE PRECISION array, dimension (N*(N+1)/2 */
16791 /* On exit, the upper or lower triangular matrix A, packed */
16792 /* columnwise in a linear array. The j-th column of A is stored */
16793 /* in the array AP as follows: */
16794 /* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
16795 /* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
16796
16797 /* INFO (output) INTEGER */
16798 /* = 0: successful exit */
16799 /* < 0: if INFO = -i, the i-th argument had an illegal value */
16800
16801 /* ===================================================================== */
16802
16803 /* .. Parameters .. */
16804 /* .. */
16805 /* .. Local Scalars .. */
16806 /* .. */
16807 /* .. External Functions .. */
16808 /* .. */
16809 /* .. External Subroutines .. */
16810 /* .. */
16811 /* .. Executable Statements .. */
16812
16813 /* Test the input parameters. */
16814
16815 /* Parameter adjustments */
16816 a_dim1 = *lda;
16817 a_offset = 1 + a_dim1;
16818 a -= a_offset;
16819 --ap;
16820
16821 /* Function Body */
16822 *info = 0;
16823 lower = lsame_(uplo, "L");
16824 if (! lower && ! lsame_(uplo, "U")) {
16825 *info = -1;
16826 } else if (*n < 0) {
16827 *info = -2;
16828 } else if (*lda < std::max(1_integer,*n)) {
16829 *info = -4;
16830 }
16831 if (*info != 0) {
16832 i__1 = -(*info);
16833 xerbla_("DTRTTP", &i__1);
16834 return 0;
16835 }
16836
16837 if (lower) {
16838 k = 0;
16839 i__1 = *n;
16840 for (j = 1; j <= i__1; ++j) {
16841 i__2 = *n;
16842 for (i__ = j; i__ <= i__2; ++i__) {
16843 ++k;
16844 ap[k] = a[i__ + j * a_dim1];
16845 }
16846 }
16847 } else {
16848 k = 0;
16849 i__1 = *n;
16850 for (j = 1; j <= i__1; ++j) {
16851 i__2 = j;
16852 for (i__ = 1; i__ <= i__2; ++i__) {
16853 ++k;
16854 ap[k] = a[i__ + j * a_dim1];
16855 }
16856 }
16857 }
16858
16859
16860 return 0;
16861
16862 /* End of DTRTTP */
16863
16864 } /* dtrttp_ */
16865
dtzrqf_(integer * m,integer * n,double * a,integer * lda,double * tau,integer * info)16866 /* Subroutine */ int dtzrqf_(integer *m, integer *n, double *a, integer *lda, double *tau, integer *info)
16867 {
16868 /* Table of constant values */
16869 static integer c__1 = 1;
16870 static double c_b8 = 1.;
16871
16872 /* System generated locals */
16873 integer a_dim1, a_offset, i__1, i__2;
16874 double d__1;
16875
16876 /* Local variables */
16877 integer i__, k, m1;
16878
16879 /* -- LAPACK routine (version 3.2) -- */
16880 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
16881 /* November 2006 */
16882
16883 /* .. Scalar Arguments .. */
16884 /* .. */
16885 /* .. Array Arguments .. */
16886 /* .. */
16887
16888 /* Purpose */
16889 /* ======= */
16890
16891 /* This routine is deprecated and has been replaced by routine DTZRZF. */
16892
16893 /* DTZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A */
16894 /* to upper triangular form by means of orthogonal transformations. */
16895
16896 /* The upper trapezoidal matrix A is factored as */
16897
16898 /* A = ( R 0 ) * Z, */
16899
16900 /* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper */
16901 /* triangular matrix. */
16902
16903 /* Arguments */
16904 /* ========= */
16905
16906 /* M (input) INTEGER */
16907 /* The number of rows of the matrix A. M >= 0. */
16908
16909 /* N (input) INTEGER */
16910 /* The number of columns of the matrix A. N >= M. */
16911
16912 /* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
16913 /* On entry, the leading M-by-N upper trapezoidal part of the */
16914 /* array A must contain the matrix to be factorized. */
16915 /* On exit, the leading M-by-M upper triangular part of A */
16916 /* contains the upper triangular matrix R, and elements M+1 to */
16917 /* N of the first M rows of A, with the array TAU, represent the */
16918 /* orthogonal matrix Z as a product of M elementary reflectors. */
16919
16920 /* LDA (input) INTEGER */
16921 /* The leading dimension of the array A. LDA >= max(1,M). */
16922
16923 /* TAU (output) DOUBLE PRECISION array, dimension (M) */
16924 /* The scalar factors of the elementary reflectors. */
16925
16926 /* INFO (output) INTEGER */
16927 /* = 0: successful exit */
16928 /* < 0: if INFO = -i, the i-th argument had an illegal value */
16929
16930 /* Further Details */
16931 /* =============== */
16932
16933 /* The factorization is obtained by Householder's method. The kth */
16934 /* transformation matrix, Z( k ), which is used to introduce zeros into */
16935 /* the ( m - k + 1 )th row of A, is given in the form */
16936
16937 /* Z( k ) = ( I 0 ), */
16938 /* ( 0 T( k ) ) */
16939
16940 /* where */
16941
16942 /* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), */
16943 /* ( 0 ) */
16944 /* ( z( k ) ) */
16945
16946 /* tau is a scalar and z( k ) is an ( n - m ) element vector. */
16947 /* tau and z( k ) are chosen to annihilate the elements of the kth row */
16948 /* of X. */
16949
16950 /* The scalar tau is returned in the kth element of TAU and the vector */
16951 /* u( k ) in the kth row of A, such that the elements of z( k ) are */
16952 /* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in */
16953 /* the upper triangular part of A. */
16954
16955 /* Z is given by */
16956
16957 /* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */
16958
16959 /* ===================================================================== */
16960
16961 /* .. Parameters .. */
16962 /* .. */
16963 /* .. Local Scalars .. */
16964 /* .. */
16965 /* .. Intrinsic Functions .. */
16966 /* .. */
16967 /* .. External Subroutines .. */
16968 /* .. */
16969 /* .. Executable Statements .. */
16970
16971 /* Test the input parameters. */
16972
16973 /* Parameter adjustments */
16974 a_dim1 = *lda;
16975 a_offset = 1 + a_dim1;
16976 a -= a_offset;
16977 --tau;
16978
16979 /* Function Body */
16980 *info = 0;
16981 if (*m < 0) {
16982 *info = -1;
16983 } else if (*n < *m) {
16984 *info = -2;
16985 } else if (*lda < std::max(1_integer,*m)) {
16986 *info = -4;
16987 }
16988 if (*info != 0) {
16989 i__1 = -(*info);
16990 xerbla_("DTZRQF", &i__1);
16991 return 0;
16992 }
16993
16994 /* Perform the factorization. */
16995
16996 if (*m == 0) {
16997 return 0;
16998 }
16999 if (*m == *n) {
17000 i__1 = *n;
17001 for (i__ = 1; i__ <= i__1; ++i__) {
17002 tau[i__] = 0.;
17003 /* L10: */
17004 }
17005 } else {
17006 /* Computing MIN */
17007 i__1 = *m + 1;
17008 m1 = std::min(i__1,*n);
17009 for (k = *m; k >= 1; --k) {
17010
17011 /* Use a Householder reflection to zero the kth row of A. */
17012 /* First set up the reflection. */
17013
17014 i__1 = *n - *m + 1;
17015 dlarfp_(&i__1, &a[k + k * a_dim1], &a[k + m1 * a_dim1], lda, &tau[
17016 k]);
17017
17018 if (tau[k] != 0. && k > 1) {
17019
17020 /* We now perform the operation A := A*P( k ). */
17021
17022 /* Use the first ( k - 1 ) elements of TAU to store a( k ), */
17023 /* where a( k ) consists of the first ( k - 1 ) elements of */
17024 /* the kth column of A. Also let B denote the first */
17025 /* ( k - 1 ) rows of the last ( n - m ) columns of A. */
17026
17027 i__1 = k - 1;
17028 dcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &tau[1], &c__1);
17029
17030 /* Form w = a( k ) + B*z( k ) in TAU. */
17031
17032 i__1 = k - 1;
17033 i__2 = *n - *m;
17034 dgemv_("No transpose", &i__1, &i__2, &c_b8, &a[m1 * a_dim1 +
17035 1], lda, &a[k + m1 * a_dim1], lda, &c_b8, &tau[1], &
17036 c__1);
17037
17038 /* Now form a( k ) := a( k ) - tau*w */
17039 /* and B := B - tau*w*z( k )'. */
17040
17041 i__1 = k - 1;
17042 d__1 = -tau[k];
17043 daxpy_(&i__1, &d__1, &tau[1], &c__1, &a[k * a_dim1 + 1], &
17044 c__1);
17045 i__1 = k - 1;
17046 i__2 = *n - *m;
17047 d__1 = -tau[k];
17048 dger_(&i__1, &i__2, &d__1, &tau[1], &c__1, &a[k + m1 * a_dim1]
17049 , lda, &a[m1 * a_dim1 + 1], lda);
17050 }
17051 /* L20: */
17052 }
17053 }
17054
17055 return 0;
17056
17057 /* End of DTZRQF */
17058
17059 } /* dtzrqf_ */
17060
dtzrzf_(integer * m,integer * n,double * a,integer * lda,double * tau,double * work,integer * lwork,integer * info)17061 /* Subroutine */ int dtzrzf_(integer *m, integer *n, double *a, integer *
17062 lda, double *tau, double *work, integer *lwork, integer *info)
17063 {
17064 /* Table of constant values */
17065 static integer c__1 = 1;
17066 static integer c_n1 = -1;
17067 static integer c__3 = 3;
17068 static integer c__2 = 2;
17069
17070 /* System generated locals */
17071 integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
17072
17073 /* Local variables */
17074 integer i__, m1, ib, nb, ki, kk, mu, nx, iws, nbmin;
17075 integer ldwork, lwkopt;
17076 bool lquery;
17077
17078
17079 /* -- LAPACK routine (version 3.1) -- */
17080 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
17081 /* November 2006 */
17082
17083 /* .. Scalar Arguments .. */
17084 /* .. */
17085 /* .. Array Arguments .. */
17086 /* .. */
17087
17088 /* Purpose */
17089 /* ======= */
17090
17091 /* DTZRZF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A */
17092 /* to upper triangular form by means of orthogonal transformations. */
17093
17094 /* The upper trapezoidal matrix A is factored as */
17095
17096 /* A = ( R 0 ) * Z, */
17097
17098 /* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper */
17099 /* triangular matrix. */
17100
17101 /* Arguments */
17102 /* ========= */
17103
17104 /* M (input) INTEGER */
17105 /* The number of rows of the matrix A. M >= 0. */
17106
17107 /* N (input) INTEGER */
17108 /* The number of columns of the matrix A. N >= M. */
17109
17110 /* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
17111 /* On entry, the leading M-by-N upper trapezoidal part of the */
17112 /* array A must contain the matrix to be factorized. */
17113 /* On exit, the leading M-by-M upper triangular part of A */
17114 /* contains the upper triangular matrix R, and elements M+1 to */
17115 /* N of the first M rows of A, with the array TAU, represent the */
17116 /* orthogonal matrix Z as a product of M elementary reflectors. */
17117
17118 /* LDA (input) INTEGER */
17119 /* The leading dimension of the array A. LDA >= max(1_integer,M). */
17120
17121 /* TAU (output) DOUBLE PRECISION array, dimension (M) */
17122 /* The scalar factors of the elementary reflectors. */
17123
17124 /* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
17125 /* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
17126
17127 /* LWORK (input) INTEGER */
17128 /* The dimension of the array WORK. LWORK >= max(1_integer,M). */
17129 /* For optimum performance LWORK >= M*NB, where NB is */
17130 /* the optimal blocksize. */
17131
17132 /* If LWORK = -1, then a workspace query is assumed; the routine */
17133 /* only calculates the optimal size of the WORK array, returns */
17134 /* this value as the first entry of the WORK array, and no error */
17135 /* message related to LWORK is issued by XERBLA. */
17136
17137 /* INFO (output) INTEGER */
17138 /* = 0: successful exit */
17139 /* < 0: if INFO = -i, the i-th argument had an illegal value */
17140
17141 /* Further Details */
17142 /* =============== */
17143
17144 /* Based on contributions by */
17145 /* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
17146
17147 /* The factorization is obtained by Householder's method. The kth */
17148 /* transformation matrix, Z( k ), which is used to introduce zeros into */
17149 /* the ( m - k + 1 )th row of A, is given in the form */
17150
17151 /* Z( k ) = ( I 0 ), */
17152 /* ( 0 T( k ) ) */
17153
17154 /* where */
17155
17156 /* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), */
17157 /* ( 0 ) */
17158 /* ( z( k ) ) */
17159
17160 /* tau is a scalar and z( k ) is an ( n - m ) element vector. */
17161 /* tau and z( k ) are chosen to annihilate the elements of the kth row */
17162 /* of X. */
17163
17164 /* The scalar tau is returned in the kth element of TAU and the vector */
17165 /* u( k ) in the kth row of A, such that the elements of z( k ) are */
17166 /* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in */
17167 /* the upper triangular part of A. */
17168
17169 /* Z is given by */
17170
17171 /* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */
17172
17173 /* ===================================================================== */
17174
17175 /* .. Parameters .. */
17176 /* .. */
17177 /* .. Local Scalars .. */
17178 /* .. */
17179 /* .. External Subroutines .. */
17180 /* .. */
17181 /* .. Intrinsic Functions .. */
17182 /* .. */
17183 /* .. External Functions .. */
17184 /* .. */
17185 /* .. Executable Statements .. */
17186
17187 /* Test the input arguments */
17188
17189 /* Parameter adjustments */
17190 a_dim1 = *lda;
17191 a_offset = 1 + a_dim1;
17192 a -= a_offset;
17193 --tau;
17194 --work;
17195
17196 /* Function Body */
17197 *info = 0;
17198 lquery = *lwork == -1;
17199 if (*m < 0) {
17200 *info = -1;
17201 } else if (*n < *m) {
17202 *info = -2;
17203 } else if (*lda < std::max(1_integer,*m)) {
17204 *info = -4;
17205 }
17206
17207 if (*info == 0) {
17208 if (*m == 0 || *m == *n) {
17209 lwkopt = 1;
17210 } else {
17211
17212 /* Determine the block size. */
17213
17214 nb = ilaenv_(&c__1, "DGERQF", " ", m, n, &c_n1, &c_n1);
17215 lwkopt = *m * nb;
17216 }
17217 work[1] = (double) lwkopt;
17218
17219 if (*lwork < std::max(1_integer,*m) && ! lquery) {
17220 *info = -7;
17221 }
17222 }
17223
17224 if (*info != 0) {
17225 i__1 = -(*info);
17226 xerbla_("DTZRZF", &i__1);
17227 return 0;
17228 } else if (lquery) {
17229 return 0;
17230 }
17231
17232 /* Quick return if possible */
17233
17234 if (*m == 0) {
17235 return 0;
17236 } else if (*m == *n) {
17237 i__1 = *n;
17238 for (i__ = 1; i__ <= i__1; ++i__) {
17239 tau[i__] = 0.;
17240 /* L10: */
17241 }
17242 return 0;
17243 }
17244
17245 nbmin = 2;
17246 nx = 1;
17247 iws = *m;
17248 if (nb > 1 && nb < *m) {
17249
17250 /* Determine when to cross over from blocked to unblocked code. */
17251
17252 /* Computing MAX */
17253 i__1 = 0, i__2 = ilaenv_(&c__3, "DGERQF", " ", m, n, &c_n1, &c_n1);
17254 nx = std::max(i__1,i__2);
17255 if (nx < *m) {
17256
17257 /* Determine if workspace is large enough for blocked code. */
17258
17259 ldwork = *m;
17260 iws = ldwork * nb;
17261 if (*lwork < iws) {
17262
17263 /* Not enough workspace to use optimal NB: reduce NB and */
17264 /* determine the minimum value of NB. */
17265
17266 nb = *lwork / ldwork;
17267 /* Computing MAX */
17268 i__1 = 2, i__2 = ilaenv_(&c__2, "DGERQF", " ", m, n, &c_n1, &
17269 c_n1);
17270 nbmin = std::max(i__1,i__2);
17271 }
17272 }
17273 }
17274
17275 if (nb >= nbmin && nb < *m && nx < *m) {
17276
17277 /* Use blocked code initially. */
17278 /* The last kk rows are handled by the block method. */
17279
17280 /* Computing MIN */
17281 i__1 = *m + 1;
17282 m1 = std::min(i__1,*n);
17283 ki = (*m - nx - 1) / nb * nb;
17284 /* Computing MIN */
17285 i__1 = *m, i__2 = ki + nb;
17286 kk = std::min(i__1,i__2);
17287
17288 i__1 = *m - kk + 1;
17289 i__2 = -nb;
17290 for (i__ = *m - kk + ki + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1;
17291 i__ += i__2) {
17292 /* Computing MIN */
17293 i__3 = *m - i__ + 1;
17294 ib = std::min(i__3,nb);
17295
17296 /* Compute the TZ factorization of the current block */
17297 /* A(i:i+ib-1,i:n) */
17298
17299 i__3 = *n - i__ + 1;
17300 i__4 = *n - *m;
17301 dlatrz_(&ib, &i__3, &i__4, &a[i__ + i__ * a_dim1], lda, &tau[i__],
17302 &work[1]);
17303 if (i__ > 1) {
17304
17305 /* Form the triangular factor of the block reflector */
17306 /* H = H(i+ib-1) . . . H(i+1) H(i) */
17307
17308 i__3 = *n - *m;
17309 dlarzt_("Backward", "Rowwise", &i__3, &ib, &a[i__ + m1 *
17310 a_dim1], lda, &tau[i__], &work[1], &ldwork);
17311
17312 /* Apply H to A(1:i-1,i:n) from the right */
17313
17314 i__3 = i__ - 1;
17315 i__4 = *n - i__ + 1;
17316 i__5 = *n - *m;
17317 dlarzb_("Right", "No transpose", "Backward", "Rowwise", &i__3,
17318 &i__4, &ib, &i__5, &a[i__ + m1 * a_dim1], lda, &work[
17319 1], &ldwork, &a[i__ * a_dim1 + 1], lda, &work[ib + 1],
17320 &ldwork)
17321 ;
17322 }
17323 /* L20: */
17324 }
17325 mu = i__ + nb - 1;
17326 } else {
17327 mu = *m;
17328 }
17329
17330 /* Use unblocked code to factor the last or only block */
17331
17332 if (mu > 0) {
17333 i__2 = *n - *m;
17334 dlatrz_(&mu, n, &i__2, &a[a_offset], lda, &tau[1], &work[1]);
17335 }
17336
17337 work[1] = (double) lwkopt;
17338
17339 return 0;
17340
17341 /* End of DTZRZF */
17342
17343 } /* dtzrzf_ */
17344