38 int *pdim =
DIM(obj), n = pdim[1];
40 Rf_error(
_(
"matrix is not square"));
41 int cs =
class[1] ==
's' &&
class[0] ==
'z' &&
TRANS(obj) !=
'C';
42 char cl[] =
"...Matrix";
43 cl[0] = (
class[0] ==
'z') ?
'z' :
'd';
44 cl[1] = (
class[1] ==
'g' || cs) ?
'g' : (
class[1] ==
's') ?
'p' :
't';
45 cl[2] = (
class[1] ==
'g' || cs) ?
'e' : (
class[1] ==
's') ?
'o' :
'r';
50 if (
cl[1] !=
'g' &&
UPLO(obj) !=
'U')
55 PROTECT_WITH_INDEX(obj, &pid);
56 if (
class[0] !=
'z' &&
class[0] !=
'd') {
61 if (
class[1] !=
's' || cs) {
68 x1 = PROTECT(Rf_allocVector(
TYPEOF(x0), XLENGTH(x0)));
69 size_t n1 = (size_t) n, nn = n1 * n1, dk = n1 + 1, k;
70 int *pivot = (
int *) R_alloc(n1,
sizeof(
int)),
71 i, j, l, s, ilo, ihi, info;
72 double *scale = (
double *) R_alloc(n1,
sizeof(
double)),
75 if (
TYPEOF(x0) == CPLXSXP) {
77 Rcomplex *a = COMPLEX(x0), *x = COMPLEX(x1), *work, *tmp,
79 memcpy(x, a,
sizeof(Rcomplex) * nn);
82 for (j = 0; j < n; ++j) {
87 trace.r /= (double) n;
88 trace.i /= (double) n;
90 for (j = 0; j < n; ++j) {
96 F77_CALL(zgebal)(
"B", &n, x, &n, &ilo, &ihi, scale, &info
FCONE);
100 norm = F77_CALL(zlange)(
"O", &n, &n, x, &n, (
double *) 0
FCONE);
102 Rf_error(
"matrix one-norm is not finite");
103 s = (norm <=
thetam[4]) ? 0 : (int) ceil(log2(norm /
thetam[4]));
105 double e = ldexp(1.0, -s);
106 for (k = 0; k < nn; ++k) {
112 for (l = 0; l < 4; ++l)
116 work = (Rcomplex *) R_alloc(nn * 2,
sizeof(Rcomplex));
117 Rcomplex *u = work, *v = u + nn;
118 memset(u, 0,
sizeof(Rcomplex) * nn * 2);
120 for (j = 0; j < n; ++j) {
128 work = (Rcomplex *) R_alloc((l > 0) ? nn * 3 : nn,
sizeof(Rcomplex));
129 Rcomplex *a2 = work, *a2m = work + nn, *a2m2 = a2m + nn;
130 F77_CALL(zgemm)(
"N",
"N", &n, &n, &n, &unit, x, &n,
132 for (k = 0; k < nn; ++k) {
133 u[k].r += b[1] * a2[k].r;
134 u[k].i += b[1] * a2[k].i;
135 v[k].r += b[0] * a2[k].r;
136 v[k].i += b[0] * a2[k].i;
140 memcpy(a2m, a2,
sizeof(
double) * nn);
141 for (i = 0; i < l; ++i) {
142 F77_CALL(zgemm)(
"N",
"N", &n, &n, &n, &unit, a2, &n,
144 for (k = 0; k < nn; ++k) {
145 u[k].r += b[1] * a2m2[k].r;
146 u[k].i += b[1] * a2m2[k].i;
147 v[k].r += b[0] * a2m2[k].r;
148 v[k].i += b[0] * a2m2[k].i;
151 tmp = a2m2; a2m2 = a2m; a2m = tmp;
154 F77_CALL(zgemm)(
"N",
"N", &n, &n, &n, &unit, x, &n,
156 memcpy(u, a2,
sizeof(Rcomplex) * nn);
159 work = (Rcomplex *) R_alloc(nn * 5,
sizeof(Rcomplex));
160 Rcomplex *a2 = work, *a4 = a2 + nn, *a6 = a4 + nn,
161 *upart = a6 + nn, *vpart = upart + nn;
162 F77_CALL(zgemm)(
"N",
"N", &n, &n, &n, &unit, x , &n,
164 F77_CALL(zgemm)(
"N",
"N", &n, &n, &n, &unit, a2, &n,
166 F77_CALL(zgemm)(
"N",
"N", &n, &n, &n, &unit, a2, &n,
168 for (k = 0; k < nn; ++k) {
169 u[k].r += b[3] * a2[k].r + b[5] * a4[k].r + b[7] * a6[k].r;
170 u[k].i += b[3] * a2[k].i + b[5] * a4[k].i + b[7] * a6[k].i;
171 v[k].r += b[2] * a2[k].r + b[4] * a4[k].r + b[6] * a6[k].r;
172 v[k].i += b[2] * a2[k].i + b[4] * a4[k].i + b[6] * a6[k].i;
173 upart[k].r = b[9] * a2[k].r + b[11] * a4[k].r + b[13] * a6[k].r;
174 upart[k].i = b[9] * a2[k].i + b[11] * a4[k].i + b[13] * a6[k].i;
175 vpart[k].r = b[8] * a2[k].r + b[10] * a4[k].r + b[12] * a6[k].r;
176 vpart[k].i = b[8] * a2[k].i + b[10] * a4[k].i + b[12] * a6[k].i;
178 F77_CALL(zgemm)(
"N",
"N", &n, &n, &n, &unit, a6, &n,
180 F77_CALL(zgemm)(
"N",
"N", &n, &n, &n, &unit, a6, &n,
182 F77_CALL(zgemm)(
"N",
"N", &n, &n, &n, &unit, x, &n,
184 memcpy(u, a2,
sizeof(Rcomplex) * nn);
186 for (k = 0; k < nn; ++k) {
187 x[k].r = u[k].r + v[k].r;
188 x[k].i = u[k].i + v[k].i;
189 u[k].r = -u[k].r + v[k].r;
190 u[k].i = -u[k].i + v[k].i;
192 F77_CALL(zgetrf)(&n, &n, u, &n, pivot, &info);
194 F77_CALL(zgetrs)(
"N", &n, &n, u, &n, pivot, x, &n, &info
FCONE);
199 for (i = 0; i < s; ++i) {
200 F77_CALL(zgemm)(
"N",
"N", &n, &n, &n, &unit, u, &n,
202 tmp = v; v = u; u = tmp;
205 memcpy(x, u,
sizeof(Rcomplex) * nn);
209 for (j = 0; j < n; ++j) {
210 for (i = ilo; i <= ihi; ++i) {
211 tmp[i].r *= scale[i];
212 tmp[i].i *= scale[i];
216 tmp = x + n1 * (size_t) ilo;
217 for (j = ilo; j <= ihi; ++j) {
218 for (i = 0; i < n; ++i) {
219 tmp[i].r /= scale[j];
220 tmp[i].i /= scale[j];
224 for (j = ilo - 1; j >= 0; --j) {
225 i = (int) scale[j] - 1;
227 zswap2(n1, x + n1 * (
size_t) i, 1, x + n1 * (
size_t) j, 1);
228 zswap2(n1, x + i, n1, x + j, n1);
231 for (j = ihi + 1; j < n; ++j) {
232 i = (int) scale[j] - 1;
234 zswap2(n1, x + n1 * (
size_t) i, 1, x + n1 * (
size_t) j, 1);
235 zswap2(n1, x + i, n1, x + j, n1);
239#define asC(x) ((double _Complex *) &(x))[0]
240#define asR(x) (( Rcomplex *) &(x))[0]
242 double _Complex z = cexp(
asC(trace));
244 for (k = 0; k < nn; ++k) {
246 x[k].r = x___.r * trace.r - x___.i * trace.i;
247 x[k].i = x___.r * trace.i + x___.i * trace.r;
252 double *a = REAL(x0), *x = REAL(x1), *work, *tmp,
253 zero = 0.0, unit = 1.0, trace = zero;
254 memcpy(x, a,
sizeof(
double) * nn);
257 for (j = 0; j < n; ++j) {
263 for (j = 0; j < n; ++j) {
268 F77_CALL(dgebal)(
"B", &n, x, &n, &ilo, &ihi, scale, &info
FCONE);
272 norm = F77_CALL(dlange)(
"O", &n, &n, x, &n, (
double *) 0
FCONE);
274 Rf_error(
"matrix one-norm is not finite");
275 s = (norm <=
thetam[4]) ? 0 : (int) ceil(log2(norm /
thetam[4]));
277 double e = ldexp(1.0, -s);
278 for (k = 0; k < nn; ++k)
282 for (l = 0; l < 4; ++l)
286 work = (
double *) R_alloc(nn * 2,
sizeof(
double));
287 double *u = work, *v = u + nn;
288 memset(u, 0,
sizeof(
double) * nn * 2);
290 for (j = 0; j < n; ++j) {
298 work = (
double *) R_alloc((l > 0) ? nn * 3 : nn,
sizeof(
double));
299 double *a2 = work, *a2m = work + nn, *a2m2 = a2m + nn;
300 F77_CALL(dgemm)(
"N",
"N", &n, &n, &n, &unit, x, &n,
302 for (k = 0; k < nn; ++k) {
303 u[k] += b[1] * a2[k];
304 v[k] += b[0] * a2[k];
308 memcpy(a2m, a2,
sizeof(
double) * nn);
309 for (i = 0; i < l; ++i) {
310 F77_CALL(dgemm)(
"N",
"N", &n, &n, &n, &unit, a2, &n,
312 for (k = 0; k < nn; ++k) {
313 u[k] += b[1] * a2m2[k];
314 v[k] += b[0] * a2m2[k];
317 tmp = a2m2; a2m2 = a2m; a2m = tmp;
320 F77_CALL(dgemm)(
"N",
"N", &n, &n, &n, &unit, x, &n,
322 memcpy(u, a2,
sizeof(
double) * nn);
325 work = (
double *) R_alloc(nn * 5,
sizeof(
double));
326 double *a2 = work, *a4 = a2 + nn, *a6 = a4 + nn,
327 *upart = a6 + nn, *vpart = upart + nn;
328 F77_CALL(dgemm)(
"N",
"N", &n, &n, &n, &unit, x , &n,
330 F77_CALL(dgemm)(
"N",
"N", &n, &n, &n, &unit, a2, &n,
332 F77_CALL(dgemm)(
"N",
"N", &n, &n, &n, &unit, a2, &n,
334 for (k = 0; k < nn; ++k) {
335 u[k] += b[3] * a2[k] + b[5] * a4[k] + b[7] * a6[k];
336 v[k] += b[2] * a2[k] + b[4] * a4[k] + b[6] * a6[k];
337 upart[k] = b[9] * a2[k] + b[11] * a4[k] + b[13] * a6[k];
338 vpart[k] = b[8] * a2[k] + b[10] * a4[k] + b[12] * a6[k];
340 F77_CALL(dgemm)(
"N",
"N", &n, &n, &n, &unit, a6, &n,
342 F77_CALL(dgemm)(
"N",
"N", &n, &n, &n, &unit, a6, &n,
344 F77_CALL(dgemm)(
"N",
"N", &n, &n, &n, &unit, x, &n,
346 memcpy(u, a2,
sizeof(
double) * nn);
348 for (k = 0; k < nn; ++k) {
352 F77_CALL(dgetrf)(&n, &n, u, &n, pivot, &info);
354 F77_CALL(dgetrs)(
"N", &n, &n, u, &n, pivot, x, &n, &info
FCONE);
359 for (i = 0; i < s; ++i) {
360 F77_CALL(dgemm)(
"N",
"N", &n, &n, &n, &unit, u, &n,
362 tmp = v; v = u; u = tmp;
365 memcpy(x, u,
sizeof(
double) * nn);
369 for (j = 0; j < n; ++j) {
370 for (i = ilo; i <= ihi; ++i)
374 tmp = x + n1 * (size_t) ilo;
375 for (j = ilo; j <= ihi; ++j) {
376 for (i = 0; i < n; ++i)
380 for (j = ilo - 1; j >= 0; --j) {
381 i = (int) scale[j] - 1;
383 dswap2(n1, x + n1 * (
size_t) i, 1, x + n1 * (
size_t) j, 1);
384 dswap2(n1, x + i, n1, x + j, n1);
387 for (j = ihi + 1; j < n; ++j) {
388 i = (int) scale[j] - 1;
390 dswap2(n1, x + n1 * (
size_t) i, 1, x + n1 * (
size_t) j, 1);
391 dswap2(n1, x + i, n1, x + j, n1);
396 for (k = 0; k < nn; ++k)
408 REPROTECT(obj =
dense_schur(obj,
class, 2, 1), pid);
411 x1 = PROTECT(Rf_allocVector(
TYPEOF(vectors), XLENGTH(vectors)));
412 double *w = REAL(values);
413 size_t n1 = (size_t) n, nn = n1 * n1;
415 for (j = 0; j < n; ++j)
417 if (
TYPEOF(vectors) == CPLXSXP) {
418 Rcomplex *qw = (Rcomplex *) R_alloc(nn,
sizeof(Rcomplex)),
419 *q = COMPLEX(vectors), *x = COMPLEX(x1), *tmp = qw,
421 for (j = 0; j < n; ++j) {
422 for (i = 0; i < n; ++i) {
423 qw[i].r = q[i].r * w[j];
424 qw[i].i = q[i].i * w[j];
429 qw = tmp; q = COMPLEX(vectors);
430 F77_CALL(zgemm)(
"N",
"C", &n, &n, &n, &unit, qw, &n,
433 double *qw = (
double *) R_alloc(nn,
sizeof(
double)),
434 *q = REAL(vectors), *x = REAL(x1), *tmp = qw,
435 zero = 0.0, unit = 1.0;
436 for (j = 0; j < n; ++j) {
437 for (i = 0; i < n; ++i)
442 qw = tmp; q = REAL(vectors);
443 F77_CALL(dgemm)(
"N",
"C", &n, &n, &n, &unit, qw, &n,
456 if (
cl[1] !=
'g' &&
class[2] ==
'p') {