Line data Source code
1 : /* Copyright (C) 2000 The PARI group.
2 :
3 : This file is part of the PARI/GP package.
4 :
5 : PARI/GP is free software; you can redistribute it and/or modify it under the
6 : terms of the GNU General Public License as published by the Free Software
7 : Foundation; either version 2 of the License, or (at your option) any later
8 : version. It is distributed in the hope that it will be useful, but WITHOUT
9 : ANY WARRANTY WHATSOEVER.
10 :
11 : Check the License for details. You should have received a copy of it, along
12 : with the package; see the file 'COPYING'. If not, write to the Free Software
13 : Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. */
14 :
15 : /********************************************************************/
16 : /** **/
17 : /** LINEAR ALGEBRA **/
18 : /** (second part) **/
19 : /** **/
20 : /********************************************************************/
21 : #include "pari.h"
22 : #include "paripriv.h"
23 :
24 : #define DEBUGLEVEL DEBUGLEVEL_mat
25 :
26 : /*******************************************************************/
27 : /* */
28 : /* CHARACTERISTIC POLYNOMIAL */
29 : /* */
30 : /*******************************************************************/
31 :
32 : static GEN
33 34103 : Flm_charpoly_i(GEN x, ulong p)
34 : {
35 34103 : long lx = lg(x), r, i;
36 34103 : GEN H, y = cgetg(lx+1, t_VEC);
37 34103 : gel(y,1) = pol1_Flx(0); H = Flm_hess(x, p);
38 257931 : for (r = 1; r < lx; r++)
39 : {
40 223828 : pari_sp av2 = avma;
41 223828 : ulong a = 1;
42 223828 : GEN z, b = zero_Flx(0);
43 673567 : for (i = r-1; i; i--)
44 : {
45 565095 : a = Fl_mul(a, ucoeff(H,i+1,i), p);
46 564953 : if (!a) break;
47 449561 : b = Flx_add(b, Flx_Fl_mul(gel(y,i), Fl_mul(a,ucoeff(H,i,r),p), p), p);
48 : }
49 223834 : z = Flx_sub(Flx_shift(gel(y,r), 1),
50 223864 : Flx_Fl_mul(gel(y,r), ucoeff(H,r,r), p), p);
51 : /* (X - H[r,r])y[r] - b */
52 223829 : gel(y,r+1) = gerepileuptoleaf(av2, Flx_sub(z, b, p));
53 : }
54 34103 : return gel(y,lx);
55 : }
56 :
57 : GEN
58 2151 : Flm_charpoly(GEN x, ulong p)
59 : {
60 2151 : pari_sp av = avma;
61 2151 : return gerepileuptoleaf(av, Flm_charpoly_i(x,p));
62 : }
63 :
64 : GEN
65 29205 : FpM_charpoly(GEN x, GEN p)
66 : {
67 29205 : pari_sp av = avma;
68 : long lx, r, i;
69 : GEN y, H;
70 :
71 29205 : if (lgefint(p) == 3)
72 : {
73 28420 : ulong pp = p[2];
74 28420 : y = Flx_to_ZX(Flm_charpoly_i(ZM_to_Flm(x,pp), pp));
75 28420 : return gerepileupto(av, y);
76 : }
77 785 : lx = lg(x); y = cgetg(lx+1, t_VEC);
78 785 : gel(y,1) = pol_1(0); H = FpM_hess(x, p);
79 4153 : for (r = 1; r < lx; r++)
80 : {
81 4153 : pari_sp av2 = avma;
82 4153 : GEN z, a = gen_1, b = pol_0(0);
83 9376 : for (i = r-1; i; i--)
84 : {
85 7064 : a = Fp_mul(a, gcoeff(H,i+1,i), p);
86 7064 : if (!signe(a)) break;
87 5223 : b = ZX_add(b, ZX_Z_mul(gel(y,i), Fp_mul(a,gcoeff(H,i,r),p)));
88 : }
89 4153 : b = FpX_red(b, p);
90 4153 : z = FpX_sub(RgX_shift_shallow(gel(y,r), 1),
91 4153 : FpX_Fp_mul(gel(y,r), gcoeff(H,r,r), p), p);
92 4153 : z = FpX_sub(z,b,p);
93 4153 : if (r+1 == lx) { gel(y,lx) = z; break; }
94 3368 : gel(y,r+1) = gerepileupto(av2, z); /* (X - H[r,r])y[r] - b */
95 : }
96 785 : return gerepileupto(av, gel(y,lx));
97 : }
98 :
99 : GEN
100 553 : charpoly0(GEN x, long v, long flag)
101 : {
102 553 : if (v<0) v = 0;
103 553 : switch(flag)
104 : {
105 14 : case 0: return caradj(x,v,NULL);
106 14 : case 1: return caract(x,v);
107 14 : case 2: return carhess(x,v);
108 14 : case 3: return carberkowitz(x,v);
109 7 : case 4:
110 7 : if (typ(x) != t_MAT) pari_err_TYPE("charpoly",x);
111 7 : RgM_check_ZM(x, "charpoly");
112 7 : x = ZM_charpoly(x); setvarn(x, v); return x;
113 490 : case 5:
114 490 : return charpoly(x, v);
115 : }
116 0 : pari_err_FLAG("charpoly");
117 : return NULL; /* LCOV_EXCL_LINE */
118 : }
119 :
120 : /* (v - x)^d */
121 : static GEN
122 42 : caract_const(pari_sp av, GEN x, long v, long d)
123 42 : { return gerepileupto(av, gpowgs(deg1pol_shallow(gen_1, gneg_i(x), v), d)); }
124 :
125 : /* characteristic pol. Easy cases. Return NULL in case it's not so easy. */
126 : static GEN
127 5828 : easychar(GEN x, long v)
128 : {
129 : pari_sp av;
130 : long lx;
131 : GEN p1;
132 :
133 5828 : switch(typ(x))
134 : {
135 35 : case t_INT: case t_REAL: case t_INTMOD:
136 : case t_FRAC: case t_PADIC:
137 35 : p1=cgetg(4,t_POL);
138 35 : p1[1]=evalsigne(1) | evalvarn(v);
139 35 : gel(p1,2) = gneg(x); gel(p1,3) = gen_1;
140 35 : return p1;
141 :
142 14 : case t_COMPLEX: case t_QUAD:
143 14 : p1 = cgetg(5,t_POL);
144 14 : p1[1] = evalsigne(1) | evalvarn(v);
145 14 : gel(p1,2) = gnorm(x); av = avma;
146 14 : gel(p1,3) = gerepileupto(av, gneg(gtrace(x)));
147 14 : gel(p1,4) = gen_1; return p1;
148 :
149 28 : case t_FFELT: {
150 28 : pari_sp ltop=avma;
151 28 : p1 = FpX_to_mod(FF_charpoly(x), FF_p_i(x));
152 28 : setvarn(p1,v); return gerepileupto(ltop,p1);
153 : }
154 :
155 133 : case t_POLMOD:
156 : {
157 133 : GEN A = gel(x,2), T = gel(x,1);
158 : long vx, vp;
159 133 : if (typ(A) != t_POL) return caract_const(avma, A, v, degpol(T));
160 98 : vx = varn(A);
161 98 : vp = varn(T);
162 98 : if (varncmp(vx, vp) > 0) return caract_const(avma, A, v, degpol(T));
163 91 : if (varncmp(vx, vp) < 0) pari_err_PRIORITY("charpoly", x, "<", vp);
164 91 : return RgXQ_charpoly(A, T, v);
165 : }
166 5618 : case t_MAT:
167 5618 : lx=lg(x);
168 5618 : if (lx==1) return pol_1(v);
169 5562 : if (lgcols(x) != lx) break;
170 5555 : return NULL;
171 : }
172 7 : pari_err_TYPE("easychar",x);
173 : return NULL; /* LCOV_EXCL_LINE */
174 : }
175 : /* compute charpoly by mapping to Fp first, return lift to Z */
176 : static GEN
177 35 : RgM_Fp_charpoly(GEN x, GEN p, long v)
178 : {
179 : GEN T;
180 35 : if (lgefint(p) == 3)
181 : {
182 21 : ulong pp = itou(p);
183 21 : T = Flm_charpoly_i(RgM_to_Flm(x, pp), pp);
184 21 : T = Flx_to_ZX(T);
185 : }
186 : else
187 14 : T = FpM_charpoly(RgM_to_FpM(x, p), p);
188 35 : setvarn(T, v); return T;
189 : }
190 : GEN
191 3763 : charpoly(GEN x, long v)
192 : {
193 3763 : GEN T, p = NULL;
194 : long prec;
195 3763 : if ((T = easychar(x,v))) return T;
196 3532 : switch(RgM_type(x, &p,&T,&prec))
197 : {
198 2321 : case t_INT:
199 2321 : T = ZM_charpoly(x); setvarn(T, v); break;
200 35 : case t_INTMOD:
201 35 : if (!BPSW_psp(p)) T = carberkowitz(x, v);
202 : else
203 : {
204 35 : pari_sp av = avma;
205 35 : T = RgM_Fp_charpoly(x,p,v);
206 35 : T = gerepileupto(av, FpX_to_mod(T,p));
207 : }
208 35 : break;
209 147 : case t_REAL:
210 : case t_COMPLEX:
211 : case t_PADIC:
212 147 : T = carhess(x, v);
213 147 : break;
214 1029 : default:
215 1029 : T = carberkowitz(x, v);
216 : }
217 3525 : return T;
218 : }
219 :
220 : /* We possibly worked with an "invalid" polynomial p, satisfying
221 : * varn(p) > gvar2(p). Fix this. */
222 : static GEN
223 1960 : fix_pol(pari_sp av, GEN p)
224 : {
225 1960 : long w = gvar2(p), v = varn(p);
226 1960 : if (w == v) pari_err_PRIORITY("charpoly", p, "=", w);
227 1953 : if (varncmp(w,v) < 0) p = gerepileupto(av, poleval(p, pol_x(v)));
228 1953 : return p;
229 : }
230 : GEN
231 14 : caract(GEN x, long v)
232 : {
233 14 : pari_sp av = avma;
234 : GEN T, C, x_k, Q;
235 : long k, n;
236 :
237 14 : if ((T = easychar(x,v))) return T;
238 :
239 14 : n = lg(x)-1;
240 14 : if (n == 1) return fix_pol(av, deg1pol(gen_1, gneg(gcoeff(x,1,1)), v));
241 :
242 14 : x_k = pol_x(v); /* to be modified in place */
243 14 : T = scalarpol(det(x), v); C = utoineg(n); Q = pol_x(v);
244 28 : for (k=1; k<=n; k++)
245 : {
246 28 : GEN mk = utoineg(k), d;
247 28 : gel(x_k,2) = mk;
248 28 : d = det(RgM_Rg_add_shallow(x, mk));
249 28 : T = RgX_add(RgX_mul(T, x_k), RgX_Rg_mul(Q, gmul(C, d)));
250 28 : if (k == n) break;
251 :
252 14 : Q = RgX_mul(Q, x_k);
253 14 : C = diviuexact(mulsi(k-n,C), k+1); /* (-1)^k binomial(n,k) */
254 : }
255 14 : return fix_pol(av, RgX_Rg_div(T, mpfact(n)));
256 : }
257 :
258 : /* C = charpoly(x, v) */
259 : static GEN
260 21 : RgM_adj_from_char(GEN x, long v, GEN C)
261 : {
262 21 : if (varn(C) != v) /* problem with variable priorities */
263 : {
264 7 : C = gdiv(gsub(C, gsubst(C, v, gen_0)), pol_x(v));
265 7 : if (odd(lg(x))) C = RgX_neg(C); /* even dimension */
266 7 : return gsubst(C, v, x);
267 : }
268 : else
269 : {
270 14 : C = RgX_shift_shallow(C, -1);
271 14 : if (odd(lg(x))) C = RgX_neg(C); /* even dimension */
272 14 : return RgX_RgM_eval(C, x);
273 : }
274 : }
275 : /* assume x square matrice */
276 : static GEN
277 1960 : mattrace(GEN x)
278 : {
279 1960 : long i, lx = lg(x);
280 : GEN t;
281 1960 : if (lx < 3) return lx == 1? gen_0: gcopy(gcoeff(x,1,1));
282 1890 : t = gcoeff(x,1,1);
283 5215 : for (i = 2; i < lx; i++) t = gadd(t, gcoeff(x,i,i));
284 1890 : return t;
285 : }
286 : static int
287 56 : bad_char(GEN q, long n)
288 : {
289 : forprime_t S;
290 : ulong p;
291 56 : if (!signe(q)) return 0;
292 42 : (void)u_forprime_init(&S, 2, n);
293 98 : while ((p = u_forprime_next(&S)))
294 70 : if (!umodiu(q, p)) return 1;
295 28 : return 0;
296 : }
297 : /* Using traces: return the characteristic polynomial of x (in variable v).
298 : * If py != NULL, the adjoint matrix is put there. */
299 : GEN
300 119 : caradj(GEN x, long v, GEN *py)
301 : {
302 : pari_sp av, av0;
303 : long i, k, n;
304 : GEN T, y, t;
305 :
306 119 : if ((T = easychar(x, v)))
307 : {
308 42 : if (py)
309 : {
310 42 : if (typ(x) != t_MAT) pari_err_TYPE("matadjoint",x);
311 42 : *py = cgetg(1,t_MAT);
312 : }
313 42 : return T;
314 : }
315 :
316 77 : n = lg(x)-1; av0 = avma;
317 77 : T = cgetg(n+3,t_POL); T[1] = evalsigne(1) | evalvarn(v);
318 77 : gel(T,n+2) = gen_1;
319 77 : if (!n) { if (py) *py = cgetg(1,t_MAT); return T; }
320 77 : av = avma; t = gerepileupto(av, gneg(mattrace(x)));
321 77 : gel(T,n+1) = t;
322 77 : if (n == 1) {
323 7 : T = fix_pol(av0, T);
324 7 : if (py) *py = matid(1); return T;
325 : }
326 70 : if (n == 2) {
327 14 : GEN a = gcoeff(x,1,1), b = gcoeff(x,1,2);
328 14 : GEN c = gcoeff(x,2,1), d = gcoeff(x,2,2);
329 14 : av = avma;
330 14 : gel(T,2) = gerepileupto(av, gsub(gmul(a,d), gmul(b,c)));
331 14 : T = fix_pol(av0, T);
332 14 : if (py) {
333 7 : y = cgetg(3, t_MAT);
334 7 : gel(y,1) = mkcol2(gcopy(d), gneg(c));
335 7 : gel(y,2) = mkcol2(gneg(b), gcopy(a));
336 7 : *py = y;
337 : }
338 14 : return T;
339 : }
340 : /* l > 3 */
341 56 : if (bad_char(residual_characteristic(x), n))
342 : { /* n! not invertible in base ring */
343 14 : T = charpoly(x, v);
344 14 : if (!py) return gerepileupto(av, T);
345 14 : *py = RgM_adj_from_char(x, v, T); return gc_all(av, 2, &T,py);
346 : }
347 42 : av = avma; y = RgM_shallowcopy(x);
348 175 : for (i = 1; i <= n; i++) gcoeff(y,i,i) = gadd(gcoeff(y,i,i), t);
349 91 : for (k = 2; k < n; k++)
350 : {
351 49 : GEN y0 = y;
352 49 : y = RgM_mul(y, x);
353 49 : t = gdivgs(mattrace(y), -k);
354 210 : for (i = 1; i <= n; i++) gcoeff(y,i,i) = gadd(gcoeff(y,i,i), t);
355 49 : y = gclone(y);
356 49 : gel(T,n-k+2) = gerepilecopy(av, t); av = avma;
357 49 : if (k > 2) gunclone(y0);
358 : }
359 42 : t = gmul(gcoeff(x,1,1),gcoeff(y,1,1));
360 133 : for (i=2; i<=n; i++) t = gadd(t, gmul(gcoeff(x,1,i),gcoeff(y,i,1)));
361 42 : gel(T,2) = gerepileupto(av, gneg(t));
362 42 : T = fix_pol(av0, T);
363 42 : if (py) *py = odd(n)? gcopy(y): RgM_neg(y);
364 42 : gunclone(y); return T;
365 : }
366 :
367 : GEN
368 105 : adj(GEN x)
369 : {
370 : GEN y;
371 105 : (void)caradj(x, fetch_var(), &y);
372 105 : (void)delete_var(); return y;
373 : }
374 :
375 : GEN
376 7 : adjsafe(GEN x)
377 : {
378 7 : const long v = fetch_var();
379 7 : pari_sp av = avma;
380 : GEN C, A;
381 7 : if (typ(x) != t_MAT) pari_err_TYPE("matadjoint",x);
382 7 : if (lg(x) < 3) return gcopy(x);
383 7 : C = charpoly(x,v);
384 7 : A = RgM_adj_from_char(x, v, C);
385 7 : (void)delete_var(); return gerepileupto(av, A);
386 : }
387 :
388 : GEN
389 112 : matadjoint0(GEN x, long flag)
390 : {
391 112 : switch(flag)
392 : {
393 105 : case 0: return adj(x);
394 7 : case 1: return adjsafe(x);
395 : }
396 0 : pari_err_FLAG("matadjoint");
397 : return NULL; /* LCOV_EXCL_LINE */
398 : }
399 :
400 : /*******************************************************************/
401 : /* */
402 : /* Frobenius form */
403 : /* */
404 : /*******************************************************************/
405 :
406 : /* The following section implement a mix of Ozello and Storjohann algorithms
407 :
408 : P. Ozello, doctoral thesis (in French):
409 : Calcul exact des formes de Jordan et de Frobenius d'une matrice, Chapitre 2
410 : http://tel.archives-ouvertes.fr/tel-00323705
411 :
412 : A. Storjohann, Diss. ETH No. 13922
413 : Algorithms for Matrix Canonical Forms, Chapter 9
414 : https://cs.uwaterloo.ca/~astorjoh/diss2up.pdf
415 :
416 : We use Storjohann Lemma 9.14 (step1, step2, step3) Ozello theorem 4,
417 : and Storjohann Lemma 9.18
418 : */
419 :
420 : /* Elementary transforms */
421 :
422 : /* M <- U^(-1) M U, U = E_{i,j}(k) => U^(-1) = E{i,j}(-k)
423 : * P = U * P */
424 : static void
425 14826 : transL(GEN M, GEN P, GEN k, long i, long j)
426 : {
427 14826 : long l, n = lg(M)-1;
428 179900 : for(l=1; l<=n; l++) /* M[,j]-=k*M[,i] */
429 165074 : gcoeff(M,l,j) = gsub(gcoeff(M,l,j), gmul(gcoeff(M,l,i), k));
430 179900 : for(l=1; l<=n; l++) /* M[i,]+=k*M[j,] */
431 165074 : gcoeff(M,i,l) = gadd(gcoeff(M,i,l), gmul(gcoeff(M,j,l), k));
432 14826 : if (P)
433 169925 : for(l=1; l<=n; l++)
434 156198 : gcoeff(P,i,l) = gadd(gcoeff(P,i,l), gmul(gcoeff(P,j,l), k));
435 14826 : }
436 :
437 : /* j = a or b */
438 : static void
439 2618 : transD(GEN M, GEN P, long a, long b, long j)
440 : {
441 : long l, n;
442 2618 : GEN k = gcoeff(M,a,b), ki;
443 :
444 2618 : if (gequal1(k)) return;
445 1330 : ki = ginv(k); n = lg(M)-1;
446 13643 : for(l=1; l<=n; l++)
447 12313 : if (l!=j)
448 : {
449 10983 : gcoeff(M,l,j) = gmul(gcoeff(M,l,j), k);
450 10983 : gcoeff(M,j,l) = (j==a && l==b)? gen_1: gmul(gcoeff(M,j,l), ki);
451 : }
452 1330 : if (P)
453 11298 : for(l=1; l<=n; l++)
454 10241 : gcoeff(P,j,l) = gmul(gcoeff(P,j,l), ki);
455 : }
456 :
457 : static void
458 539 : transS(GEN M, GEN P, long i, long j)
459 : {
460 539 : long l, n = lg(M)-1;
461 539 : swap(gel(M,i), gel(M,j));
462 7056 : for (l=1; l<=n; l++)
463 6517 : swap(gcoeff(M,i,l), gcoeff(M,j,l));
464 539 : if (P)
465 5621 : for (l=1; l<=n; l++)
466 5243 : swap(gcoeff(P,i,l), gcoeff(P,j,l));
467 539 : }
468 :
469 : /* Convert companion matrix to polynomial*/
470 : static GEN
471 434 : minpoly_polslice(GEN M, long i, long j, long v)
472 : {
473 434 : long k, d = j+1-i;
474 434 : GEN P = cgetg(d+3,t_POL);
475 434 : P[1] = evalsigne(1)|evalvarn(v);
476 2037 : for (k=0; k<d; k++)
477 1603 : gel(P,k+2) = gneg(gcoeff(M,i+k, j));
478 434 : gel(P,d+2) = gen_1;
479 434 : return P;
480 : }
481 :
482 : static GEN
483 49 : minpoly_listpolslice(GEN M, GEN V, long v)
484 : {
485 49 : long i, n = lg(M)-1, nb = lg(V)-1;
486 49 : GEN W = cgetg(nb+1, t_VEC);
487 147 : for (i=1; i<=nb; i++)
488 98 : gel(W,i) = minpoly_polslice(M, V[i], i < nb? V[i+1]-1: n, v);
489 49 : return W;
490 : }
491 :
492 : static int
493 168 : minpoly_dvdslice(GEN M, long i, long j, long k)
494 : {
495 168 : pari_sp av = avma;
496 168 : long r = signe(RgX_rem(minpoly_polslice(M, i, j-1, 0),
497 : minpoly_polslice(M, j, k, 0)));
498 168 : return gc_bool(av, r == 0);
499 : }
500 :
501 : static void
502 0 : RgM_replace(GEN M, GEN M2)
503 : {
504 0 : long n = lg(M)-1, m = nbrows(M), i, j;
505 0 : for(i=1; i<=n; i++)
506 0 : for(j=1; j<=m; j++)
507 0 : gcoeff(M, i, j) = gcoeff(M2, i, j);
508 0 : }
509 :
510 : static void
511 0 : gerepilemat2_inplace(pari_sp av, GEN M, GEN P)
512 : {
513 0 : GEN M2 = M, P2 = P;
514 0 : gerepileall(av, P ? 2: 1, &M2, &P2);
515 0 : RgM_replace(M, M2);
516 0 : if (P) RgM_replace(P, P2);
517 0 : }
518 :
519 : /* Lemma 9.14 */
520 : static long
521 742 : weakfrobenius_step1(GEN M, GEN P, long j0)
522 : {
523 742 : pari_sp av = avma;
524 742 : long n = lg(M)-1, k, j;
525 3339 : for (j = j0; j < n; ++j)
526 : {
527 2835 : if (gequal0(gcoeff(M, j+1, j)))
528 : {
529 2086 : for (k = j+2; k <= n; ++k)
530 1848 : if (!gequal0(gcoeff(M,k,j))) break;
531 756 : if (k > n) return j;
532 518 : transS(M, P, k, j+1);
533 : }
534 2597 : transD(M, P, j+1, j, j+1);
535 : /* Now M[j+1,j] = 1 */
536 28623 : for (k = 1; k <= n; ++k)
537 26026 : if (k != j+1 && !gequal0(gcoeff(M,k,j))) /* zero M[k,j] */
538 : {
539 13874 : transL(M, P, gneg(gcoeff(M,k,j)), k, j+1);
540 13874 : gcoeff(M,k,j) = gen_0; /* avoid approximate 0 */
541 : }
542 2597 : if (gc_needed(av,1))
543 : {
544 0 : if (DEBUGMEM > 1)
545 0 : pari_warn(warnmem,"RgM_minpoly stage 1: j0=%ld, j=%ld", j0, j);
546 0 : gerepilemat2_inplace(av, M, P);
547 : }
548 : }
549 504 : return n;
550 : }
551 :
552 : static void
553 742 : weakfrobenius_step2(GEN M, GEN P, long j)
554 : {
555 742 : pari_sp av = avma;
556 742 : long i, k, n = lg(M)-1;
557 4207 : for(i=j; i>=2; i--)
558 : {
559 7546 : for(k=j+1; k<=n; k++)
560 4081 : if (!gequal0(gcoeff(M,i,k)))
561 952 : transL(M, P, gcoeff(M,i,k), i-1, k);
562 3465 : if (gc_needed(av,1))
563 : {
564 0 : if (DEBUGMEM > 1)
565 0 : pari_warn(warnmem,"RgM_minpoly stage 2: j=%ld, i=%ld", j, i);
566 0 : gerepilemat2_inplace(av, M, P);
567 : }
568 : }
569 742 : }
570 :
571 : static long
572 742 : weakfrobenius_step3(GEN M, GEN P, long j0, long j)
573 : {
574 742 : long i, k, n = lg(M)-1;
575 742 : if (j == n) return 0;
576 238 : if (gequal0(gcoeff(M, j0, j+1)))
577 : {
578 840 : for (k=j+2; k<=n; k++)
579 623 : if (!gequal0(gcoeff(M, j0, k))) break;
580 217 : if (k > n) return 0;
581 0 : transS(M, P, k, j+1);
582 : }
583 21 : transD(M, P, j0, j+1, j+1);
584 21 : for (i=j+2; i<=n; i++)
585 0 : if (!gequal0(gcoeff(M, j0, i)))
586 0 : transL(M, P, gcoeff(M, j0, i),j+1, i);
587 21 : return 1;
588 : }
589 :
590 : /* flag: 0 -> full Frobenius from , 1 -> weak Frobenius form */
591 : static GEN
592 504 : RgM_Frobenius(GEN M, long flag, GEN *pt_P, GEN *pt_v)
593 : {
594 504 : pari_sp av = avma, av2, ltop;
595 504 : long n = lg(M)-1, eps, j0 = 1, nb = 0;
596 : GEN v, P;
597 504 : v = cgetg(n+1, t_VECSMALL);
598 504 : ltop = avma;
599 504 : P = pt_P ? matid(n): NULL;
600 504 : M = RgM_shallowcopy(M);
601 504 : av2 = avma;
602 1246 : while (j0 <= n)
603 : {
604 742 : long j = weakfrobenius_step1(M, P, j0);
605 742 : weakfrobenius_step2(M, P, j);
606 742 : eps = weakfrobenius_step3(M, P, j0, j);
607 742 : if (eps == 0)
608 : {
609 721 : v[++nb] = j0;
610 721 : if (flag == 0 && nb > 1 && !minpoly_dvdslice(M, v[nb-1], j0, j))
611 : {
612 0 : j = j0; j0 = v[nb-1]; nb -= 2;
613 0 : transL(M, P, gen_1, j, j0); /*lemma 9.18*/
614 : } else
615 721 : j0 = j+1;
616 : }
617 : else
618 21 : transS(M, P, j0, j+1); /*theorem 4*/
619 742 : if (gc_needed(av,1))
620 : {
621 0 : if (DEBUGMEM > 1)
622 0 : pari_warn(warnmem,"weakfrobenius j0=%ld",j0);
623 0 : gerepilemat2_inplace(av2, M, P);
624 : }
625 : }
626 504 : fixlg(v, nb+1);
627 504 : if (pt_v) *pt_v = v;
628 504 : gerepileall(pt_v ? ltop: av, P? 2: 1, &M, &P);
629 504 : if (pt_P) *pt_P = P;
630 504 : return M;
631 : }
632 :
633 : static GEN
634 49 : RgM_minpoly(GEN M, long v)
635 : {
636 49 : pari_sp av = avma;
637 : GEN V, W;
638 49 : if (lg(M) == 1) return pol_1(v);
639 49 : M = RgM_Frobenius(M, 1, NULL, &V);
640 49 : W = minpoly_listpolslice(M, V, v);
641 49 : if (varncmp(v,gvar2(W)) >= 0)
642 0 : pari_err_PRIORITY("matfrobenius", M, "<=", v);
643 49 : return gerepileupto(av, RgX_normalize(glcm0(W, NULL)));
644 : }
645 :
646 : GEN
647 0 : Frobeniusform(GEN V, long n)
648 : {
649 : long i, j, k;
650 0 : GEN M = zeromatcopy(n,n);
651 0 : for (k=1,i=1;i<lg(V);i++,k++)
652 : {
653 0 : GEN P = gel(V,i);
654 0 : long d = degpol(P);
655 0 : if (k+d-1 > n) pari_err_PREC("matfrobenius");
656 0 : for (j=0; j<d-1; j++, k++) gcoeff(M,k+1,k) = gen_1;
657 0 : for (j=0; j<d; j++) gcoeff(M,k-j,k) = gneg(gel(P, 1+d-j));
658 : }
659 0 : return M;
660 : }
661 :
662 : GEN
663 455 : matfrobenius(GEN M, long flag, long v)
664 : {
665 : long n;
666 455 : if (typ(M)!=t_MAT) pari_err_TYPE("matfrobenius",M);
667 455 : if (v < 0) v = 0;
668 455 : n = lg(M)-1;
669 455 : if (n && lgcols(M)!=n+1) pari_err_DIM("matfrobenius");
670 455 : if (flag > 2) pari_err_FLAG("matfrobenius");
671 455 : switch (flag)
672 : {
673 7 : case 0:
674 7 : return RgM_Frobenius(M, 0, NULL, NULL);
675 0 : case 1:
676 : {
677 0 : pari_sp av = avma;
678 : GEN V, W, F;
679 0 : F = RgM_Frobenius(M, 0, NULL, &V);
680 0 : W = minpoly_listpolslice(F, V, v);
681 0 : if (varncmp(v, gvar2(W)) >= 0)
682 0 : pari_err_PRIORITY("matfrobenius", M, "<=", v);
683 0 : return gerepileupto(av, W);
684 : }
685 448 : case 2:
686 : {
687 448 : GEN P, F, R = cgetg(3, t_VEC);
688 448 : F = RgM_Frobenius(M, 0, &P, NULL);
689 448 : gel(R,1) = F; gel(R,2) = P;
690 448 : return R;
691 : }
692 0 : default:
693 0 : pari_err_FLAG("matfrobenius");
694 : }
695 : return NULL; /*LCOV_EXCL_LINE*/
696 : }
697 :
698 : /*******************************************************************/
699 : /* */
700 : /* MINIMAL POLYNOMIAL */
701 : /* */
702 : /*******************************************************************/
703 :
704 : static GEN
705 63 : RgXQ_minpoly_naive(GEN y, GEN P)
706 : {
707 63 : long n = lgpol(P);
708 63 : GEN M = ker(RgXQ_matrix_pow(y,n,n,P));
709 63 : return content(RgM_to_RgXV(M,varn(P)));
710 : }
711 :
712 : static GEN
713 0 : RgXQ_minpoly_FpXQ(GEN x, GEN y, GEN p)
714 : {
715 0 : pari_sp av = avma;
716 : GEN r;
717 0 : if (lgefint(p) == 3)
718 : {
719 0 : ulong pp = uel(p, 2);
720 0 : r = Flx_to_ZX_inplace(Flxq_minpoly(RgX_to_Flx(x, pp),
721 : RgX_to_Flx(y, pp), pp));
722 : }
723 : else
724 0 : r = FpXQ_minpoly(RgX_to_FpX(x, p), RgX_to_FpX(y, p), p);
725 0 : return gerepileupto(av, FpX_to_mod(r, p));
726 : }
727 :
728 : static GEN
729 21 : RgXQ_minpoly_FpXQXQ(GEN x, GEN S, GEN pol, GEN p)
730 : {
731 21 : pari_sp av = avma;
732 : GEN r;
733 21 : GEN T = RgX_to_FpX(pol, p);
734 21 : if (signe(T)==0) pari_err_OP("minpoly",x,S);
735 21 : if (lgefint(p) == 3)
736 : {
737 13 : ulong pp = uel(p, 2);
738 13 : GEN Tp = ZX_to_Flx(T, pp);
739 13 : r = FlxX_to_ZXX(FlxqXQ_minpoly(RgX_to_FlxqX(x, Tp, pp),
740 : RgX_to_FlxqX(S, Tp, pp), Tp, pp));
741 : }
742 : else
743 8 : r = FpXQXQ_minpoly(RgX_to_FpXQX(x, T, p), RgX_to_FpXQX(S, T, p), T, p);
744 21 : return gerepileupto(av, FpXQX_to_mod(r, T, p));
745 : }
746 :
747 : #define code(t1,t2) ((t1 << 6) | t2)
748 :
749 : static GEN
750 3255 : RgXQ_minpoly_fast(GEN x, GEN y)
751 : {
752 : GEN p, pol;
753 : long pa;
754 3255 : long t = RgX_type2(x,y, &p,&pol,&pa);
755 3255 : switch(t)
756 : {
757 0 : case t_INTMOD: return RgXQ_minpoly_FpXQ(x, y, p);
758 77 : case t_FFELT: return FFXQ_minpoly(x, y, pol);
759 21 : case code(t_POLMOD, t_INTMOD):
760 21 : return RgXQ_minpoly_FpXQXQ(x, y, pol, p);
761 3157 : default: return NULL;
762 : }
763 : }
764 :
765 : #undef code
766 :
767 : /* return caract(Mod(x,T)) in variable v */
768 : GEN
769 3255 : RgXQ_minpoly(GEN x, GEN T, long v)
770 : {
771 3255 : pari_sp av = avma;
772 3255 : GEN R = RgXQ_minpoly_fast(x,T);
773 3255 : if (R) { setvarn(R, v); return R; }
774 3157 : if (!issquarefree(T))
775 : {
776 63 : R = RgXQ_minpoly_naive(x, T);
777 63 : setvarn(R,v); return R;
778 : }
779 3094 : R = RgXQ_charpoly(x, T, v);
780 3094 : return gerepileupto(av, RgX_div(R,RgX_gcd(R, RgX_deriv(R))));
781 : }
782 :
783 : static GEN
784 3668 : easymin(GEN x, long v)
785 : {
786 : GEN G, R, dR;
787 3668 : long tx = typ(x);
788 3668 : if (tx == t_FFELT)
789 : {
790 154 : R = FpX_to_mod(FF_minpoly(x), FF_p_i(x));
791 154 : setvarn(R,v); return R;
792 : }
793 3514 : if (tx == t_POLMOD)
794 : {
795 3465 : GEN a = gel(x,2), b = gel(x,1);
796 3465 : if (degpol(b)==0) return pol_1(v);
797 3437 : if (typ(a) != t_POL || varn(a) != varn(b))
798 : {
799 217 : if (varncmp(gvar(a), v) <= 0) pari_err_PRIORITY("minpoly", x, "<", v);
800 210 : return deg1pol(gen_1, gneg_i(a), v);
801 : }
802 3220 : return RgXQ_minpoly(a, b, v);
803 : }
804 49 : R = easychar(x, v); if (!R) return NULL;
805 0 : dR = RgX_deriv(R); if (!lgpol(dR)) return NULL;
806 0 : G = RgX_normalize(RgX_gcd(R,dR));
807 0 : return RgX_div(R,G);
808 : }
809 : GEN
810 3668 : minpoly(GEN x, long v)
811 : {
812 3668 : pari_sp av = avma;
813 : GEN P;
814 3668 : if (v < 0) v = 0;
815 3668 : P = easymin(x,v);
816 3661 : if (P) return gerepileupto(av,P);
817 : /* typ(x) = t_MAT */
818 49 : set_avma(av); return RgM_minpoly(x,v);
819 : }
820 :
821 : /*******************************************************************/
822 : /* */
823 : /* HESSENBERG FORM */
824 : /* */
825 : /*******************************************************************/
826 : static int
827 364 : relative0(GEN a, GEN a0, long bit)
828 : {
829 364 : if (gequal0(a)) return 1;
830 343 : if (gequal0(a0)) return gexpo(a) < bit;
831 203 : return (gexpo(a)-gexpo(a0) < bit);
832 : }
833 : /* x0 a nonempty square t_MAT that can be written to */
834 : static GEN
835 168 : RgM_hess(GEN x0, long prec)
836 : {
837 168 : pari_sp av = avma;
838 168 : long lx = lg(x0), bit = prec? 8 - prec2nbits(prec): 0, m, i, j;
839 168 : GEN x = bit? RgM_shallowcopy(x0): x0;
840 :
841 665 : for (m=2; m<lx-1; m++)
842 : {
843 497 : GEN t = NULL;
844 497 : if (!bit)
845 : { /* first non-zero pivot */
846 84 : for (i=m+1; i<lx; i++)
847 77 : if (!gequal0(t = gcoeff(x,i,m-1))) break;
848 : }
849 : else
850 : { /* maximal pivot */
851 434 : long E = -(long)HIGHEXPOBIT, k = lx;
852 3906 : for (i=m+1; i<lx; i++)
853 : {
854 3472 : long e = gexpo(gcoeff(x,i,m-1));
855 3472 : if (e > E) { E = e; k = i; t = gcoeff(x,i,m-1); }
856 : }
857 434 : if (k != lx && relative0(t, gcoeff(x0,k,m-1), bit)) k = lx;
858 434 : i = k;
859 : }
860 497 : if (i == lx) continue;
861 4438 : for (j=m-1; j<lx; j++) swap(gcoeff(x,i,j), gcoeff(x,m,j));
862 385 : swap(gel(x,i), gel(x,m));
863 385 : if (bit)
864 : {
865 4102 : for (j=m-1; j<lx; j++) swap(gcoeff(x0,i,j), gcoeff(x0,m,j));
866 329 : swap(gel(x0,i), gel(x0,m));
867 : }
868 385 : t = ginv(t);
869 :
870 3668 : for (i=m+1; i<lx; i++)
871 : {
872 3283 : GEN c = gcoeff(x,i,m-1);
873 3283 : if (gequal0(c)) continue;
874 :
875 2520 : c = gmul(c,t); gcoeff(x,i,m-1) = gen_0;
876 41062 : for (j=m; j<lx; j++)
877 38542 : gcoeff(x,i,j) = gsub(gcoeff(x,i,j), gmul(c,gcoeff(x,m,j)));
878 67417 : for (j=1; j<lx; j++)
879 64897 : gcoeff(x,j,m) = gadd(gcoeff(x,j,m), gmul(c,gcoeff(x,j,i)));
880 2520 : if (gc_needed(av,2))
881 : {
882 0 : if (DEBUGMEM>1) pari_warn(warnmem,"hess, m = %ld", m);
883 0 : gerepileall(av,2, &x, &t);
884 : }
885 : }
886 : }
887 168 : return x;
888 : }
889 :
890 : GEN
891 168 : hess(GEN x)
892 : {
893 168 : pari_sp av = avma;
894 168 : GEN p = NULL, T = NULL;
895 168 : long prec, lx = lg(x);
896 168 : if (typ(x) != t_MAT) pari_err_TYPE("hess",x);
897 168 : if (lx == 1) return cgetg(1,t_MAT);
898 168 : if (lgcols(x) != lx) pari_err_DIM("hess");
899 168 : switch(RgM_type(x, &p, &T, &prec))
900 : {
901 140 : case t_REAL:
902 140 : case t_COMPLEX: break;
903 28 : default: prec = 0;
904 : }
905 168 : return gerepilecopy(av, RgM_hess(RgM_shallowcopy(x),prec));
906 : }
907 :
908 : GEN
909 34103 : Flm_hess(GEN x, ulong p)
910 : {
911 34103 : long lx = lg(x), m, i, j;
912 34103 : if (lx == 1) return cgetg(1,t_MAT);
913 34103 : if (lgcols(x) != lx) pari_err_DIM("hess");
914 :
915 34103 : x = Flm_copy(x);
916 190070 : for (m=2; m<lx-1; m++)
917 : {
918 156227 : ulong t = 0;
919 731919 : for (i=m+1; i<lx; i++) { t = ucoeff(x,i,m-1); if (t) break; }
920 156227 : if (i == lx) continue;
921 1284030 : for (j=m-1; j<lx; j++) lswap(ucoeff(x,i,j), ucoeff(x,m,j));
922 94191 : swap(gel(x,i), gel(x,m)); t = Fl_inv(t, p);
923 :
924 1094855 : for (i=m+1; i<lx; i++)
925 : {
926 1000924 : ulong c = ucoeff(x,i,m-1);
927 1000924 : if (!c) continue;
928 :
929 353349 : c = Fl_mul(c,t,p); ucoeff(x,i,m-1) = 0;
930 6576190 : for (j=m; j<lx; j++)
931 6222854 : ucoeff(x,i,j) = Fl_sub(ucoeff(x,i,j), Fl_mul(c,ucoeff(x,m,j), p), p);
932 10881853 : for (j=1; j<lx; j++)
933 10528795 : ucoeff(x,j,m) = Fl_add(ucoeff(x,j,m), Fl_mul(c,ucoeff(x,j,i), p), p);
934 : }
935 : }
936 33843 : return x;
937 : }
938 : GEN
939 785 : FpM_hess(GEN x, GEN p)
940 : {
941 785 : pari_sp av = avma;
942 785 : long lx = lg(x), m, i, j;
943 785 : if (lx == 1) return cgetg(1,t_MAT);
944 785 : if (lgcols(x) != lx) pari_err_DIM("hess");
945 785 : if (lgefint(p) == 3)
946 : {
947 0 : ulong pp = p[2];
948 0 : x = Flm_hess(ZM_to_Flm(x, pp), pp);
949 0 : return gerepileupto(av, Flm_to_ZM(x));
950 : }
951 785 : x = RgM_shallowcopy(x);
952 3368 : for (m=2; m<lx-1; m++)
953 : {
954 2583 : GEN t = NULL;
955 5488 : for (i=m+1; i<lx; i++) { t = gcoeff(x,i,m-1); if (signe(t)) break; }
956 2583 : if (i == lx) continue;
957 12047 : for (j=m-1; j<lx; j++) swap(gcoeff(x,i,j), gcoeff(x,m,j));
958 1897 : swap(gel(x,i), gel(x,m)); t = Fp_inv(t, p);
959 :
960 8253 : for (i=m+1; i<lx; i++)
961 : {
962 6356 : GEN c = gcoeff(x,i,m-1);
963 6356 : if (!signe(c)) continue;
964 :
965 5061 : c = Fp_mul(c,t, p); gcoeff(x,i,m-1) = gen_0;
966 29785 : for (j=m; j<lx; j++)
967 24724 : gcoeff(x,i,j) = Fp_sub(gcoeff(x,i,j), Fp_mul(c,gcoeff(x,m,j),p), p);
968 45465 : for (j=1; j<lx; j++)
969 40404 : gcoeff(x,j,m) = Fp_add(gcoeff(x,j,m), Fp_mul(c,gcoeff(x,j,i),p), p);
970 5061 : if (gc_needed(av,2))
971 : {
972 0 : if (DEBUGMEM>1) pari_warn(warnmem,"hess, m = %ld", m);
973 0 : gerepileall(av,2, &x, &t);
974 : }
975 : }
976 : }
977 785 : return gerepilecopy(av,x);
978 : }
979 : /* H in Hessenberg form */
980 : static GEN
981 161 : RgM_hess_charpoly(GEN H, long v)
982 : {
983 161 : long n = lg(H), r, i;
984 161 : GEN y = cgetg(n+1, t_VEC);
985 161 : gel(y,1) = pol_1(v);
986 945 : for (r = 1; r < n; r++)
987 : {
988 784 : pari_sp av2 = avma;
989 784 : GEN z, a = gen_1, b = pol_0(v);
990 4690 : for (i = r-1; i; i--)
991 : {
992 3983 : a = gmul(a, gcoeff(H,i+1,i));
993 3983 : if (gequal0(a)) break;
994 3906 : b = RgX_add(b, RgX_Rg_mul(gel(y,i), gmul(a,gcoeff(H,i,r))));
995 : }
996 784 : z = RgX_sub(RgX_shift_shallow(gel(y,r), 1),
997 784 : RgX_Rg_mul(gel(y,r), gcoeff(H,r,r)));
998 784 : gel(y,r+1) = gerepileupto(av2, RgX_sub(z, b)); /* (X - H[r,r])y[r] - b */
999 : }
1000 161 : return gel(y,n);
1001 : }
1002 : GEN
1003 161 : carhess(GEN x, long v)
1004 : {
1005 : pari_sp av;
1006 : GEN y;
1007 161 : if ((y = easychar(x,v))) return y;
1008 161 : av = avma; y = RgM_hess_charpoly(hess(x), v);
1009 161 : return fix_pol(av, y);
1010 : }
1011 :
1012 : /* Bound for sup norm of charpoly(M/dM), M integral: let B = |M|oo / |dM|,
1013 : * s = max_k binomial(n,k) (kB^2)^(k/2),
1014 : * return ceil(log2(s)) */
1015 : static long
1016 3833 : charpoly_bound(GEN M, GEN dM, GEN N)
1017 : {
1018 3833 : pari_sp av = avma;
1019 3833 : GEN B = itor(N, LOWDEFAULTPREC);
1020 3833 : GEN s = real_0(LOWDEFAULTPREC), bin, B2;
1021 3833 : long n = lg(M)-1, k;
1022 3833 : bin = gen_1;
1023 3833 : if (dM) B = divri(B, dM);
1024 3833 : B2 = sqrr(B);
1025 17348 : for (k = n; k >= (n+1)>>1; k--)
1026 : {
1027 13515 : GEN t = mulri(powruhalf(mulur(k, B2), k), bin);
1028 13515 : if (abscmprr(t, s) > 0) s = t;
1029 13515 : bin = diviuexact(muliu(bin, k), n-k+1);
1030 : }
1031 3833 : return gc_long(av, ceil(dbllog2(s)));
1032 : }
1033 :
1034 : static GEN
1035 4250 : QM_charpoly_ZX_slice(GEN A, GEN dM, GEN P, GEN *mod)
1036 : {
1037 4250 : pari_sp av = avma;
1038 4250 : long i, n = lg(P)-1;
1039 : GEN H, T;
1040 4250 : if (n == 1)
1041 : {
1042 3511 : ulong p = uel(P,1), dp = dM ? umodiu(dM, p): 1;
1043 3511 : GEN Hp, a = ZM_to_Flm(A, p);
1044 3511 : Hp = Flm_charpoly_i(a, p);
1045 3511 : if (dp != 1) Hp = Flx_rescale(Hp, Fl_inv(dp, p), p);
1046 3511 : Hp = gerepileupto(av, Flx_to_ZX(Hp));
1047 3511 : *mod = utoipos(p); return Hp;
1048 : }
1049 739 : T = ZV_producttree(P);
1050 739 : A = ZM_nv_mod_tree(A, P, T);
1051 739 : H = cgetg(n+1, t_VEC);
1052 2890 : for(i=1; i <= n; i++)
1053 : {
1054 2151 : ulong p = uel(P,i), dp = dM ? umodiu(dM, p): 1;
1055 2151 : gel(H,i) = Flm_charpoly(gel(A, i), p);
1056 2151 : if (dp != 1) gel(H,i) = Flx_rescale(gel(H,i), Fl_inv(dp, p), p);
1057 : }
1058 739 : H = nxV_chinese_center_tree(H, P, T, ZV_chinesetree(P,T));
1059 739 : *mod = gmael(T, lg(T)-1, 1); return gc_all(av, 2, &H, mod);
1060 : }
1061 :
1062 : GEN
1063 4250 : QM_charpoly_ZX_worker(GEN P, GEN M, GEN dM)
1064 : {
1065 4250 : GEN V = cgetg(3, t_VEC);
1066 4250 : gel(V,1) = QM_charpoly_ZX_slice(M, equali1(dM) ? NULL:dM, P, &gel(V,2));
1067 4250 : return V;
1068 : }
1069 :
1070 : /* Assume M a square ZM, dM integer. Return charpoly(M / dM) in Z[X] */
1071 : static GEN
1072 4428 : QM_charpoly_ZX_i(GEN M, GEN dM, long bound)
1073 : {
1074 4428 : long n = lg(M)-1;
1075 : forprime_t S;
1076 4428 : GEN worker = snm_closure(is_entry("_QM_charpoly_ZX_worker"),
1077 : mkvec2(M, dM? dM: gen_1));
1078 4428 : if (!n) return pol_1(0);
1079 4428 : if (bound < 0)
1080 : {
1081 4162 : GEN N = ZM_supnorm(M);
1082 4162 : if (signe(N) == 0) return monomial(gen_1, n, 0);
1083 3833 : bound = charpoly_bound(M, dM, N) + 1;
1084 : }
1085 4099 : if (DEBUGLEVEL>5) err_printf("ZM_charpoly: bound 2^%ld\n", bound);
1086 4099 : init_modular_big(&S);
1087 4099 : return gen_crt("QM_charpoly_ZX", worker, &S, dM, bound, 0, NULL,
1088 : nxV_chinese_center, FpX_center);
1089 : }
1090 :
1091 : GEN
1092 266 : QM_charpoly_ZX_bound(GEN M, long bit)
1093 : {
1094 266 : pari_sp av = avma;
1095 266 : GEN dM; M = Q_remove_denom(M, &dM);
1096 266 : return gerepilecopy(av, QM_charpoly_ZX_i(M, dM, bit));
1097 : }
1098 : GEN
1099 1834 : QM_charpoly_ZX(GEN M)
1100 : {
1101 1834 : pari_sp av = avma;
1102 1834 : GEN dM; M = Q_remove_denom(M, &dM);
1103 1834 : return gerepilecopy(av, QM_charpoly_ZX_i(M, dM, -1));
1104 : }
1105 : GEN
1106 2328 : ZM_charpoly(GEN M)
1107 : {
1108 2328 : pari_sp av = avma;
1109 2328 : return gerepilecopy(av, QM_charpoly_ZX_i(M, NULL, -1));
1110 : }
1111 :
1112 : /*******************************************************************/
1113 : /* */
1114 : /* CHARACTERISTIC POLYNOMIAL (BERKOWITZ'S ALGORITHM) */
1115 : /* */
1116 : /*******************************************************************/
1117 : GEN
1118 1722 : carberkowitz(GEN x, long v)
1119 : {
1120 : long lx, i, j, k, r;
1121 : GEN V, S, C, Q;
1122 : pari_sp av0, av;
1123 1722 : if ((V = easychar(x,v))) return V;
1124 1722 : lx = lg(x); av0 = avma;
1125 1722 : V = cgetg(lx+1, t_VEC);
1126 1722 : S = cgetg(lx+1, t_VEC);
1127 1722 : C = cgetg(lx+1, t_VEC);
1128 1722 : Q = cgetg(lx+1, t_VEC);
1129 1722 : av = avma;
1130 1722 : gel(C,1) = gen_m1;
1131 1722 : gel(V,1) = gen_m1;
1132 12285 : for (i=2;i<=lx; i++) gel(C,i) = gel(Q,i) = gel(S,i) = gel(V,i) = gen_0;
1133 1722 : gel(V,2) = gcoeff(x,1,1);
1134 10563 : for (r = 2; r < lx; r++)
1135 : {
1136 : pari_sp av2;
1137 : GEN t;
1138 :
1139 69664 : for (i = 1; i < r; i++) gel(S,i) = gcoeff(x,i,r);
1140 8841 : gel(C,2) = gcoeff(x,r,r);
1141 60823 : for (i = 1; i < r-1; i++)
1142 : {
1143 51982 : av2 = avma; t = gmul(gcoeff(x,r,1), gel(S,1));
1144 760648 : for (j = 2; j < r; j++) t = gadd(t, gmul(gcoeff(x,r,j), gel(S,j)));
1145 51982 : gel(C,i+2) = gerepileupto(av2, t);
1146 812630 : for (j = 1; j < r; j++)
1147 : {
1148 760648 : av2 = avma; t = gmul(gcoeff(x,j,1), gel(S,1));
1149 15034292 : for (k = 2; k < r; k++) t = gadd(t, gmul(gcoeff(x,j,k), gel(S,k)));
1150 760648 : gel(Q,j) = gerepileupto(av2, t);
1151 : }
1152 812630 : for (j = 1; j < r; j++) gel(S,j) = gel(Q,j);
1153 : }
1154 8841 : av2 = avma; t = gmul(gcoeff(x,r,1), gel(S,1));
1155 60823 : for (j = 2; j < r; j++) t = gadd(t, gmul(gcoeff(x,r,j), gel(S,j)));
1156 8841 : gel(C,r+1) = gerepileupto(av2, t);
1157 8841 : if (gc_needed(av0,1))
1158 : {
1159 0 : if (DEBUGMEM>1) pari_warn(warnmem,"carberkowitz");
1160 0 : gerepileall(av, 2, &C, &V);
1161 : }
1162 87346 : for (i = 1; i <= r+1; i++)
1163 : {
1164 78505 : av2 = avma; t = gmul(gel(C,i), gel(V,1));
1165 580475 : for (j = 2; j <= minss(r,i); j++)
1166 501970 : t = gadd(t, gmul(gel(C,i+1-j), gel(V,j)));
1167 78505 : gel(Q,i) = gerepileupto(av2, t);
1168 : }
1169 87346 : for (i = 1; i <= r+1; i++) gel(V,i) = gel(Q,i);
1170 : }
1171 1722 : V = RgV_to_RgX_reverse(V, v); /* not gtopoly: fail if v > gvar(V) */
1172 1722 : V = odd(lx)? gcopy(V): RgX_neg(V);
1173 1722 : return fix_pol(av0, V);
1174 : }
1175 :
1176 : /*******************************************************************/
1177 : /* */
1178 : /* NORMS */
1179 : /* */
1180 : /*******************************************************************/
1181 : GEN
1182 3539033 : gnorm(GEN x)
1183 : {
1184 : pari_sp av;
1185 3539033 : switch(typ(x))
1186 : {
1187 47720 : case t_INT: return sqri(x);
1188 537810 : case t_REAL: return sqrr(x);
1189 1393 : case t_FRAC: return sqrfrac(x);
1190 2878834 : case t_COMPLEX: av = avma; return gerepileupto(av, cxnorm(x));
1191 69055 : case t_QUAD: av = avma; return gerepileupto(av, quadnorm(x));
1192 :
1193 14 : case t_POL: case t_SER: case t_RFRAC: av = avma;
1194 14 : return gerepileupto(av, greal(gmul(conj_i(x),x)));
1195 :
1196 28 : case t_FFELT:
1197 28 : retmkintmod(FF_norm(x), FF_p(x));
1198 :
1199 4179 : case t_POLMOD:
1200 : {
1201 4179 : GEN T = gel(x,1), a = gel(x,2);
1202 4179 : if (typ(a) != t_POL || varn(a) != varn(T)) return gpowgs(a, degpol(T));
1203 3997 : return RgXQ_norm(a, T);
1204 : }
1205 0 : case t_VEC: case t_COL: case t_MAT:
1206 0 : pari_APPLY_same(gnorm(gel(x,i)));
1207 : }
1208 0 : pari_err_TYPE("gnorm",x);
1209 : return NULL; /* LCOV_EXCL_LINE */
1210 : }
1211 :
1212 : /* return |q|^2, complex modulus */
1213 : static GEN
1214 28 : cxquadnorm(GEN q, long prec)
1215 : {
1216 28 : GEN X = gel(q,1), c = gel(X,2); /* (1-D)/4, -D/4 */
1217 28 : if (signe(c) > 0) return quadnorm(q); /* imaginary */
1218 21 : if (!prec) pari_err_TYPE("gnorml2", q);
1219 7 : return sqrr(quadtofp(q, prec));
1220 : }
1221 :
1222 : static GEN
1223 36599049 : gnorml2_i(GEN x, long prec)
1224 : {
1225 : pari_sp av;
1226 : long i, lx;
1227 : GEN s;
1228 :
1229 36599049 : switch(typ(x))
1230 : {
1231 1335941 : case t_INT: return sqri(x);
1232 26509144 : case t_REAL: return sqrr(x);
1233 7 : case t_FRAC: return sqrfrac(x);
1234 4149648 : case t_COMPLEX: av = avma; return gerepileupto(av, cxnorm(x));
1235 21 : case t_QUAD: av = avma; return gerepileupto(av, cxquadnorm(x,prec));
1236 :
1237 60451 : case t_POL: lx = lg(x)-1; x++; break;
1238 :
1239 4546306 : case t_VEC:
1240 : case t_COL:
1241 4546306 : case t_MAT: lx = lg(x); break;
1242 :
1243 0 : default: pari_err_TYPE("gnorml2",x);
1244 : return NULL; /* LCOV_EXCL_LINE */
1245 : }
1246 4606757 : if (lx == 1) return gen_0;
1247 4606757 : av = avma;
1248 4606757 : s = gnorml2(gel(x,1));
1249 32105781 : for (i=2; i<lx; i++)
1250 : {
1251 27499658 : s = gadd(s, gnorml2(gel(x,i)));
1252 27499154 : if (gc_needed(av,1))
1253 : {
1254 0 : if (DEBUGMEM>1) pari_warn(warnmem,"gnorml2");
1255 0 : s = gerepileupto(av, s);
1256 : }
1257 : }
1258 4606123 : return gerepileupto(av,s);
1259 : }
1260 : GEN
1261 36598549 : gnorml2(GEN x) { return gnorml2_i(x, 0); }
1262 :
1263 : static GEN pnormlp(GEN,GEN,long);
1264 : static GEN
1265 63 : pnormlpvec(long i0, GEN x, GEN p, long prec)
1266 : {
1267 63 : pari_sp av = avma;
1268 63 : long i, lx = lg(x);
1269 63 : GEN s = gen_0;
1270 224 : for (i=i0; i<lx; i++)
1271 : {
1272 161 : s = gadd(s, pnormlp(gel(x,i),p,prec));
1273 161 : if (gc_needed(av,1))
1274 : {
1275 0 : if (DEBUGMEM>1) pari_warn(warnmem,"gnormlp, i = %ld", i);
1276 0 : s = gerepileupto(av, s);
1277 : }
1278 : }
1279 63 : return s;
1280 : }
1281 : /* (||x||_p)^p */
1282 : static GEN
1283 196 : pnormlp(GEN x, GEN p, long prec)
1284 : {
1285 196 : switch(typ(x))
1286 : {
1287 119 : case t_INT: case t_REAL: x = mpabs(x); break;
1288 0 : case t_FRAC: x = absfrac(x); break;
1289 14 : case t_COMPLEX: case t_QUAD: x = gabs(x,prec); break;
1290 7 : case t_POL: return pnormlpvec(2, x, p, prec);
1291 56 : case t_VEC: case t_COL: case t_MAT: return pnormlpvec(1, x, p, prec);
1292 0 : default: pari_err_TYPE("gnormlp",x);
1293 : }
1294 133 : return gpow(x, p, prec);
1295 : }
1296 :
1297 : GEN
1298 357 : gnormlp(GEN x, GEN p, long prec)
1299 : {
1300 357 : pari_sp av = avma;
1301 357 : if (!p || (typ(p) == t_INFINITY && inf_get_sign(p) > 0))
1302 196 : return gsupnorm(x, prec);
1303 161 : if (gsigne(p) <= 0) pari_err_DOMAIN("normlp", "p", "<=", gen_0, p);
1304 154 : if (is_scalar_t(typ(x))) return gabs(x, prec);
1305 91 : if (typ(p) == t_INT)
1306 : {
1307 63 : ulong pp = itou_or_0(p);
1308 63 : switch(pp)
1309 : {
1310 28 : case 1: return gnorml1(x, prec);
1311 28 : case 2: x = gnorml2_i(x, prec); break;
1312 7 : default: x = pnormlp(x, p, prec); break;
1313 : }
1314 35 : if (pp && typ(x) == t_INT && Z_ispowerall(x, pp, &x))
1315 7 : return gerepileuptoleaf(av, x);
1316 28 : if (pp == 2) return gerepileupto(av, gsqrt(x, prec));
1317 : }
1318 : else
1319 28 : x = pnormlp(x, p, prec);
1320 28 : x = gpow(x, ginv(p), prec);
1321 28 : return gerepileupto(av, x);
1322 : }
1323 :
1324 : GEN
1325 168 : gnorml1(GEN x,long prec)
1326 : {
1327 168 : pari_sp av = avma;
1328 : long lx,i;
1329 : GEN s;
1330 168 : switch(typ(x))
1331 : {
1332 98 : case t_INT: case t_REAL: return mpabs(x);
1333 0 : case t_FRAC: return absfrac(x);
1334 :
1335 14 : case t_COMPLEX: case t_QUAD:
1336 14 : return gabs(x,prec);
1337 :
1338 7 : case t_POL:
1339 7 : lx = lg(x); s = gen_0;
1340 28 : for (i=2; i<lx; i++) s = gadd(s, gnorml1(gel(x,i),prec));
1341 7 : break;
1342 :
1343 49 : case t_VEC: case t_COL: case t_MAT:
1344 49 : lx = lg(x); s = gen_0;
1345 168 : for (i=1; i<lx; i++) s = gadd(s, gnorml1(gel(x,i),prec));
1346 49 : break;
1347 :
1348 0 : default: pari_err_TYPE("gnorml1",x);
1349 : return NULL; /* LCOV_EXCL_LINE */
1350 : }
1351 56 : return gerepileupto(av, s);
1352 : }
1353 : /* As gnorml1, except for t_QUAD and t_COMPLEX: |x + wy| := |x| + |y|
1354 : * Still a norm of R-vector spaces, and can be cheaply computed without
1355 : * square roots */
1356 : GEN
1357 142765 : gnorml1_fake(GEN x)
1358 : {
1359 142765 : pari_sp av = avma;
1360 : long lx, i;
1361 : GEN s;
1362 142765 : switch(typ(x))
1363 : {
1364 126994 : case t_INT: case t_REAL: return mpabs(x);
1365 0 : case t_FRAC: return absfrac(x);
1366 :
1367 0 : case t_COMPLEX:
1368 0 : s = gadd(gnorml1_fake(gel(x,1)), gnorml1_fake(gel(x,2)));
1369 0 : break;
1370 0 : case t_QUAD:
1371 0 : s = gadd(gnorml1_fake(gel(x,2)), gnorml1_fake(gel(x,3)));
1372 0 : break;
1373 :
1374 15771 : case t_POL:
1375 15771 : lx = lg(x); s = gen_0;
1376 102893 : for (i=2; i<lx; i++) s = gadd(s, gnorml1_fake(gel(x,i)));
1377 15771 : break;
1378 :
1379 0 : case t_VEC: case t_COL: case t_MAT:
1380 0 : lx = lg(x); s = gen_0;
1381 0 : for (i=1; i<lx; i++) s = gadd(s, gnorml1_fake(gel(x,i)));
1382 0 : break;
1383 :
1384 0 : default: pari_err_TYPE("gnorml1_fake",x);
1385 : return NULL; /* LCOV_EXCL_LINE */
1386 : }
1387 15771 : return gerepileupto(av, s);
1388 : }
1389 :
1390 : static void
1391 29190794 : store(GEN z, GEN *m) { if (!*m || gcmp(z, *m) > 0) *m = z; }
1392 : /* compare |x| to *m or |x|^2 to *msq, whichever is easiest, and update
1393 : * the pointed value if x is larger */
1394 : void
1395 35140033 : gsupnorm_aux(GEN x, GEN *m, GEN *msq, long prec)
1396 : {
1397 : long i, lx;
1398 : GEN z;
1399 35140033 : switch(typ(x))
1400 : {
1401 92555 : case t_COMPLEX: z = cxnorm(x); store(z, msq); return;
1402 7 : case t_QUAD: z = cxquadnorm(x,prec); store(z, msq); return;
1403 29098204 : case t_INT: case t_REAL: z = mpabs(x); store(z,m); return;
1404 35 : case t_FRAC: z = absfrac(x); store(z,m); return;
1405 :
1406 81049 : case t_POL: lx = lg(x)-1; x++; break;
1407 :
1408 5868256 : case t_VEC:
1409 : case t_COL:
1410 5868256 : case t_MAT: lx = lg(x); break;
1411 :
1412 0 : default: pari_err_TYPE("gsupnorm",x);
1413 : return; /* LCOV_EXCL_LINE */
1414 : }
1415 39860286 : for (i=1; i<lx; i++) gsupnorm_aux(gel(x,i), m, msq, prec);
1416 : }
1417 : GEN
1418 1229045 : gsupnorm(GEN x, long prec)
1419 : {
1420 1229045 : GEN m = NULL, msq = NULL;
1421 1229045 : pari_sp av = avma;
1422 1229045 : gsupnorm_aux(x, &m, &msq, prec);
1423 : /* now set m = max (m, sqrt(msq)) */
1424 1229049 : if (msq) {
1425 15130 : msq = gsqrt(msq, prec);
1426 15129 : if (!m || gcmp(m, msq) < 0) m = msq;
1427 1213919 : } else if (!m) m = gen_0;
1428 1229048 : return gerepilecopy(av, m);
1429 : }
1430 :
1431 : /*******************************************************************/
1432 : /* */
1433 : /* TRACES */
1434 : /* */
1435 : /*******************************************************************/
1436 : GEN
1437 35 : matcompanion(GEN x)
1438 : {
1439 35 : long n = degpol(x), j;
1440 : GEN y, c;
1441 :
1442 35 : if (typ(x)!=t_POL) pari_err_TYPE("matcompanion",x);
1443 35 : if (!signe(x)) pari_err_DOMAIN("matcompanion","polynomial","=",gen_0,x);
1444 28 : if (n == 0) return cgetg(1, t_MAT);
1445 :
1446 28 : y = cgetg(n+1,t_MAT);
1447 105 : for (j=1; j < n; j++) gel(y,j) = col_ei(n, j+1);
1448 28 : c = cgetg(n+1,t_COL); gel(y,n) = c;
1449 28 : if (gequal1(gel(x, n+2)))
1450 112 : for (j=1; j<=n; j++) gel(c,j) = gneg(gel(x,j+1));
1451 : else
1452 : { /* not monic. Hardly ever used */
1453 7 : pari_sp av = avma;
1454 7 : GEN d = gclone(gneg(gel(x,n+2)));
1455 7 : set_avma(av);
1456 21 : for (j=1; j<=n; j++) gel(c,j) = gdiv(gel(x,j+1), d);
1457 7 : gunclone(d);
1458 : }
1459 28 : return y;
1460 : }
1461 :
1462 : GEN
1463 761512 : gtrace(GEN x)
1464 : {
1465 : pari_sp av;
1466 761512 : long lx, tx = typ(x);
1467 : GEN y, z;
1468 :
1469 761512 : switch(tx)
1470 : {
1471 23624 : case t_INT: case t_REAL: case t_FRAC:
1472 23624 : return gmul2n(x,1);
1473 :
1474 735053 : case t_COMPLEX:
1475 735053 : return gmul2n(gel(x,1),1);
1476 :
1477 154 : case t_QUAD:
1478 154 : y = gel(x,1);
1479 154 : if (!gequal0(gel(y,3)))
1480 : { /* assume quad. polynomial is either x^2 + d or x^2 - x + d */
1481 154 : av = avma;
1482 154 : return gerepileupto(av, gadd(gel(x,3), gmul2n(gel(x,2),1)));
1483 : }
1484 0 : return gmul2n(gel(x,2),1);
1485 :
1486 7 : case t_POL:
1487 21 : pari_APPLY_pol(gtrace(gel(x,i)));
1488 14 : case t_SER:
1489 14 : if (ser_isexactzero(x)) return gcopy(x);
1490 21 : pari_APPLY_ser(gtrace(gel(x,i)));
1491 :
1492 777 : case t_POLMOD:
1493 777 : y = gel(x,1); z = gel(x,2);
1494 777 : if (typ(z) != t_POL || varn(y) != varn(z)) return gmulsg(degpol(y), z);
1495 476 : av = avma;
1496 476 : return gerepileupto(av, RgXQ_trace(z, y));
1497 :
1498 28 : case t_FFELT:
1499 28 : retmkintmod(FF_trace(x), FF_p(x));
1500 :
1501 7 : case t_RFRAC:
1502 7 : av = avma; return gerepileupto(av, gadd(x, conj_i(x)));
1503 :
1504 0 : case t_VEC: case t_COL:
1505 0 : pari_APPLY_same(gtrace(gel(x,i)));
1506 :
1507 1848 : case t_MAT:
1508 1848 : lx = lg(x); if (lx == 1) return gen_0;
1509 : /*now lx >= 2*/
1510 1841 : if (lx != lgcols(x)) pari_err_DIM("gtrace");
1511 1834 : av = avma; return gerepileupto(av, mattrace(x));
1512 : }
1513 0 : pari_err_TYPE("gtrace",x);
1514 : return NULL; /* LCOV_EXCL_LINE */
1515 : }
1516 :
1517 : /* Cholesky decomposition for positive definite matrix a
1518 : * [GTM138, Algo 2.7.6, matrix Q]
1519 : * If a is not positive definite return NULL. */
1520 : GEN
1521 69820 : qfgaussred_positive(GEN a)
1522 : {
1523 69820 : pari_sp av = avma;
1524 : GEN b;
1525 69820 : long i,j,k, n = lg(a);
1526 :
1527 69820 : if (typ(a)!=t_MAT) pari_err_TYPE("qfgaussred_positive",a);
1528 69820 : if (n == 1) return cgetg(1, t_MAT);
1529 69813 : if (lgcols(a)!=n) pari_err_DIM("qfgaussred_positive");
1530 69813 : b = cgetg(n,t_MAT);
1531 369540 : for (j=1; j<n; j++)
1532 : {
1533 299727 : GEN p1=cgetg(n,t_COL), p2=gel(a,j);
1534 :
1535 299727 : gel(b,j) = p1;
1536 1513628 : for (i=1; i<=j; i++) gel(p1,i) = gel(p2,i);
1537 1213901 : for ( ; i<n ; i++) gel(p1,i) = gen_0;
1538 : }
1539 363760 : for (k=1; k<n; k++)
1540 : {
1541 296380 : GEN bk, p = gcoeff(b,k,k), invp;
1542 296380 : if (gsigne(p)<=0) return gc_NULL(av); /* not positive definite */
1543 293946 : invp = ginv(p);
1544 293943 : bk = row(b, k);
1545 1193671 : for (i=k+1; i<n; i++) gcoeff(b,k,i) = gmul(gel(bk,i), invp);
1546 1193667 : for (i=k+1; i<n; i++)
1547 : {
1548 899727 : GEN c = gel(bk, i);
1549 5558399 : for (j=i; j<n; j++)
1550 4658678 : gcoeff(b,i,j) = gsub(gcoeff(b,i,j), gmul(c,gcoeff(b,k,j)));
1551 : }
1552 293940 : if (gc_needed(av,1))
1553 : {
1554 0 : if (DEBUGMEM>1) pari_warn(warnmem,"qfgaussred_positive");
1555 0 : b=gerepilecopy(av,b);
1556 : }
1557 : }
1558 67380 : return gerepilecopy(av,b);
1559 : }
1560 :
1561 : GEN
1562 68464 : RgM_Cholesky(GEN M, long prec)
1563 : {
1564 68464 : pari_sp av = avma;
1565 68464 : long i, j, lM = lg(M);
1566 68464 : GEN R, L = qfgaussred_positive(M);
1567 68465 : if (!L) return gc_NULL(av);
1568 338599 : R = cgetg(lM, t_MAT); for (j = 1; j < lM; j++) gel(R,j) = cgetg(lM, t_COL);
1569 338582 : for (i = 1; i < lM; i++)
1570 : {
1571 272568 : GEN r = gsqrt(gcoeff(L,i,i), prec);
1572 2027801 : for (j = 1; j < lM; j++)
1573 1755250 : gcoeff(R, i, j) = (i == j) ? r: gmul(r, gcoeff(L, i, j));
1574 : }
1575 66014 : return gerepileupto(av, R);
1576 : }
1577 :
1578 : /* Maximal pivot strategy: x is a suitable pivot if it is non zero and either
1579 : * - an exact type, or
1580 : * - it is maximal among remaining nonzero (t_REAL) pivots */
1581 : static int
1582 47429 : suitable(GEN x, long k, GEN *pp, long *pi)
1583 : {
1584 47429 : long t = typ(x);
1585 47429 : switch(t)
1586 : {
1587 24785 : case t_INT: return signe(x) != 0;
1588 22490 : case t_FRAC: return 1;
1589 154 : case t_REAL: {
1590 154 : GEN p = *pp;
1591 154 : if (signe(x) && (!p || abscmprr(p, x) < 0)) { *pp = x; *pi = k; }
1592 154 : return 0;
1593 : }
1594 0 : default: return !gequal0(x);
1595 : }
1596 : }
1597 :
1598 : /* Gauss reduction (arbitrary symmetric matrix, only the part above the
1599 : * diagonal is considered). If signature is nonzero, return only the
1600 : * signature, in which case gsigne() should be defined for elements of a. */
1601 : static GEN
1602 12200 : gaussred(GEN a, long signature)
1603 : {
1604 : GEN r, ak, al;
1605 12200 : pari_sp av = avma, av1;
1606 12200 : long n = lg(a), i, j, k, l, sp, sn, t;
1607 :
1608 12200 : if (typ(a) != t_MAT) pari_err_TYPE("gaussred",a);
1609 12200 : if (n == 1) return signature? mkvec2(gen_0, gen_0): cgetg(1, t_MAT);
1610 12200 : if (lgcols(a) != n) pari_err_DIM("gaussred");
1611 12200 : n--;
1612 12200 : r = const_vecsmall(n, 1); av1= avma;
1613 12200 : a = RgM_shallowcopy(a);
1614 12200 : t = n; sp = sn = 0;
1615 59461 : while (t)
1616 : {
1617 47261 : long pind = 0;
1618 47261 : GEN invp, p = NULL;
1619 130579 : k=1; while (k<=n && (!r[k] || !suitable(gcoeff(a,k,k), k, &p, &pind))) k++;
1620 47261 : if (k > n && p) k = pind;
1621 47261 : if (k <= n)
1622 : {
1623 47247 : p = gcoeff(a,k,k); invp = ginv(p); /* != 0 */
1624 47247 : if (signature) { /* skip if (!signature): gsigne may fail ! */
1625 47184 : if (gsigne(p) > 0) sp++; else sn++;
1626 : }
1627 47247 : r[k] = 0; t--;
1628 47247 : ak = row(a, k);
1629 260654 : for (i=1; i<=n; i++)
1630 213407 : gcoeff(a,k,i) = r[i]? gmul(gcoeff(a,k,i), invp): gen_0;
1631 :
1632 260654 : for (i=1; i<=n; i++) if (r[i])
1633 : {
1634 83052 : GEN c = gel(ak,i); /* - p * a[k,i] */
1635 83052 : if (gequal0(c)) continue;
1636 462136 : for (j=1; j<=n; j++) if (r[j])
1637 244348 : gcoeff(a,i,j) = gsub(gcoeff(a,i,j), gmul(c,gcoeff(a,k,j)));
1638 : }
1639 47247 : gcoeff(a,k,k) = p;
1640 47247 : if (gc_needed(av1,1))
1641 : {
1642 0 : if(DEBUGMEM>1) pari_warn(warnmem,"gaussred (t = %ld)", t);
1643 0 : a = gerepilecopy(av1, a);
1644 : }
1645 : }
1646 : else
1647 : { /* all remaining diagonal coeffs are currently 0 */
1648 14 : for (k=1; k<=n; k++) if (r[k])
1649 : {
1650 14 : l=k+1; while (l<=n && (!r[l] || !suitable(gcoeff(a,k,l), l, &p, &pind))) l++;
1651 14 : if (l > n && p) l = pind;
1652 14 : if (l > n) continue;
1653 :
1654 14 : p = gcoeff(a,k,l); invp = ginv(p);
1655 14 : sp++; sn++;
1656 14 : r[k] = r[l] = 0; t -= 2;
1657 14 : ak = row(a, k);
1658 14 : al = row(a, l);
1659 70 : for (i=1; i<=n; i++) if (r[i])
1660 : {
1661 28 : gcoeff(a,k,i) = gmul(gcoeff(a,k,i), invp);
1662 28 : gcoeff(a,l,i) = gmul(gcoeff(a,l,i), invp);
1663 : } else {
1664 28 : gcoeff(a,k,i) = gen_0;
1665 28 : gcoeff(a,l,i) = gen_0;
1666 : }
1667 :
1668 70 : for (i=1; i<=n; i++) if (r[i])
1669 : { /* c = a[k,i] * p, d = a[l,i] * p; */
1670 28 : GEN c = gel(ak,i), d = gel(al,i);
1671 140 : for (j=1; j<=n; j++) if (r[j])
1672 56 : gcoeff(a,i,j) = gsub(gcoeff(a,i,j),
1673 56 : gadd(gmul(gcoeff(a,l,j), c),
1674 56 : gmul(gcoeff(a,k,j), d)));
1675 : }
1676 70 : for (i=1; i<=n; i++) if (r[i])
1677 : {
1678 28 : GEN c = gcoeff(a,k,i), d = gcoeff(a,l,i);
1679 28 : gcoeff(a,k,i) = gadd(c, d);
1680 28 : gcoeff(a,l,i) = gsub(c, d);
1681 : }
1682 14 : gcoeff(a,k,l) = gen_1;
1683 14 : gcoeff(a,l,k) = gen_m1;
1684 14 : gcoeff(a,k,k) = gmul2n(p,-1);
1685 14 : gcoeff(a,l,l) = gneg(gcoeff(a,k,k));
1686 14 : if (gc_needed(av1,1))
1687 : {
1688 0 : if(DEBUGMEM>1) pari_warn(warnmem,"gaussred");
1689 0 : a = gerepilecopy(av1, a);
1690 : }
1691 14 : break;
1692 : }
1693 14 : if (k > n) break;
1694 : }
1695 : }
1696 12200 : if (!signature) return gerepilecopy(av, a);
1697 12179 : set_avma(av); return mkvec2s(sp, sn);
1698 : }
1699 :
1700 : GEN
1701 21 : qfgaussred(GEN a) { return gaussred(a,0); }
1702 :
1703 : GEN
1704 7 : qfgaussred2(GEN a)
1705 : {
1706 7 : pari_sp av = avma;
1707 7 : GEN M = qfgaussred(a);
1708 7 : long i, l = lg(M);
1709 7 : GEN D = cgetg(l, t_VEC);
1710 35 : for (i = 1; i < l; i++)
1711 : {
1712 28 : gel(D,i) = gcoeff(M,i,i);
1713 28 : gcoeff(M,i,i) = gen_1;
1714 : }
1715 7 : return gerepilecopy(av, mkvec2(M,D));
1716 : }
1717 :
1718 : GEN
1719 21 : qfgaussred0(GEN a, long flag)
1720 : {
1721 21 : switch (flag)
1722 : {
1723 14 : case 0: return qfgaussred(a);
1724 7 : case 1: return qfgaussred2(a);
1725 0 : default: pari_err_FLAG("qfgaussred");
1726 : }
1727 : return NULL; /* LCOV_EXCL_LINE */
1728 : }
1729 :
1730 : GEN
1731 14 : qfcholesky(GEN a, long prec)
1732 : {
1733 : GEN M;
1734 14 : long n = lg(a);
1735 14 : if (typ(a) != t_MAT) pari_err_TYPE("qfcholesky",a);
1736 14 : if (n == 1) return cgetg(1, t_MAT);
1737 14 : if (lgcols(a) != lg(a)) pari_err_DIM("qfcholesky");
1738 14 : M = RgM_Cholesky(a, prec);
1739 14 : if (!M) return cgetg(1, t_VEC);
1740 7 : return M;
1741 : }
1742 :
1743 : GEN
1744 12179 : qfsign(GEN a) { return gaussred(a,1); }
1745 :
1746 : /* x -= s(y+u*x) */
1747 : /* y += s(x-u*y), simultaneously */
1748 : static void
1749 19180 : rot(GEN x, GEN y, GEN s, GEN u) {
1750 19180 : GEN x1 = subrr(x, mulrr(s,addrr(y,mulrr(u,x))));
1751 19180 : GEN y1 = addrr(y, mulrr(s,subrr(x,mulrr(u,y))));
1752 19180 : affrr(x1,x);
1753 19180 : affrr(y1,y);
1754 19180 : }
1755 :
1756 : /* Diagonalization of a REAL symmetric matrix. Return a vector [L, r]:
1757 : * L = vector of eigenvalues
1758 : * r = matrix of eigenvectors */
1759 : GEN
1760 28 : jacobi(GEN a, long prec)
1761 : {
1762 : pari_sp av;
1763 28 : long de, e, e1, e2, i, j, p, q, l = lg(a);
1764 : GEN c, ja, L, r, L2, r2, unr;
1765 :
1766 28 : if (typ(a) != t_MAT) pari_err_TYPE("jacobi",a);
1767 28 : ja = cgetg(3,t_VEC);
1768 28 : L = cgetg(l,t_COL); gel(ja,1) = L;
1769 28 : r = cgetg(l,t_MAT); gel(ja,2) = r;
1770 28 : if (l == 1) return ja;
1771 28 : if (lgcols(a) != l) pari_err_DIM("jacobi");
1772 :
1773 28 : e1 = HIGHEXPOBIT-1;
1774 224 : for (j=1; j<l; j++)
1775 : {
1776 196 : GEN z = gtofp(gcoeff(a,j,j), prec);
1777 196 : gel(L,j) = z;
1778 196 : e = expo(z); if (e < e1) e1 = e;
1779 : }
1780 224 : for (j=1; j<l; j++)
1781 : {
1782 196 : gel(r,j) = cgetg(l,t_COL);
1783 1582 : for (i=1; i<l; i++) gcoeff(r,i,j) = utor(i==j? 1: 0, prec);
1784 : }
1785 28 : av = avma;
1786 :
1787 28 : e2 = -(long)HIGHEXPOBIT; p = q = 1;
1788 28 : c = cgetg(l,t_MAT);
1789 224 : for (j=1; j<l; j++)
1790 : {
1791 196 : gel(c,j) = cgetg(j,t_COL);
1792 791 : for (i=1; i<j; i++)
1793 : {
1794 595 : GEN z = gtofp(gcoeff(a,i,j), prec);
1795 595 : gcoeff(c,i,j) = z;
1796 595 : if (!signe(z)) continue;
1797 308 : e = expo(z); if (e > e2) { e2 = e; p = i; q = j; }
1798 : }
1799 : }
1800 28 : a = c; unr = real_1(prec);
1801 28 : de = prec2nbits(prec);
1802 :
1803 : /* e1 = min expo(a[i,i])
1804 : * e2 = max expo(a[i,j]), i != j */
1805 1568 : while (e1-e2 < de)
1806 : {
1807 1540 : pari_sp av2 = avma;
1808 : GEN x, y, t, c, s, u;
1809 : /* compute attached rotation in the plane formed by basis vectors number
1810 : * p and q */
1811 1540 : x = subrr(gel(L,q),gel(L,p));
1812 1540 : if (signe(x))
1813 : {
1814 1512 : x = divrr(x, shiftr(gcoeff(a,p,q),1));
1815 1512 : y = sqrtr(addrr(unr, sqrr(x)));
1816 1512 : t = invr((signe(x)>0)? addrr(x,y): subrr(x,y));
1817 : }
1818 : else
1819 28 : y = t = unr;
1820 1540 : c = sqrtr(addrr(unr,sqrr(t)));
1821 1540 : s = divrr(t,c);
1822 1540 : u = divrr(t,addrr(unr,c));
1823 :
1824 : /* compute successive transforms of a and the matrix of accumulated
1825 : * rotations (r) */
1826 4144 : for (i=1; i<p; i++) rot(gcoeff(a,i,p), gcoeff(a,i,q), s,u);
1827 4039 : for (i=p+1; i<q; i++) rot(gcoeff(a,p,i), gcoeff(a,i,q), s,u);
1828 4487 : for (i=q+1; i<l; i++) rot(gcoeff(a,p,i), gcoeff(a,q,i), s,u);
1829 1540 : y = gcoeff(a,p,q);
1830 1540 : t = mulrr(t, y); shiftr_inplace(y, -de - 1);
1831 1540 : x = gel(L,p); subrrz(x,t, x);
1832 1540 : y = gel(L,q); addrrz(y,t, y);
1833 12670 : for (i=1; i<l; i++) rot(gcoeff(r,i,p), gcoeff(r,i,q), s,u);
1834 :
1835 1540 : e2 = -(long)HIGHEXPOBIT; p = q = 1;
1836 12670 : for (j=1; j<l; j++)
1837 : {
1838 46396 : for (i=1; i<j; i++)
1839 : {
1840 35266 : GEN z = gcoeff(a,i,j);
1841 35266 : if (!signe(z)) continue;
1842 31080 : e = expo(z); if (e > e2) { e2=e; p=i; q=j; }
1843 : }
1844 46396 : for (i=j+1; i<l; i++)
1845 : {
1846 35266 : GEN z = gcoeff(a,j,i);
1847 35266 : if (!signe(z)) continue;
1848 31080 : e = expo(z); if (e > e2) { e2=e; p=j; q=i; }
1849 : }
1850 : }
1851 1540 : set_avma(av2);
1852 : }
1853 : /* sort eigenvalues from smallest to largest */
1854 28 : c = indexsort(L);
1855 224 : r2 = vecpermute(r, c); for (i=1; i<l; i++) gel(r,i) = gel(r2,i);
1856 224 : L2 = vecpermute(L, c); for (i=1; i<l; i++) gel(L,i) = gel(L2,i);
1857 28 : set_avma(av); return ja;
1858 : }
1859 :
1860 : /*************************************************************************/
1861 : /** **/
1862 : /** Q-vector space -> Z-modules **/
1863 : /** **/
1864 : /*************************************************************************/
1865 :
1866 : GEN
1867 133 : matrixqz0(GEN x,GEN p)
1868 : {
1869 133 : if (typ(x) != t_MAT) pari_err_TYPE("matrixqz",x);
1870 133 : if (!p) return QM_minors_coprime(x,NULL);
1871 98 : if (typ(p) != t_INT) pari_err_TYPE("matrixqz",p);
1872 98 : if (signe(p)>=0) return QM_minors_coprime(x,p);
1873 91 : if (!RgM_is_QM(x)) pari_err_TYPE("matrixqz", x);
1874 91 : if (absequaliu(p,1)) return QM_ImZ(x); /* p = -1 */
1875 63 : if (absequaliu(p,2)) return QM_ImQ(x); /* p = -2 */
1876 7 : pari_err_FLAG("QM_minors_coprime");
1877 : return NULL; /* LCOV_EXCL_LINE */
1878 : }
1879 :
1880 : GEN
1881 42 : QM_minors_coprime(GEN x, GEN D)
1882 : {
1883 42 : pari_sp av = avma, av1;
1884 : long i, j, m, n, lP;
1885 : GEN P, y;
1886 :
1887 42 : n = lg(x)-1; if (!n) return gcopy(x);
1888 42 : m = nbrows(x);
1889 42 : if (n > m) pari_err_DOMAIN("QM_minors_coprime","n",">",strtoGENstr("m"),x);
1890 35 : y = x; x = cgetg(n+1,t_MAT);
1891 112 : for (j=1; j<=n; j++)
1892 : {
1893 77 : gel(x,j) = Q_primpart(gel(y,j));
1894 77 : RgV_check_ZV(gel(x,j), "QM_minors_coprime");
1895 : }
1896 : /* x now a ZM */
1897 35 : if (n==m)
1898 : {
1899 21 : if (gequal0(ZM_det(x)))
1900 14 : pari_err_DOMAIN("QM_minors_coprime", "rank(A)", "<",stoi(n),x);
1901 7 : set_avma(av); return matid(n);
1902 : }
1903 : /* m > n */
1904 14 : if (!D || gequal0(D))
1905 : {
1906 14 : pari_sp av2 = avma;
1907 14 : D = ZM_detmult(shallowtrans(x));
1908 14 : if (is_pm1(D)) { set_avma(av2); return ZM_copy(x); }
1909 : }
1910 14 : P = gel(Z_factor(D), 1); lP = lg(P);
1911 14 : av1 = avma;
1912 56 : for (i=1; i < lP; i++)
1913 : {
1914 42 : GEN p = gel(P,i), pov2 = shifti(p, -1);
1915 : for(;;)
1916 42 : {
1917 84 : GEN N, M = FpM_ker(x, p);
1918 84 : long lM = lg(M);
1919 84 : if (lM==1) break;
1920 :
1921 42 : FpM_center_inplace(M, p, pov2);
1922 42 : N = ZM_Z_divexact(ZM_mul(x,M), p);
1923 126 : for (j=1; j<lM; j++)
1924 : {
1925 147 : long k = n; while (!signe(gcoeff(M,k,j))) k--;
1926 84 : gel(x,k) = gel(N,j);
1927 : }
1928 42 : if (gc_needed(av1,1))
1929 : {
1930 0 : if (DEBUGMEM>1) pari_warn(warnmem,"QM_minors_coprime, p = %Ps", p);
1931 0 : x = gerepilecopy(av1, x); pov2 = shifti(p, -1);
1932 : }
1933 : }
1934 : }
1935 14 : return gerepilecopy(av, x);
1936 : }
1937 :
1938 : static GEN
1939 3479 : QM_ImZ_all_i(GEN A, GEN *U, long remove, long hnf, long linindep)
1940 : {
1941 3479 : GEN V = NULL, D;
1942 3479 : A = Q_remove_denom(A,&D);
1943 3479 : if (D)
1944 : {
1945 : long l, lA;
1946 1190 : V = matkermod(A,D,NULL);
1947 1190 : l = lg(V); lA = lg(A);
1948 1190 : if (l == 1) V = scalarmat_shallow(D, lA-1);
1949 : else
1950 : {
1951 1015 : if (l < lA) V = hnfmodid(V,D);
1952 1015 : A = ZM_Z_divexact(ZM_mul(A, V), D);
1953 : }
1954 : }
1955 3479 : if (!linindep && ZM_rank(A)==lg(A)-1) linindep = 1;
1956 3479 : if (hnf || !linindep) A = ZM_hnflll(A, U, remove);
1957 3479 : if (U && V)
1958 : {
1959 1057 : if (hnf) *U = ZM_mul(V,*U);
1960 0 : else *U = V;
1961 : }
1962 3479 : return A;
1963 : }
1964 : GEN
1965 28 : QM_ImZ_all(GEN x, GEN *U, long remove, long hnf)
1966 : {
1967 28 : pari_sp av = avma;
1968 28 : x = QM_ImZ_all_i(x, U, remove, hnf, 0);
1969 28 : return gc_all(av, U?2:1, &x, &U);
1970 : }
1971 : GEN
1972 0 : QM_ImZ_hnfall(GEN x, GEN *U, long remove) { return QM_ImZ_all(x, U, remove, 1); }
1973 : GEN
1974 0 : QM_ImZ_hnf(GEN x) { return QM_ImZ_hnfall(x, NULL, 1); }
1975 : GEN
1976 28 : QM_ImZ(GEN x) { return QM_ImZ_all(x, NULL, 1, 0); }
1977 :
1978 : GEN
1979 3458 : QM_ImQ_all(GEN x, GEN *U, long remove, long hnf)
1980 : {
1981 3458 : pari_sp av = avma;
1982 3458 : long i, n = lg(x), m;
1983 3458 : GEN ir, V, D, c, K = NULL;
1984 :
1985 3458 : if (U) *U = matid(n-1);
1986 3458 : if (n==1) return gcopy(x);
1987 3451 : m = lg(gel(x,1));
1988 :
1989 3451 : x = RgM_shallowcopy(x);
1990 15029 : for (i=1; i<n; i++)
1991 : {
1992 11578 : gel(x,i) = Q_primitive_part(gel(x,i), &c);
1993 11578 : if (U && c && signe(c)) gcoeff(*U,i,i) = ginv(c);
1994 : }
1995 :
1996 3451 : ir = ZM_indexrank(x);
1997 3451 : if (U)
1998 : {
1999 2219 : *U = vecpermute(*U, gel(ir,2));
2000 2219 : if (remove < 2) K = ZM_ker(x);
2001 : }
2002 3451 : x = vecpermute(x, gel(ir,2));
2003 :
2004 3451 : D = absi(ZM_det(rowpermute(x,gel(ir,1))));
2005 3451 : x = RgM_Rg_div(x, D);
2006 3451 : x = QM_ImZ_all_i(x, U? &V: NULL, remove, hnf, 1);
2007 :
2008 3451 : if (U)
2009 : {
2010 2219 : *U = RgM_Rg_div(RgM_mul(*U,V),D);
2011 2219 : if (remove < 2) *U = shallowconcat(K,*U);
2012 2219 : if (!remove) x = shallowconcat(zeromatcopy(m-1,lg(K)-1), x);
2013 2219 : gerepileall(av, 2, &x, U);
2014 : }
2015 1232 : else x = gerepilecopy(av,x);
2016 3451 : return x;
2017 : }
2018 : GEN
2019 3402 : QM_ImQ_hnfall(GEN x, GEN *U, long remove) { return QM_ImQ_all(x, U, remove, 1); }
2020 : GEN
2021 1183 : QM_ImQ_hnf(GEN x) { return QM_ImQ_hnfall(x, NULL, 1); }
2022 : GEN
2023 56 : QM_ImQ(GEN x) { return QM_ImQ_all(x, NULL, 1, 0); }
2024 :
2025 : GEN
2026 5691 : intersect(GEN x, GEN y)
2027 : {
2028 5691 : long j, lx = lg(x);
2029 : pari_sp av;
2030 : GEN z;
2031 :
2032 5691 : if (typ(x)!=t_MAT) pari_err_TYPE("intersect",x);
2033 5691 : if (typ(y)!=t_MAT) pari_err_TYPE("intersect",y);
2034 5691 : if (lx==1 || lg(y)==1) return cgetg(1,t_MAT);
2035 :
2036 4207 : av = avma; z = ker(shallowconcat(x,y));
2037 18676 : for (j=lg(z)-1; j; j--) setlg(z[j], lx);
2038 4207 : return gerepileupto(av, image(RgM_mul(x,z)));
2039 : }
|
