Line data Source code
1 : /* Copyright (C) 2016 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 : /* Modular forms package based on trace formulas */
18 : /* */
19 : /*************************************************************************/
20 : #include "pari.h"
21 : #include "paripriv.h"
22 :
23 : #define DEBUGLEVEL DEBUGLEVEL_mf
24 :
25 : enum {
26 : MF_SPLIT = 1,
27 : MF_EISENSPACE,
28 : MF_FRICKE,
29 : MF_MF2INIT,
30 : MF_SPLITN
31 : };
32 :
33 : typedef struct {
34 : GEN vnew, vfull, DATA, VCHIP;
35 : long n, newHIT, newTOTAL, cuspHIT, cuspTOTAL;
36 : } cachenew_t;
37 :
38 : static void init_cachenew(cachenew_t *c, long n, long N, GEN f);
39 : static long mf1cuspdim_i(long N, GEN CHI, GEN TMP, GEN vSP, long *dih);
40 : static GEN mfinit_i(GEN NK, long space);
41 : static GEN mfinit_Nkchi(long N, long k, GEN CHI, long space, long flraw);
42 : static GEN mf2init_Nkchi(long N, long k, GEN CHI, long space, long flraw);
43 : static GEN mf2basis(long N, long r, GEN CHI, GEN *pCHI1, long space);
44 : static GEN mfeisensteinbasis(long N, long k, GEN CHI);
45 : static GEN mfeisensteindec(GEN mf, GEN F);
46 : static GEN initwt1newtrace(GEN mf);
47 : static GEN initwt1trace(GEN mf);
48 : static GEN myfactoru(long N);
49 : static GEN mydivisorsu(long N);
50 : static GEN Qab_Czeta(long k, long ord, GEN C, long vt);
51 : static GEN mfcoefs_i(GEN F, long n, long d);
52 : static GEN bhnmat_extend(GEN M, long m,long l, GEN S, cachenew_t *cache);
53 : static GEN initnewtrace(long N, GEN CHI);
54 : static void dbg_cachenew(cachenew_t *C);
55 : static GEN hecke_i(long m, long l, GEN V, GEN F, GEN DATA);
56 : static GEN c_Ek(long n, long d, GEN F);
57 : static GEN RgV_heckef2(long n, long d, GEN V, GEN F, GEN DATA);
58 : static GEN mfcusptrace_i(long N, long k, long n, GEN Dn, GEN TDATA);
59 : static GEN mfnewtracecache(long N, long k, long n, cachenew_t *cache);
60 : static GEN colnewtrace(long n0, long n, long d, long N, long k, cachenew_t *c);
61 : static GEN dihan(GEN bnr, GEN w, GEN k0j, long m, ulong n);
62 : static GEN sigchi(long k, GEN CHI, long n);
63 : static GEN sigchi2(long k, GEN CHI1, GEN CHI2, long n, long ord);
64 : static GEN mflineardivtomat(long N, GEN vF, long n);
65 : static GEN mfdihedralcusp(long N, GEN CHI, GEN vSP);
66 : static long mfdihedralcuspdim(long N, GEN CHI, GEN vSP);
67 : static GEN mfdihedralnew(long N, GEN CHI, GEN SP);
68 : static GEN mfdihedral(long N);
69 : static GEN mfdihedralall(long N);
70 : static long mf1cuspdim(long N, GEN CHI, GEN vSP);
71 : static long mf2dim_Nkchi(long N, long k, GEN CHI, ulong space);
72 : static long mfdim_Nkchi(long N, long k, GEN CHI, long space);
73 : static GEN charLFwtk(long N, long k, GEN CHI, long ord, long t);
74 : static GEN mfeisensteingacx(GEN E,long w,GEN ga,long n,long prec);
75 : static GEN mfgaexpansion(GEN mf, GEN F, GEN gamma, long n, long prec);
76 : static GEN mfEHmat(long n, long r);
77 : static GEN mfEHcoef(long r, long N);
78 : static GEN mftobasis_i(GEN mf, GEN F);
79 :
80 : static GEN
81 36323 : mkgNK(GEN N, GEN k, GEN CHI, GEN P) { return mkvec4(N, k, CHI, P); }
82 : static GEN
83 14854 : mkNK(long N, long k, GEN CHI) { return mkgNK(stoi(N), stoi(k), CHI, pol_x(1)); }
84 : GEN
85 7861 : MF_get_CHI(GEN mf) { return gmael(mf,1,3); }
86 : GEN
87 19376 : MF_get_gN(GEN mf) { return gmael(mf,1,1); }
88 : long
89 18487 : MF_get_N(GEN mf) { return itou(MF_get_gN(mf)); }
90 : GEN
91 13384 : MF_get_gk(GEN mf) { return gmael(mf,1,2); }
92 : long
93 6685 : MF_get_k(GEN mf)
94 : {
95 6685 : GEN gk = MF_get_gk(mf);
96 6685 : if (typ(gk)!=t_INT) pari_err_IMPL("half-integral weight");
97 6685 : return itou(gk);
98 : }
99 : long
100 245 : MF_get_r(GEN mf)
101 : {
102 245 : GEN gk = MF_get_gk(mf);
103 245 : if (typ(gk) == t_INT) pari_err_IMPL("integral weight");
104 245 : return itou(gel(gk, 1)) >> 1;
105 : }
106 : long
107 13748 : MF_get_space(GEN mf) { return itos(gmael(mf,1,4)); }
108 : GEN
109 4193 : MF_get_E(GEN mf) { return gel(mf,2); }
110 : GEN
111 20328 : MF_get_S(GEN mf) { return gel(mf,3); }
112 : GEN
113 1659 : MF_get_basis(GEN mf) { return shallowconcat(gel(mf,2), gel(mf,3)); }
114 : long
115 5271 : MF_get_dim(GEN mf)
116 : {
117 5271 : switch(MF_get_space(mf))
118 : {
119 693 : case mf_FULL:
120 693 : return lg(MF_get_S(mf)) - 1 + lg(MF_get_E(mf))-1;
121 140 : case mf_EISEN:
122 140 : return lg(MF_get_E(mf))-1;
123 4438 : default: /* mf_NEW, mf_CUSP, mf_OLD */
124 4438 : return lg(MF_get_S(mf)) - 1;
125 : }
126 : }
127 : GEN
128 7077 : MFnew_get_vj(GEN mf) { return gel(mf,4); }
129 : GEN
130 490 : MFcusp_get_vMjd(GEN mf) { return gel(mf,4); }
131 : GEN
132 6748 : MF_get_M(GEN mf) { return gmael(mf,5,3); }
133 : GEN
134 4564 : MF_get_Minv(GEN mf) { return gmael(mf,5,2); }
135 : GEN
136 9982 : MF_get_Mindex(GEN mf) { return gmael(mf,5,1); }
137 :
138 : /* ordinary gtocol forgets about initial 0s */
139 : GEN
140 2387 : sertocol(GEN S) { return gtocol0(S, -(lg(S) - 2 + valser(S))); }
141 : /*******************************************************************/
142 : /* Linear algebra in cyclotomic fields (TODO: export this) */
143 : /*******************************************************************/
144 : /* return r and split prime p giving projection Q(zeta_n) -> Fp, zeta -> r */
145 : static ulong
146 1211 : QabM_init(long n, ulong *p)
147 : {
148 1211 : ulong pinit = 1000000007;
149 : forprime_t T;
150 1211 : if (n <= 1) { *p = pinit; return 0; }
151 1204 : u_forprime_arith_init(&T, pinit, ULONG_MAX, 1, n);
152 1204 : *p = u_forprime_next(&T);
153 1204 : return Flx_oneroot(ZX_to_Flx(polcyclo(n, 0), *p), *p);
154 : }
155 : static ulong
156 8534960 : Qab_to_Fl(GEN P, ulong r, ulong p)
157 : {
158 : ulong t;
159 : GEN den;
160 8534960 : P = Q_remove_denom(liftpol_shallow(P), &den);
161 8534960 : if (typ(P) == t_POL) { GEN Pp = ZX_to_Flx(P, p); t = Flx_eval(Pp, r, p); }
162 8399335 : else t = umodiu(P, p);
163 8534960 : if (den) t = Fl_div(t, umodiu(den, p), p);
164 8534960 : return t;
165 : }
166 : static GEN
167 38164 : QabC_to_Flc(GEN C, ulong r, ulong p)
168 : {
169 38164 : long i, l = lg(C);
170 38164 : GEN A = cgetg(l, t_VECSMALL);
171 8341333 : for (i = 1; i < l; i++) uel(A,i) = Qab_to_Fl(gel(C,i), r, p);
172 38164 : return A;
173 : }
174 : static GEN
175 595 : QabM_to_Flm(GEN M, ulong r, ulong p)
176 : {
177 : long i, l;
178 595 : GEN A = cgetg_copy(M, &l);
179 38759 : for (i = 1; i < l; i++)
180 38164 : gel(A, i) = QabC_to_Flc(gel(M, i), r, p);
181 595 : return A;
182 : }
183 : /* A a t_POL */
184 : static GEN
185 1484 : QabX_to_Flx(GEN A, ulong r, ulong p)
186 : {
187 1484 : long i, l = lg(A);
188 1484 : GEN a = cgetg(l, t_VECSMALL);
189 1484 : a[1] = ((ulong)A[1])&VARNBITS;
190 233023 : for (i = 2; i < l; i++) uel(a,i) = Qab_to_Fl(gel(A,i), r, p);
191 1484 : return Flx_renormalize(a, l);
192 : }
193 :
194 : /* FIXME: remove */
195 : static GEN
196 1092 : ZabM_pseudoinv_i(GEN M, GEN P, long n, GEN *pv, GEN *den, int ratlift)
197 : {
198 1092 : GEN v = ZabM_indexrank(M, P, n);
199 1092 : if (pv) *pv = v;
200 1092 : M = shallowmatextract(M,gel(v,1),gel(v,2));
201 1092 : return ratlift? ZabM_inv_ratlift(M, P, n, den): ZabM_inv(M, P, n, den);
202 : }
203 :
204 : /* M matrix with coeff in Q(\chi)), where Q(\chi) = Q(X)/(P) for
205 : * P = cyclotomic Phi_n. Assume M rational if n <= 2 */
206 : static GEN
207 1561 : QabM_ker(GEN M, GEN P, long n)
208 : {
209 1561 : if (n <= 2) return QM_ker(M);
210 378 : return ZabM_ker(row_Q_primpart(liftpol_shallow(M)), P, n);
211 : }
212 : /* pseudo-inverse of M. FIXME: should replace QabM_pseudoinv */
213 : static GEN
214 1274 : QabM_pseudoinv_i(GEN M, GEN P, long n, GEN *pv, GEN *pden)
215 : {
216 : GEN cM, Mi;
217 1274 : if (n <= 2)
218 : {
219 1134 : M = Q_primitive_part(M, &cM);
220 1134 : Mi = ZM_pseudoinv(M, pv, pden); /* M^(-1) = Mi / (cM * den) */
221 : }
222 : else
223 : {
224 140 : M = Q_primitive_part(liftpol_shallow(M), &cM);
225 140 : Mi = ZabM_pseudoinv(M, P, n, pv, pden);
226 : }
227 1274 : *pden = mul_content(*pden, cM);
228 1274 : return Mi;
229 : }
230 : /* FIXME: delete */
231 : static GEN
232 1015 : QabM_pseudoinv(GEN M, GEN P, long n, GEN *pv, GEN *pden)
233 : {
234 1015 : GEN Mi = QabM_pseudoinv_i(M, P, n, pv, pden);
235 1015 : return P? gmodulo(Mi, P): Mi;
236 : }
237 :
238 : static GEN
239 10283 : QabM_indexrank(GEN M, GEN P, long n)
240 : {
241 : GEN z;
242 10283 : if (n <= 2)
243 : {
244 9128 : M = vec_Q_primpart(M);
245 9128 : z = ZM_indexrank(M); /* M^(-1) = Mi / (cM * den) */
246 : }
247 : else
248 : {
249 1155 : M = vec_Q_primpart(liftpol_shallow(M));
250 1155 : z = ZabM_indexrank(M, P, n);
251 : }
252 10283 : return z;
253 : }
254 :
255 : /*********************************************************************/
256 : /* Simple arithmetic functions */
257 : /*********************************************************************/
258 : /* TODO: most of these should be exported and used in ifactor1.c */
259 : /* phi(n) */
260 : static ulong
261 106407 : myeulerphiu(ulong n)
262 : {
263 : pari_sp av;
264 106407 : if (n == 1) return 1;
265 87787 : av = avma; return gc_ulong(av, eulerphiu_fact(myfactoru(n)));
266 : }
267 : static long
268 65688 : mymoebiusu(ulong n)
269 : {
270 : pari_sp av;
271 65688 : if (n == 1) return 1;
272 54173 : av = avma; return gc_long(av, moebiusu_fact(myfactoru(n)));
273 : }
274 :
275 : static long
276 2933 : mynumdivu(long N)
277 : {
278 : pari_sp av;
279 2933 : if (N == 1) return 1;
280 2828 : av = avma; return gc_long(av, numdivu_fact(myfactoru(N)));
281 : }
282 :
283 : /* N\prod_{p|N} (1+1/p) */
284 : static long
285 383950 : mypsiu(ulong N)
286 : {
287 : pari_sp av;
288 : GEN P;
289 : long j, l, a;
290 383950 : if (N == 1) return 1;
291 302883 : av = avma; P = gel(myfactoru(N), 1); l = lg(P);
292 722183 : for (a = N, j = 1; j < l; j++) a += a / P[j];
293 302883 : return gc_long(av, a);
294 : }
295 : /* write n = mf^2. Return m, set f. */
296 : static ulong
297 70 : mycore(ulong n, long *pf)
298 : {
299 70 : pari_sp av = avma;
300 70 : GEN fa = myfactoru(n), P = gel(fa,1), E = gel(fa,2);
301 70 : long i, l = lg(P), m = 1, f = 1;
302 266 : for (i = 1; i < l; i++)
303 : {
304 196 : long j, p = P[i], e = E[i];
305 196 : if (e & 1) m *= p;
306 455 : for (j = 2; j <= e; j+=2) f *= p;
307 : }
308 70 : *pf = f; return gc_long(av,m);
309 : }
310 :
311 : /* fa = factorization of -D > 0, return -D0 > 0 (where D0 is fundamental) */
312 : static long
313 4369208 : corediscs_fact(GEN fa)
314 : {
315 4369208 : GEN P = gel(fa,1), E = gel(fa,2);
316 4369208 : long i, l = lg(P), m = 1;
317 14413146 : for (i = 1; i < l; i++)
318 : {
319 10043938 : long p = P[i], e = E[i];
320 10043938 : if (e & 1) m *= p;
321 : }
322 4369208 : if ((m&3L) != 3) m <<= 2;
323 4369208 : return m;
324 : }
325 : static long
326 6916 : mubeta(long n)
327 : {
328 6916 : pari_sp av = avma;
329 6916 : GEN E = gel(myfactoru(n), 2);
330 6916 : long i, s = 1, l = lg(E);
331 14350 : for (i = 1; i < l; i++)
332 : {
333 7434 : long e = E[i];
334 7434 : if (e >= 3) return gc_long(av,0);
335 7434 : if (e == 1) s *= -2;
336 : }
337 6916 : return gc_long(av,s);
338 : }
339 :
340 : /* n = n1*n2, n1 = ppo(n, m); return mubeta(n1)*moebiusu(n2).
341 : * N.B. If n from newt_params we, in fact, never return 0 */
342 : static long
343 7600969 : mubeta2(long n, long m)
344 : {
345 7600969 : pari_sp av = avma;
346 7600969 : GEN fa = myfactoru(n), P = gel(fa,1), E = gel(fa,2);
347 7600969 : long i, s = 1, l = lg(P);
348 15287726 : for (i = 1; i < l; i++)
349 : {
350 7686757 : long p = P[i], e = E[i];
351 7686757 : if (m % p)
352 : { /* p^e in n1 */
353 6529076 : if (e >= 3) return gc_long(av,0);
354 6529076 : if (e == 1) s *= -2;
355 : }
356 : else
357 : { /* in n2 */
358 1157681 : if (e >= 2) return gc_long(av,0);
359 1157681 : s = -s;
360 : }
361 : }
362 7600969 : return gc_long(av,s);
363 : }
364 :
365 : /* write N = prod p^{ep} and n = df^2, d squarefree.
366 : * set g = ppo(gcd(sqfpart(N), f), FC)
367 : * N2 = prod p^if(e==1 || p|n, ep-1, ep-2) */
368 : static void
369 1861815 : newt_params(long N, long n, long FC, long *pg, long *pN2)
370 : {
371 1861815 : GEN fa = myfactoru(N), P = gel(fa,1), E = gel(fa,2);
372 1861815 : long i, g = 1, N2 = 1, l = lg(P);
373 4972696 : for (i = 1; i < l; i++)
374 : {
375 3110881 : long p = P[i], e = E[i];
376 3110881 : if (e == 1)
377 2719696 : { if (FC % p && n % (p*p) == 0) g *= p; }
378 : else
379 391185 : N2 *= upowuu(p,(n % p)? e-2: e-1);
380 : }
381 1861815 : *pg = g; *pN2 = N2;
382 1861815 : }
383 : /* simplified version of newt_params for n = 1 (newdim) */
384 : static void
385 39627 : newd_params(long N, long *pN2)
386 : {
387 39627 : GEN fa = myfactoru(N), P = gel(fa,1), E = gel(fa,2);
388 39627 : long i, N2 = 1, l = lg(P);
389 99302 : for (i = 1; i < l; i++)
390 : {
391 59675 : long p = P[i], e = E[i];
392 59675 : if (e > 2) N2 *= upowuu(p, e-2);
393 : }
394 39627 : *pN2 = N2;
395 39627 : }
396 :
397 : static long
398 21 : newd_params2(long N)
399 : {
400 21 : GEN fa = myfactoru(N), P = gel(fa,1), E = gel(fa,2);
401 21 : long i, N2 = 1, l = lg(P);
402 56 : for (i = 1; i < l; i++)
403 : {
404 35 : long p = P[i], e = E[i];
405 35 : if (e >= 2) N2 *= upowuu(p, e);
406 : }
407 21 : return N2;
408 : }
409 :
410 : /*******************************************************************/
411 : /* Relative trace between cyclotomic fields (TODO: export this) */
412 : /*******************************************************************/
413 : /* g>=1; return g * prod_{p | g, (p,q) = 1} (1-1/p) */
414 : static long
415 36862 : phipart(long g, long q)
416 : {
417 36862 : if (g > 1)
418 : {
419 19663 : GEN P = gel(myfactoru(g), 1);
420 19663 : long i, l = lg(P);
421 40180 : for (i = 1; i < l; i++) { long p = P[i]; if (q % p) g -= g / p; }
422 : }
423 36862 : return g;
424 : }
425 : /* Set s,v s.t. Trace(zeta_N^k) from Q(zeta_N) to Q(\zeta_N) = s * zeta_M^v
426 : * With k > 0, N = M*d and N, M != 2 mod 4 */
427 : static long
428 84735 : tracerelz(long *pv, long d, long M, long k)
429 : {
430 : long s, g, q, muq;
431 84735 : if (d == 1) { *pv = k; return 1; }
432 65597 : *pv = 0; g = ugcd(k, d); q = d / g;
433 65597 : muq = mymoebiusu(q); if (!muq) return 0;
434 47166 : if (M != 1)
435 : {
436 37821 : long v = Fl_invsafe(q % M, M);
437 37821 : if (!v) return 0;
438 27517 : *pv = (v * (k/g)) % M;
439 : }
440 36862 : s = phipart(g, M*q); if (muq < 0) s = -s;
441 36862 : return s;
442 : }
443 : /* Pi = polcyclo(i), i = m or n. Let Ki = Q(zeta_i), initialize Tr_{Kn/Km} */
444 : GEN
445 34006 : Qab_trace_init(long n, long m, GEN Pn, GEN Pm)
446 : {
447 : long a, i, j, N, M, vt, d, D;
448 : GEN T, G;
449 :
450 34006 : if (m == n || n <= 2) return mkvec(Pm);
451 16548 : vt = varn(Pn);
452 16548 : d = degpol(Pn);
453 : /* if (N != n) zeta_N = zeta_n^2 and zeta_n = - zeta_N^{(N+1)/2} */
454 16548 : N = ((n & 3) == 2)? n >> 1: n;
455 16548 : M = ((m & 3) == 2)? m >> 1: m; /* M | N | n */
456 16548 : a = N / M;
457 16548 : T = const_vec(d, NULL);
458 16548 : D = d / degpol(Pm); /* relative degree */
459 16548 : if (D == 1) G = NULL;
460 : else
461 : { /* zeta_M = zeta_n^A; s_j(zeta_M) = zeta_M <=> j = 1 (mod J) */
462 15274 : long lG, A = (N == n)? a: (a << 1), J = n / ugcd(n, A);
463 15274 : G = coprimes_zv(n);
464 150241 : for (j = lG = 1; j < n; j += J)
465 134967 : if (G[j]) G[lG++] = j;
466 15274 : setlg(G, lG); /* Gal(Q(zeta_n) / Q(zeta_m)) */
467 : }
468 16548 : T = const_vec(d, NULL);
469 16548 : gel(T,1) = utoipos(D); /* Tr 1 */
470 140112 : for (i = 1; i < d; i++)
471 : { /* if n = 2N, zeta_n^i = (-1)^i zeta_N^k */
472 : long s, v, k;
473 : GEN t;
474 :
475 123564 : if (gel(T, i+1)) continue;
476 84735 : k = (N == n)? i: ((odd(i)? i + N: i) >> 1);
477 84735 : if ((s = tracerelz(&v, a, M, k)))
478 : {
479 56000 : if (m != M) v *= 2;/* Tr = s * zeta_m^v */
480 56000 : if (n != N && odd(i)) s = -s;
481 56000 : t = Qab_Czeta(v, m, stoi(s), vt);
482 : }
483 : else
484 28735 : t = gen_0;
485 : /* t = Tr_{Kn/Km} zeta_n^i; fill using Galois action */
486 84735 : if (!G)
487 19138 : gel(T, i + 1) = t;
488 : else
489 370811 : for (j = 1; j <= D; j++)
490 : {
491 305214 : long z = Fl_mul(i,G[j], n);
492 305214 : if (z < d) gel(T, z + 1) = t;
493 : }
494 : }
495 16548 : return mkvec3(Pm, Pn, T);
496 : }
497 : /* x a t_POL modulo Phi_n */
498 : static GEN
499 80248 : tracerel_i(GEN T, GEN x)
500 : {
501 80248 : long k, l = lg(x);
502 : GEN S;
503 80248 : if (l == 2) return gen_0;
504 80248 : S = gmul(gel(T,1), gel(x,2));
505 283269 : for (k = 3; k < l; k++) S = gadd(S, gmul(gel(T,k-1), gel(x,k)));
506 80248 : return S;
507 : }
508 : static GEN
509 253827 : tracerel(GEN a, GEN v, GEN z)
510 : {
511 253827 : a = liftpol_shallow(a);
512 253827 : a = simplify_shallow(z? gmul(z,a): a);
513 253827 : if (typ(a) == t_POL)
514 : {
515 80248 : GEN T = gel(v,3);
516 80248 : long degrel = itou(gel(T,1));
517 80248 : a = tracerel_i(T, RgX_rem(a, gel(v,2)));
518 80248 : if (degrel != 1) a = gdivgu(a, degrel);
519 80248 : if (typ(a) == t_POL) a = RgX_rem(a, gel(v,1));
520 : }
521 253827 : return a;
522 : }
523 : static GEN
524 6937 : tracerel_z(GEN v, long t)
525 : {
526 6937 : GEN Pn = gel(v,2);
527 6937 : return t? pol_xn(t, varn(Pn)): NULL;
528 : }
529 : /* v = Qab_trace_init(n,m); x is a t_VEC of polmodulo Phi_n; Kn = Q(zeta_n)
530 : * [Kn:Km]^(-1) Tr_{Kn/Km} (zeta_n^t * x); 0 <= t < [Kn:Km] */
531 : GEN
532 0 : Qab_tracerel(GEN v, long t, GEN a)
533 : {
534 0 : if (lg(v) != 4) return a; /* => t = 0 */
535 0 : return tracerel(a, v, tracerel_z(v, t));
536 : }
537 : GEN
538 16086 : QabV_tracerel(GEN v, long t, GEN x)
539 : {
540 : GEN z;
541 16086 : if (lg(v) != 4) return x; /* => t = 0 */
542 6937 : z = tracerel_z(v, t);
543 260764 : pari_APPLY_same(tracerel(gel(x,i), v, z));
544 : }
545 : GEN
546 147 : QabM_tracerel(GEN v, long t, GEN x)
547 : {
548 147 : if (lg(v) != 4) return x;
549 105 : pari_APPLY_same(QabV_tracerel(v, t, gel(x,i)));
550 : }
551 :
552 : /* C*zeta_o^k mod X^o - 1 */
553 : static GEN
554 2188543 : Qab_Czeta(long k, long o, GEN C, long vt)
555 : {
556 2188543 : if (!k) return C;
557 1455734 : if (!odd(o))
558 : { /* optimization: reduce max degree by a factor 2 for free */
559 1404634 : o >>= 1;
560 1404634 : if (k >= o) { k -= o; C = gneg(C); if (!k) return C; }
561 : }
562 1109444 : return monomial(C, k, vt);
563 : }
564 : /* zeta_o^k */
565 : static GEN
566 200242 : Qab_zeta(long k, long o, long vt) { return Qab_Czeta(k, o, gen_1, vt); }
567 :
568 : /* Operations on Dirichlet characters */
569 :
570 : /* A Dirichlet character can be given in GP in different formats, but in this
571 : * package, it will be a vector CHI=[G,chi,ord], where G is the (Z/MZ)^* to
572 : * which the character belongs, chi is the character in Conrey format, ord is
573 : * the order */
574 :
575 : static GEN
576 3718820 : gmfcharorder(GEN CHI) { return gel(CHI, 3); }
577 : long
578 3681370 : mfcharorder(GEN CHI) { return itou(gmfcharorder(CHI)); }
579 : static long
580 2632 : mfcharistrivial(GEN CHI) { return !CHI || mfcharorder(CHI) == 1; }
581 : static GEN
582 1546545 : gmfcharmodulus(GEN CHI) { return gmael3(CHI, 1, 1, 1); }
583 : long
584 1546545 : mfcharmodulus(GEN CHI) { return itou(gmfcharmodulus(CHI)); }
585 : GEN
586 562709 : mfcharpol(GEN CHI) { return gel(CHI,4); }
587 :
588 : /* vz[i+1] = image of (zeta_o)^i in Fp */
589 : static ulong
590 220514 : Qab_Czeta_Fl(long k, GEN vz, ulong C, ulong p)
591 : {
592 : long o;
593 220514 : if (!k) return C;
594 148631 : o = lg(vz)-2;
595 148631 : if ((k << 1) == o) return Fl_neg(C,p);
596 123123 : return Fl_mul(C, vz[k+1], p);
597 : }
598 :
599 : static long
600 2507092 : znchareval_i(GEN CHI, long n, GEN ord)
601 2507092 : { return itos(znchareval(gel(CHI,1), gel(CHI,2), stoi(n), ord)); }
602 :
603 : /* n coprime with the modulus of CHI */
604 : static GEN
605 13972 : mfchareval(GEN CHI, long n)
606 : {
607 13972 : GEN Pn, C, go = gmfcharorder(CHI);
608 13972 : long k, o = go[2];
609 13972 : if (o == 1) return gen_1;
610 7378 : k = znchareval_i(CHI, n, go);
611 7378 : Pn = mfcharpol(CHI);
612 7378 : C = Qab_zeta(k, o, varn(Pn));
613 7378 : if (typ(C) != t_POL) return C;
614 5320 : return gmodulo(C, Pn);
615 : }
616 : /* d a multiple of ord(CHI); n coprime with char modulus;
617 : * return x s.t. CHI(n) = \zeta_d^x] */
618 : static long
619 3561152 : mfcharevalord(GEN CHI, long n, long d)
620 : {
621 3561152 : if (mfcharorder(CHI) == 1) return 0;
622 2496018 : return znchareval_i(CHI, n, utoi(d));
623 : }
624 :
625 : /* G a znstar, L a Conrey log: return a 'mfchar' */
626 : static GEN
627 373506 : mfcharGL(GEN G, GEN L)
628 : {
629 373506 : GEN o = zncharorder(G,L);
630 373506 : long ord = itou(o), vt = fetch_user_var("t");
631 373506 : return mkvec4(G, L, o, polcyclo(ord,vt));
632 : }
633 : static GEN
634 5614 : mfchartrivial()
635 5614 : { return mfcharGL(znstar0(gen_1,1), cgetg(1,t_COL)); }
636 : /* convert a generic character into an 'mfchar' */
637 : static GEN
638 4025 : get_mfchar(GEN CHI)
639 : {
640 : GEN G, L;
641 4025 : if (typ(CHI) != t_VEC) CHI = znchar(CHI);
642 : else
643 : {
644 889 : long l = lg(CHI);
645 889 : if ((l != 3 && l != 5) || !checkznstar_i(gel(CHI,1)))
646 7 : pari_err_TYPE("checkNF [chi]", CHI);
647 882 : if (l == 5) return CHI;
648 : }
649 3955 : G = gel(CHI,1);
650 3955 : L = gel(CHI,2); if (typ(L) != t_COL) L = znconreylog(G,L);
651 3955 : return mfcharGL(G, L);
652 : }
653 :
654 : /* parse [N], [N,k], [N,k,CHI]. If 'joker' is set, allow wildcard for CHI */
655 : static GEN
656 9128 : checkCHI(GEN NK, long N, int joker)
657 : {
658 : GEN CHI;
659 9128 : if (lg(NK) == 3)
660 644 : CHI = mfchartrivial();
661 : else
662 : {
663 : long i, l;
664 8484 : CHI = gel(NK,3); l = lg(CHI);
665 8484 : if (isintzero(CHI) && joker)
666 4116 : CHI = NULL; /* all character orbits */
667 4368 : else if (isintm1(CHI) && joker > 1)
668 2373 : CHI = gen_m1; /* sum over all character orbits */
669 1995 : else if ((typ(CHI) == t_VEC &&
670 217 : (l == 1 || l != 3 || !checkznstar_i(gel(CHI,1)))) && joker)
671 : {
672 133 : CHI = shallowtrans(CHI); /* list of characters */
673 952 : for (i = 1; i < l; i++) gel(CHI,i) = get_mfchar(gel(CHI,i));
674 : }
675 : else
676 : {
677 1862 : CHI = get_mfchar(CHI); /* single char */
678 1862 : if (N % mfcharmodulus(CHI)) pari_err_TYPE("checkNF [chi]", NK);
679 : }
680 : }
681 9114 : return CHI;
682 : }
683 : /* support half-integral weight */
684 : static void
685 9135 : checkNK2(GEN NK, long *N, long *nk, long *dk, GEN *CHI, int joker)
686 : {
687 9135 : long l = lg(NK);
688 : GEN T;
689 9135 : if (typ(NK) != t_VEC || l < 3 || l > 4) pari_err_TYPE("checkNK", NK);
690 9135 : T = gel(NK,1); if (typ(T) != t_INT) pari_err_TYPE("checkNF [N]", NK);
691 9135 : *N = itos(T); if (*N <= 0) pari_err_TYPE("checkNF [N <= 0]", NK);
692 9135 : T = gel(NK,2);
693 9135 : switch(typ(T))
694 : {
695 5754 : case t_INT: *nk = itos(T); *dk = 1; break;
696 3374 : case t_FRAC:
697 3374 : *nk = itos(gel(T,1));
698 3374 : *dk = itou(gel(T,2)); if (*dk == 2) break;
699 7 : default: pari_err_TYPE("checkNF [k]", NK);
700 : }
701 9128 : *CHI = checkCHI(NK, *N, joker);
702 9114 : }
703 : /* don't support half-integral weight */
704 : static void
705 133 : checkNK(GEN NK, long *N, long *k, GEN *CHI, int joker)
706 : {
707 : long d;
708 133 : checkNK2(NK, N, k, &d, CHI, joker);
709 133 : if (d != 1) pari_err_TYPE("checkNF [k]", NK);
710 133 : }
711 :
712 : static GEN
713 4872 : mfchargalois(long N, int odd, GEN flagorder)
714 : {
715 4872 : GEN G = znstar0(utoi(N), 1), L = chargalois(G, flagorder);
716 4872 : long l = lg(L), i, j;
717 113526 : for (i = j = 1; i < l; i++)
718 : {
719 108654 : GEN chi = znconreyfromchar(G, gel(L,i));
720 108654 : if (zncharisodd(G,chi) == odd) gel(L,j++) = mfcharGL(G,chi);
721 : }
722 4872 : setlg(L, j); return L;
723 : }
724 : /* possible characters for nontrivial S_1(N, chi) */
725 : static GEN
726 1729 : mf1chars(long N, GEN vCHI)
727 : {
728 1729 : if (vCHI) return vCHI; /*do not filter, user knows best*/
729 : /* Tate's theorem */
730 1659 : return mfchargalois(N, 1, uisprime(N)? mkvecsmall2(2,4): NULL);
731 : }
732 : static GEN
733 3255 : mfchars(long N, long k, long dk, GEN vCHI)
734 3255 : { return vCHI? vCHI: mfchargalois(N, (dk == 2)? 0: (k & 1), NULL); }
735 :
736 : /* wrappers from mfchar to znchar */
737 : static long
738 68250 : mfcharparity(GEN CHI)
739 : {
740 68250 : if (!CHI) return 1;
741 68250 : return zncharisodd(gel(CHI,1), gel(CHI,2)) ? -1 : 1;
742 : }
743 : /* if CHI is primitive, return CHI itself, not a copy */
744 : static GEN
745 73920 : mfchartoprimitive(GEN CHI, long *pF)
746 : {
747 : pari_sp av;
748 : GEN chi, F;
749 73920 : if (!CHI) { if (pF) *pF = 1; return mfchartrivial(); }
750 73920 : av = avma; F = znconreyconductor(gel(CHI,1), gel(CHI,2), &chi);
751 73920 : if (typ(F) == t_INT) set_avma(av);
752 : else
753 : {
754 7805 : CHI = leafcopy(CHI);
755 7805 : gel(CHI,1) = znstar0(F, 1);
756 7805 : gel(CHI,2) = chi;
757 : }
758 73920 : if (pF) *pF = mfcharmodulus(CHI);
759 73920 : return CHI;
760 : }
761 : static long
762 396389 : mfcharconductor(GEN CHI)
763 : {
764 396389 : pari_sp av = avma;
765 396389 : GEN res = znconreyconductor(gel(CHI,1), gel(CHI,2), NULL);
766 396389 : if (typ(res) == t_VEC) res = gel(res, 1);
767 396389 : return gc_long(av, itos(res));
768 : }
769 :
770 : /* Operations on mf closures */
771 : static GEN
772 61747 : tagparams(long t, GEN NK) { return mkvec2(mkvecsmall(t), NK); }
773 : static GEN
774 1127 : lfuntag(long t, GEN x) { return mkvec2(mkvecsmall(t), x); }
775 : static GEN
776 56 : tag0(long t, GEN NK) { retmkvec(tagparams(t,NK)); }
777 : static GEN
778 10003 : tag(long t, GEN NK, GEN x) { retmkvec2(tagparams(t,NK), x); }
779 : static GEN
780 35861 : tag2(long t, GEN NK, GEN x, GEN y) { retmkvec3(tagparams(t,NK), x,y); }
781 : static GEN
782 15701 : tag3(long t, GEN NK, GEN x,GEN y,GEN z) { retmkvec4(tagparams(t,NK), x,y,z); }
783 : static GEN
784 0 : tag4(long t, GEN NK, GEN x,GEN y,GEN z,GEN a)
785 0 : { retmkvec5(tagparams(t,NK), x,y,z,a); }
786 : /* is F a "modular form" ? */
787 : int
788 16898 : checkmf_i(GEN F)
789 16898 : { return typ(F) == t_VEC
790 16261 : && lg(F) > 1 && typ(gel(F,1)) == t_VEC
791 11991 : && lg(gel(F,1)) == 3
792 11830 : && typ(gmael(F,1,1)) == t_VECSMALL
793 33159 : && typ(gmael(F,1,2)) == t_VEC; }
794 227514 : long mf_get_type(GEN F) { return gmael(F,1,1)[1]; }
795 181146 : GEN mf_get_gN(GEN F) { return gmael3(F,1,2,1); }
796 136528 : GEN mf_get_gk(GEN F) { return gmael3(F,1,2,2); }
797 : /* k - 1/2, assume k in 1/2 + Z */
798 413 : long mf_get_r(GEN F) { return itou(gel(mf_get_gk(F),1)) >> 1; }
799 116298 : long mf_get_N(GEN F) { return itou(mf_get_gN(F)); }
800 70574 : long mf_get_k(GEN F)
801 : {
802 70574 : GEN gk = mf_get_gk(F);
803 70574 : if (typ(gk)!=t_INT) pari_err_IMPL("half-integral weight");
804 70574 : return itou(gk);
805 : }
806 61012 : GEN mf_get_CHI(GEN F) { return gmael3(F,1,2,3); }
807 23954 : GEN mf_get_field(GEN F) { return gmael3(F,1,2,4); }
808 18543 : GEN mf_get_NK(GEN F) { return gmael(F,1,2); }
809 : static void
810 518 : mf_setfield(GEN f, GEN P)
811 : {
812 518 : gel(f,1) = leafcopy(gel(f,1));
813 518 : gmael(f,1,2) = leafcopy(gmael(f,1,2));
814 518 : gmael3(f,1,2,4) = P;
815 518 : }
816 :
817 : /* UTILITY FUNCTIONS */
818 : GEN
819 9065 : mftocol(GEN F, long lim, long d)
820 9065 : { GEN c = mfcoefs_i(F, lim, d); settyp(c,t_COL); return c; }
821 : GEN
822 2093 : mfvectomat(GEN vF, long lim, long d)
823 : {
824 2093 : long j, l = lg(vF);
825 2093 : GEN M = cgetg(l, t_MAT);
826 10339 : for (j = 1; j < l; j++) gel(M,j) = mftocol(gel(vF,j), lim, d);
827 2093 : return M;
828 : }
829 :
830 : static GEN
831 4655 : RgV_to_ser_full(GEN x) { return RgV_to_ser(x, 0, lg(x)+1); }
832 : /* TODO: delete */
833 : static GEN
834 665 : mfcoefsser(GEN F, long n) { return RgV_to_ser_full(mfcoefs_i(F,n,1)); }
835 : static GEN
836 833 : sertovecslice(GEN S, long n)
837 : {
838 833 : GEN v = gtovec0(S, -(lg(S) - 2 + valser(S)));
839 833 : long l = lg(v), n2 = n + 2;
840 833 : if (l < n2) pari_err_BUG("sertovecslice [n too large]");
841 833 : return (l == n2)? v: vecslice(v, 1, n2-1);
842 : }
843 :
844 : /* a, b two RgV of the same length, multiply as truncated power series */
845 : static GEN
846 3339 : RgV_mul_RgXn(GEN a, GEN b)
847 : {
848 3339 : long n = lg(a)-1;
849 : GEN c;
850 3339 : a = RgV_to_RgX(a,0);
851 3339 : b = RgV_to_RgX(b,0); c = RgXn_mul(a, b, n);
852 3339 : c = RgX_to_RgC(c,n); settyp(c,t_VEC); return c;
853 : }
854 : /* divide as truncated power series */
855 : static GEN
856 399 : RgV_div_RgXn(GEN a, GEN b)
857 : {
858 399 : long n = lg(a)-1;
859 : GEN c;
860 399 : a = RgV_to_RgX(a,0);
861 399 : b = RgV_to_RgX(b,0); c = RgXn_div_i(a, b, n);
862 399 : c = RgX_to_RgC(c,n); settyp(c,t_VEC); return c;
863 : }
864 : /* a^b */
865 : static GEN
866 112 : RgV_pows_RgXn(GEN a, long b)
867 : {
868 112 : long n = lg(a)-1;
869 : GEN c;
870 112 : a = RgV_to_RgX(a,0);
871 112 : if (b < 0) { a = RgXn_inv(a, n); b = -b; }
872 112 : c = RgXn_powu_i(a,b,n);
873 112 : c = RgX_to_RgC(c,n); settyp(c,t_VEC); return c;
874 : }
875 :
876 : /* assume lg(V) >= n*d + 2 */
877 : static GEN
878 8645 : c_deflate(long n, long d, GEN v)
879 : {
880 8645 : long i, id, l = n+2;
881 : GEN w;
882 8645 : if (d == 1) return lg(v) == l ? v: vecslice(v, 1, l-1);
883 441 : w = cgetg(l, typ(v));
884 10724 : for (i = id = 1; i < l; i++, id += d) gel(w, i) = gel(v, id);
885 441 : return w;
886 : }
887 :
888 : static void
889 14 : err_cyclo(void)
890 14 : { pari_err_IMPL("changing cyclotomic fields in mf"); }
891 : /* Q(zeta_a) = Q(zeta_b) ? */
892 : static int
893 616 : same_cyc(long a, long b)
894 616 : { return (a == b) || (odd(a) && b == (a<<1)) || (odd(b) && a == (b<<1)); }
895 : /* need to combine elements in Q(CHI1) and Q(CHI2) with result in Q(CHI),
896 : * CHI = CHI1 * CHI2 or CHI / CHI2 times some character of order 2 */
897 : static GEN
898 2723 : chicompat(GEN CHI, GEN CHI1, GEN CHI2)
899 : {
900 2723 : long o1 = mfcharorder(CHI1);
901 2723 : long o2 = mfcharorder(CHI2), O, o;
902 : GEN T1, T2, P, Po;
903 2723 : if (o1 <= 2 && o2 <= 2) return NULL;
904 623 : o = mfcharorder(CHI);
905 623 : Po = mfcharpol(CHI);
906 623 : P = mfcharpol(CHI1);
907 623 : if (o1 == o2)
908 : {
909 21 : if (o1 == o) return NULL;
910 14 : if (!same_cyc(o1,o)) err_cyclo();
911 0 : return mkvec4(P, gen_1,gen_1, Qab_trace_init(o1, o, P, Po));
912 : }
913 602 : O = ulcm(o1, o2);
914 602 : if (!same_cyc(O,o)) err_cyclo();
915 602 : if (O != o1) P = (O == o2)? mfcharpol(CHI2): polcyclo(O, varn(P));
916 602 : T1 = o1 <= 2? gen_1: utoipos(O / o1);
917 602 : T2 = o2 <= 2? gen_1: utoipos(O / o2);
918 602 : return mkvec4(P, T1, T2, O == o? gen_1: Qab_trace_init(O, o, P, Po));
919 : }
920 : /* *F a vector of cyclotomic numbers */
921 : static void
922 7 : compatlift(GEN *F, long o, GEN P)
923 : {
924 : long i, l;
925 7 : GEN f = *F, g = cgetg_copy(f,&l);
926 56 : for (i = 1; i < l; i++)
927 : {
928 49 : GEN fi = lift_shallow(gel(f,i));
929 49 : gel(g,i) = gmodulo(typ(fi)==t_POL? RgX_inflate(fi,o): fi, P);
930 : }
931 7 : *F = g;
932 7 : }
933 : static void
934 651 : chicompatlift(GEN T, GEN *F, GEN *G)
935 : {
936 651 : long o1 = itou(gel(T,2)), o2 = itou(gel(T,3));
937 651 : GEN P = gel(T,1);
938 651 : if (o1 != 1) compatlift(F, o1, P);
939 651 : if (o2 != 1 && G) compatlift(G, o2, P);
940 651 : }
941 : static GEN
942 651 : chicompatfix(GEN T, GEN F)
943 : {
944 651 : GEN V = gel(T,4);
945 651 : if (typ(V) == t_VEC) F = gmodulo(QabV_tracerel(V, 0, F), gel(V,1));
946 651 : return F;
947 : }
948 :
949 : static GEN
950 637 : c_mul(long n, long d, GEN S)
951 : {
952 637 : pari_sp av = avma;
953 637 : long nd = n*d;
954 637 : GEN F = gel(S,2), G = gel(S,3);
955 637 : F = mfcoefs_i(F, nd, 1);
956 637 : G = mfcoefs_i(G, nd, 1);
957 637 : if (lg(S) == 5) chicompatlift(gel(S,4),&F,&G);
958 637 : F = c_deflate(n, d, RgV_mul_RgXn(F,G));
959 637 : if (lg(S) == 5) F = chicompatfix(gel(S,4), F);
960 637 : return gerepilecopy(av, F);
961 : }
962 : static GEN
963 112 : c_pow(long n, long d, GEN S)
964 : {
965 112 : pari_sp av = avma;
966 112 : long nd = n*d;
967 112 : GEN F = gel(S,2), a = gel(S,3), f = mfcoefs_i(F,nd,1);
968 112 : if (lg(S) == 5) chicompatlift(gel(S,4),&F, NULL);
969 112 : f = RgV_pows_RgXn(f, itos(a));
970 112 : f = c_deflate(n, d, f);
971 112 : if (lg(S) == 5) f = chicompatfix(gel(S,4), f);
972 112 : return gerepilecopy(av, f);
973 : }
974 :
975 : /* F * Theta */
976 : static GEN
977 448 : mfmultheta(GEN F)
978 : {
979 448 : if (typ(mf_get_gk(F)) == t_FRAC && mf_get_type(F) == t_MF_DIV)
980 : {
981 154 : GEN T = gel(F,3); /* hopefully mfTheta() */
982 154 : if (mf_get_type(T) == t_MF_THETA && mf_get_N(T) == 4) return gel(F,2);
983 : }
984 294 : return mfmul(F, mfTheta(NULL));
985 : }
986 :
987 : static GEN
988 42 : c_bracket(long n, long d, GEN S)
989 : {
990 42 : pari_sp av = avma;
991 42 : long i, nd = n*d;
992 42 : GEN F = gel(S,2), G = gel(S,3), tF, tG, C, mpow, res, gk, gl;
993 42 : GEN VF = mfcoefs_i(F, nd, 1);
994 42 : GEN VG = mfcoefs_i(G, nd, 1);
995 42 : ulong j, m = itou(gel(S,4));
996 :
997 42 : if (!n)
998 : {
999 14 : if (m > 0) { set_avma(av); return mkvec(gen_0); }
1000 7 : return gerepilecopy(av, mkvec(gmul(gel(VF, 1), gel(VG, 1))));
1001 : }
1002 28 : tF = cgetg(nd+2, t_VEC);
1003 28 : tG = cgetg(nd+2, t_VEC);
1004 28 : res = NULL; gk = mf_get_gk(F); gl = mf_get_gk(G);
1005 : /* pow[i,j+1] = i^j */
1006 28 : if (lg(S) == 6) chicompatlift(gel(S,5),&VF,&VG);
1007 28 : mpow = cgetg(m+2, t_MAT);
1008 28 : gel(mpow,1) = const_col(nd, gen_1);
1009 56 : for (j = 1; j <= m; j++)
1010 : {
1011 28 : GEN c = cgetg(nd+1, t_COL);
1012 28 : gel(mpow,j+1) = c;
1013 245 : for (i = 1; i <= nd; i++) gel(c,i) = muliu(gcoeff(mpow,i,j), i);
1014 : }
1015 28 : C = binomial(gaddgs(gk, m-1), m);
1016 28 : if (odd(m)) C = gneg(C);
1017 84 : for (j = 0; j <= m; j++)
1018 : { /* C = (-1)^(m-j) binom(m+l-1, j) binom(m+k-1,m-j) */
1019 : GEN c;
1020 56 : gel(tF,1) = j == 0? gel(VF,1): gen_0;
1021 56 : gel(tG,1) = j == m? gel(VG,1): gen_0;
1022 56 : gel(tF,2) = gel(VF,2); /* assume nd >= 1 */
1023 56 : gel(tG,2) = gel(VG,2);
1024 518 : for (i = 2; i <= nd; i++)
1025 : {
1026 462 : gel(tF, i+1) = gmul(gcoeff(mpow,i,j+1), gel(VF, i+1));
1027 462 : gel(tG, i+1) = gmul(gcoeff(mpow,i,m-j+1), gel(VG, i+1));
1028 : }
1029 56 : c = gmul(C, c_deflate(n, d, RgV_mul_RgXn(tF, tG)));
1030 56 : res = res? gadd(res, c): c;
1031 56 : if (j < m)
1032 56 : C = gdiv(gmul(C, gmulsg(m-j, gaddgs(gl,m-j-1))),
1033 28 : gmulsg(-(j+1), gaddgs(gk,j)));
1034 : }
1035 28 : if (lg(S) == 6) res = chicompatfix(gel(S,5), res);
1036 28 : return gerepileupto(av, res);
1037 : }
1038 : /* linear combination \sum L[j] vecF[j] */
1039 : static GEN
1040 2961 : c_linear(long n, long d, GEN F, GEN L, GEN dL)
1041 : {
1042 2961 : pari_sp av = avma;
1043 2961 : long j, l = lg(L);
1044 2961 : GEN S = NULL;
1045 10598 : for (j = 1; j < l; j++)
1046 : {
1047 7637 : GEN c = gel(L,j);
1048 7637 : if (gequal0(c)) continue;
1049 6881 : c = gmul(c, mfcoefs_i(gel(F,j), n, d));
1050 6881 : S = S? gadd(S,c): c;
1051 : }
1052 2961 : if (!S) return zerovec(n+1);
1053 2961 : if (!is_pm1(dL)) S = gdiv(S, dL);
1054 2961 : return gerepileupto(av, S);
1055 : }
1056 :
1057 : /* B_d(T_j Trace^new) as t_MF_BD(t_MF_HECKE(t_MF_NEWTRACE)) or
1058 : * t_MF_HECKE(t_MF_NEWTRACE)
1059 : * or t_MF_NEWTRACE in level N. Set d and j, return t_MF_NEWTRACE component*/
1060 : static GEN
1061 81662 : bhn_parse(GEN f, long *d, long *j)
1062 : {
1063 81662 : long t = mf_get_type(f);
1064 81662 : *d = *j = 1;
1065 81662 : if (t == t_MF_BD) { *d = itos(gel(f,3)); f = gel(f,2); t = mf_get_type(f); }
1066 81662 : if (t == t_MF_HECKE) { *j = gel(f,2)[1]; f = gel(f,3); }
1067 81662 : return f;
1068 : }
1069 : /* f as above, return the t_MF_NEWTRACE component */
1070 : static GEN
1071 31689 : bhn_newtrace(GEN f)
1072 : {
1073 31689 : long t = mf_get_type(f);
1074 31689 : if (t == t_MF_BD) { f = gel(f,2); t = mf_get_type(f); }
1075 31689 : if (t == t_MF_HECKE) f = gel(f,3);
1076 31689 : return f;
1077 : }
1078 : static int
1079 3780 : ok_bhn_linear(GEN vf)
1080 : {
1081 3780 : long i, N0 = 0, l = lg(vf);
1082 : GEN CHI, gk;
1083 3780 : if (l == 1) return 1;
1084 3780 : gk = mf_get_gk(gel(vf,1));
1085 3780 : CHI = mf_get_CHI(gel(vf,1));
1086 26943 : for (i = 1; i < l; i++)
1087 : {
1088 25480 : GEN f = bhn_newtrace(gel(vf,i));
1089 25480 : long N = mf_get_N(f);
1090 25480 : if (mf_get_type(f) != t_MF_NEWTRACE) return 0;
1091 23163 : if (N < N0) return 0; /* largest level must come last */
1092 23163 : N0 = N;
1093 23163 : if (!gequal(gk,mf_get_gk(f))) return 0; /* same k */
1094 23163 : if (!gequal(gel(mf_get_CHI(f),2), gel(CHI,2))) return 0; /* same CHI */
1095 : }
1096 1463 : return 1;
1097 : }
1098 :
1099 : /* vF not empty, same hypotheses as bhnmat_extend */
1100 : static GEN
1101 6314 : bhnmat_extend_nocache(GEN M, long N, long n, long d, GEN vF)
1102 : {
1103 : cachenew_t cache;
1104 6314 : long l = lg(vF);
1105 : GEN f;
1106 6314 : if (l == 1) return M? M: cgetg(1, t_MAT);
1107 6209 : f = bhn_newtrace(gel(vF,1)); /* N.B. mf_get_N(f) divides N */
1108 6209 : init_cachenew(&cache, n*d, N, f);
1109 6209 : M = bhnmat_extend(M, n, d, vF, &cache);
1110 6209 : dbg_cachenew(&cache); return M;
1111 : }
1112 : /* c_linear of "bhn" mf closures, same hypotheses as bhnmat_extend */
1113 : static GEN
1114 1652 : c_linear_bhn(long n, long d, GEN F)
1115 : {
1116 : pari_sp av;
1117 1652 : GEN M, v, vF = gel(F,2), L = gel(F,3), dL = gel(F,4);
1118 1652 : if (lg(L) == 1) return zerovec(n+1);
1119 1652 : av = avma;
1120 1652 : M = bhnmat_extend_nocache(NULL, mf_get_N(F), n, d, vF);
1121 1652 : v = RgM_RgC_mul(M,L); settyp(v, t_VEC);
1122 1652 : if (!is_pm1(dL)) v = gdiv(v, dL);
1123 1652 : return gerepileupto(av, v);
1124 : }
1125 :
1126 : /* c in K, K := Q[X]/(T) vz = vector of consecutive powers of root z of T
1127 : * attached to an embedding s: K -> C. Return s(c) in C */
1128 : static GEN
1129 84658 : Rg_embed1(GEN c, GEN vz)
1130 : {
1131 84658 : long t = typ(c);
1132 84658 : if (t == t_POLMOD) { c = gel(c,2); t = typ(c); }
1133 84658 : if (t == t_POL) c = RgX_RgV_eval(c, vz);
1134 84658 : return c;
1135 : }
1136 : /* return s(P) in C[X] */
1137 : static GEN
1138 910 : RgX_embed1(GEN P, GEN vz)
1139 : {
1140 : long i, l;
1141 910 : GEN Q = cgetg_copy(P, &l);
1142 910 : Q[1] = P[1];
1143 2373 : for (i = 2; i < l; i++) gel(Q,i) = Rg_embed1(gel(P,i), vz);
1144 910 : return normalizepol_lg(Q,l); /* normally a no-op */
1145 : }
1146 : /* return s(P) in C^n */
1147 : static GEN
1148 798 : vecembed1(GEN P, GEN vz)
1149 : {
1150 : long i, l;
1151 798 : GEN Q = cgetg_copy(P, &l);
1152 39858 : for (i = 1; i < l; i++) gel(Q,i) = Rg_embed1(gel(P,i), vz);
1153 798 : return Q;
1154 : }
1155 : /* P in L = K[X]/(U), K = Q[t]/T; s an embedding of K -> C attached
1156 : * to a root of T, extended to an embedding of L -> C attached to a root
1157 : * of s(U); vT powers of the root of T, vU powers of the root of s(U).
1158 : * Return s(P) in C^n */
1159 : static GEN
1160 13328 : Rg_embed2(GEN P, long vt, GEN vT, GEN vU)
1161 : {
1162 : long i, l;
1163 : GEN Q;
1164 13328 : P = liftpol_shallow(P);
1165 13328 : if (typ(P) != t_POL) return P;
1166 13300 : if (varn(P) == vt) return Rg_embed1(P, vT);
1167 : /* varn(P) == vx */
1168 13293 : Q = cgetg_copy(P, &l); Q[1] = P[1];
1169 39669 : for (i = 2; i < l; i++) gel(Q,i) = Rg_embed1(gel(P,i), vT);
1170 13293 : return Rg_embed1(Q, vU);
1171 : }
1172 : static GEN
1173 42 : vecembed2(GEN P, long vt, GEN vT, GEN vU)
1174 : {
1175 : long i, l;
1176 42 : GEN Q = cgetg_copy(P, &l);
1177 1050 : for (i = 1; i < l; i++) gel(Q,i) = Rg_embed2(gel(P,i), vt, vT, vU);
1178 42 : return Q;
1179 : }
1180 : static GEN
1181 532 : RgX_embed2(GEN P, long vt, GEN vT, GEN vU)
1182 : {
1183 : long i, l;
1184 532 : GEN Q = cgetg_copy(P, &l);
1185 3724 : for (i = 2; i < l; i++) gel(Q,i) = Rg_embed2(gel(P,i), vt, vT, vU);
1186 532 : Q[1] = P[1]; return normalizepol_lg(Q,l);
1187 : }
1188 : /* embed polynomial f in variable 0 [ may be a scalar ], E from getembed */
1189 : static GEN
1190 1645 : RgX_embed(GEN f, GEN E)
1191 : {
1192 : GEN vT;
1193 1645 : if (typ(f) != t_POL || varn(f) != 0) return mfembed(E, f);
1194 1603 : if (lg(E) == 1) return f;
1195 1407 : vT = gel(E,2);
1196 1407 : if (lg(E) == 3)
1197 875 : f = RgX_embed1(f, vT);
1198 : else
1199 532 : f = RgX_embed2(f, varn(gel(E,1)), vT, gel(E,3));
1200 1407 : return f;
1201 : }
1202 : /* embed vector, E from getembed */
1203 : GEN
1204 1694 : mfvecembed(GEN E, GEN v)
1205 : {
1206 : GEN vT;
1207 1694 : if (lg(E) == 1) return v;
1208 840 : vT = gel(E,2);
1209 840 : if (lg(E) == 3)
1210 798 : v = vecembed1(v, vT);
1211 : else
1212 42 : v = vecembed2(v, varn(gel(E,1)), vT, gel(E,3));
1213 840 : return v;
1214 : }
1215 : GEN
1216 70 : mfmatembed(GEN E, GEN f)
1217 : {
1218 : long i, l;
1219 : GEN g;
1220 70 : if (lg(E) == 1) return f;
1221 42 : g = cgetg_copy(f, &l);
1222 168 : for (i = 1; i < l; i++) gel(g,i) = mfvecembed(E, gel(f,i));
1223 42 : return g;
1224 : }
1225 : /* embed vector of polynomials in var 0 */
1226 : static GEN
1227 98 : RgXV_embed(GEN f, GEN E)
1228 : {
1229 : long i, l;
1230 : GEN v;
1231 98 : if (lg(E) == 1) return f;
1232 70 : v = cgetg_copy(f, &l);
1233 1358 : for (i = 1; i < l; i++) gel(v,i) = RgX_embed(gel(f,i), E);
1234 70 : return v;
1235 : }
1236 :
1237 : /* embed scalar */
1238 : GEN
1239 100663 : mfembed(GEN E, GEN f)
1240 : {
1241 : GEN vT;
1242 100663 : if (lg(E) == 1) return f;
1243 13587 : vT = gel(E,2);
1244 13587 : if (lg(E) == 3)
1245 4459 : f = Rg_embed1(f, vT);
1246 : else
1247 9128 : f = Rg_embed2(f, varn(gel(E,1)), vT, gel(E,3));
1248 13587 : return f;
1249 : }
1250 : /* vector of the sigma(f), sigma in vE */
1251 : static GEN
1252 322 : RgX_embedall(GEN f, GEN vE)
1253 : {
1254 322 : long i, l = lg(vE);
1255 : GEN v;
1256 322 : if (l == 2) return RgX_embed(f, gel(vE,1));
1257 35 : v = cgetg(l, t_VEC);
1258 105 : for (i = 1; i < l; i++) gel(v,i) = RgX_embed(f, gel(vE,i));
1259 35 : return v;
1260 : }
1261 : /* matrix whose colums are the sigma(v), sigma in vE */
1262 : static GEN
1263 343 : RgC_embedall(GEN v, GEN vE)
1264 : {
1265 343 : long j, l = lg(vE);
1266 343 : GEN M = cgetg(l, t_MAT);
1267 861 : for (j = 1; j < l; j++) gel(M,j) = mfvecembed(gel(vE,j), v);
1268 343 : return M;
1269 : }
1270 : /* vector of the sigma(v), sigma in vE */
1271 : static GEN
1272 4907 : Rg_embedall_i(GEN v, GEN vE)
1273 : {
1274 4907 : long j, l = lg(vE);
1275 4907 : GEN M = cgetg(l, t_VEC);
1276 14735 : for (j = 1; j < l; j++) gel(M,j) = mfembed(gel(vE,j), v);
1277 4907 : return M;
1278 : }
1279 : /* vector of the sigma(v), sigma in vE; if #vE == 1, return v */
1280 : static GEN
1281 95000 : Rg_embedall(GEN v, GEN vE)
1282 95000 : { return (lg(vE) == 2)? mfembed(gel(vE,1), v): Rg_embedall_i(v, vE); }
1283 :
1284 : static GEN
1285 833 : c_div_i(long n, GEN S)
1286 : {
1287 833 : GEN F = gel(S,2), G = gel(S,3);
1288 : GEN a0, a0i, H;
1289 833 : F = mfcoefs_i(F, n, 1);
1290 833 : G = mfcoefs_i(G, n, 1);
1291 833 : if (lg(S) == 5) chicompatlift(gel(S,4),&F,&G);
1292 833 : F = RgV_to_ser_full(F);
1293 833 : G = RgV_to_ser_full(G);
1294 833 : a0 = polcoef_i(G, 0, -1); /* != 0 */
1295 833 : if (gequal1(a0)) a0 = a0i = NULL;
1296 : else
1297 : {
1298 602 : a0i = ginv(a0);
1299 602 : G = gmul(ser_unscale(G,a0), a0i);
1300 602 : F = gmul(ser_unscale(F,a0), a0i);
1301 : }
1302 833 : H = gdiv(F, G);
1303 833 : if (a0) H = ser_unscale(H,a0i);
1304 833 : H = sertovecslice(H, n);
1305 833 : if (lg(S) == 5) H = chicompatfix(gel(S,4), H);
1306 833 : return H;
1307 : }
1308 : static GEN
1309 833 : c_div(long n, long d, GEN S)
1310 : {
1311 833 : pari_sp av = avma;
1312 833 : GEN D = (d==1)? c_div_i(n, S): c_deflate(n, d, c_div_i(n*d, S));
1313 833 : return gerepilecopy(av, D);
1314 : }
1315 :
1316 : static GEN
1317 35 : c_shift(long n, long d, GEN F, GEN gsh)
1318 : {
1319 35 : pari_sp av = avma;
1320 : GEN vF;
1321 35 : long sh = itos(gsh), n1 = n*d + sh;
1322 35 : if (n1 < 0) return zerovec(n+1);
1323 35 : vF = mfcoefs_i(F, n1, 1);
1324 35 : if (sh < 0) vF = shallowconcat(zerovec(-sh), vF);
1325 35 : else vF = vecslice(vF, sh+1, n1+1);
1326 35 : return gerepilecopy(av, c_deflate(n, d, vF));
1327 : }
1328 :
1329 : static GEN
1330 147 : c_deriv(long n, long d, GEN F, GEN gm)
1331 : {
1332 147 : pari_sp av = avma;
1333 147 : GEN V = mfcoefs_i(F, n, d), res;
1334 147 : long i, m = itos(gm);
1335 147 : if (!m) return V;
1336 147 : res = cgetg(n+2, t_VEC); gel(res,1) = gen_0;
1337 147 : if (m < 0)
1338 49 : { for (i=1; i <= n; i++) gel(res, i+1) = gdiv(gel(V, i+1), powuu(i,-m)); }
1339 : else
1340 1953 : { for (i=1; i <= n; i++) gel(res, i+1) = gmul(gel(V,i+1), powuu(i,m)); }
1341 147 : return gerepileupto(av, res);
1342 : }
1343 :
1344 : static GEN
1345 14 : c_derivE2(long n, long d, GEN F, GEN gm)
1346 : {
1347 14 : pari_sp av = avma;
1348 : GEN VF, VE, res, tmp, gk;
1349 14 : long i, m = itos(gm), nd;
1350 14 : if (m == 0) return mfcoefs_i(F, n, d);
1351 14 : nd = n*d;
1352 14 : VF = mfcoefs_i(F, nd, 1); VE = mfcoefs_i(mfEk(2), nd, 1);
1353 14 : gk = mf_get_gk(F);
1354 14 : if (m == 1)
1355 : {
1356 7 : res = cgetg(n+2, t_VEC);
1357 56 : for (i = 0; i <= n; i++) gel(res, i+1) = gmulsg(i, gel(VF, i*d+1));
1358 7 : tmp = c_deflate(n, d, RgV_mul_RgXn(VF, VE));
1359 7 : return gerepileupto(av, gsub(res, gmul(gdivgu(gk, 12), tmp)));
1360 : }
1361 : else
1362 : {
1363 : long j;
1364 35 : for (j = 1; j <= m; j++)
1365 : {
1366 28 : tmp = RgV_mul_RgXn(VF, VE);
1367 140 : for (i = 0; i <= nd; i++) gel(VF, i+1) = gmulsg(i, gel(VF, i+1));
1368 28 : VF = gsub(VF, gmul(gdivgu(gaddgs(gk, 2*(j-1)), 12), tmp));
1369 : }
1370 7 : return gerepilecopy(av, c_deflate(n, d, VF));
1371 : }
1372 : }
1373 :
1374 : /* Twist by the character (D/.) */
1375 : static GEN
1376 7 : c_twist(long n, long d, GEN F, GEN D)
1377 : {
1378 7 : pari_sp av = avma;
1379 7 : GEN V = mfcoefs_i(F, n, d), res = cgetg(n+2, t_VEC);
1380 : long i;
1381 119 : for (i = 0; i <= n; i++)
1382 112 : gel(res, i + 1) = gmulsg(krois(D, i), gel(V, i+1));
1383 7 : return gerepileupto(av, res);
1384 : }
1385 :
1386 : /* form F given by closure, compute T(n)(F) as closure */
1387 : static GEN
1388 994 : c_hecke(long m, long l, GEN DATA, GEN F)
1389 : {
1390 994 : pari_sp av = avma;
1391 994 : return gerepilecopy(av, hecke_i(m, l, NULL, F, DATA));
1392 : }
1393 : static GEN
1394 140 : c_const(long n, long d, GEN C)
1395 : {
1396 140 : GEN V = zerovec(n+1);
1397 140 : long i, j, l = lg(C);
1398 140 : if (l > d*n+2) l = d*n+2;
1399 189 : for (i = j = 1; i < l; i+=d, j++) gel(V, j) = gcopy(gel(C,i));
1400 140 : return V;
1401 : }
1402 :
1403 : /* m > 0 */
1404 : static GEN
1405 469 : eta3_ZXn(long m)
1406 : {
1407 469 : long l = m+2, n, k;
1408 469 : GEN P = cgetg(l,t_POL);
1409 469 : P[1] = evalsigne(1)|evalvarn(0);
1410 6489 : for (n = 2; n < l; n++) gel(P,n) = gen_0;
1411 469 : for (n = k = 0;; n++)
1412 : {
1413 2611 : if (k + n >= m) { setlg(P, k+3); return P; }
1414 2142 : k += n;
1415 : /* now k = n(n+1) / 2 */
1416 2142 : gel(P, k+2) = odd(n)? utoineg(2*n+1): utoipos(2*n+1);
1417 : }
1418 : }
1419 :
1420 : static GEN
1421 476 : c_delta(long n, long d)
1422 : {
1423 476 : pari_sp ltop = avma;
1424 476 : long N = n*d;
1425 : GEN e;
1426 476 : if (!N) return mkvec(gen_0);
1427 469 : e = eta3_ZXn(N);
1428 469 : e = ZXn_sqr(e,N);
1429 469 : e = ZXn_sqr(e,N);
1430 469 : e = ZXn_sqr(e,N); /* eta(x)^24 */
1431 469 : settyp(e, t_VEC);
1432 469 : gel(e,1) = gen_0; /* Delta(x) = x*eta(x)^24 as a t_VEC */
1433 469 : return gerepilecopy(ltop, c_deflate(n, d, e));
1434 : }
1435 :
1436 : /* return s(d) such that s|f <=> d | f^2 */
1437 : static long
1438 56 : mysqrtu(ulong d)
1439 : {
1440 56 : GEN fa = myfactoru(d), P = gel(fa,1), E = gel(fa,2);
1441 56 : long l = lg(P), i, s = 1;
1442 140 : for (i = 1; i < l; i++) s *= upowuu(P[i], (E[i]+1)>>1);
1443 56 : return s;
1444 : }
1445 : static GEN
1446 1855 : c_theta(long n, long d, GEN psi)
1447 : {
1448 1855 : long lim = usqrt(n*d), F = mfcharmodulus(psi), par = mfcharparity(psi);
1449 1855 : long f, d2 = d == 1? 1: mysqrtu(d);
1450 1855 : GEN V = zerovec(n + 1);
1451 8134 : for (f = d2; f <= lim; f += d2)
1452 6279 : if (ugcd(F, f) == 1)
1453 : {
1454 6272 : pari_sp av = avma;
1455 6272 : GEN c = mfchareval(psi, f);
1456 6272 : gel(V, f*f/d + 1) = gerepileupto(av, par < 0? gmulgu(c,2*f): gmul2n(c,1));
1457 : }
1458 1855 : if (F == 1) gel(V, 1) = gen_1;
1459 1855 : return V; /* no gerepile needed */
1460 : }
1461 :
1462 : static GEN
1463 203 : c_etaquo(long n, long d, GEN eta, GEN gs)
1464 : {
1465 203 : pari_sp av = avma;
1466 203 : long s = itos(gs), nd = n*d, nds = nd - s + 1;
1467 : GEN c;
1468 203 : if (nds <= 0) return zerovec(n+1);
1469 182 : c = RgX_to_RgC(eta_product_ZXn(eta, nds), nds); settyp(c, t_VEC);
1470 182 : if (s > 0) c = shallowconcat(zerovec(s), c);
1471 182 : return gerepilecopy(av, c_deflate(n, d, c));
1472 : }
1473 :
1474 : static GEN
1475 77 : c_ell(long n, long d, GEN E)
1476 : {
1477 77 : pari_sp av = avma;
1478 : GEN v;
1479 77 : if (d == 1) return gconcat(gen_0, ellan(E, n));
1480 7 : v = vec_prepend(ellan(E, n*d), gen_0);
1481 7 : return gerepilecopy(av, c_deflate(n, d, v));
1482 : }
1483 :
1484 : static GEN
1485 21 : c_cusptrace(long n, long d, GEN F)
1486 : {
1487 21 : pari_sp av = avma;
1488 21 : GEN D = gel(F,2), res = cgetg(n+2, t_VEC);
1489 21 : long i, N = mf_get_N(F), k = mf_get_k(F);
1490 21 : gel(res, 1) = gen_0;
1491 140 : for (i = 1; i <= n; i++)
1492 119 : gel(res, i+1) = mfcusptrace_i(N, k, i*d, mydivisorsu(i*d), D);
1493 21 : return gerepilecopy(av, res);
1494 : }
1495 :
1496 : static GEN
1497 1582 : c_newtrace(long n, long d, GEN F)
1498 : {
1499 1582 : pari_sp av = avma;
1500 : cachenew_t cache;
1501 1582 : long N = mf_get_N(F);
1502 : GEN v;
1503 1582 : init_cachenew(&cache, n == 1? 1: n*d, N, F);
1504 1582 : v = colnewtrace(0, n, d, N, mf_get_k(F), &cache);
1505 1582 : settyp(v, t_VEC); return gerepilecopy(av, v);
1506 : }
1507 :
1508 : static GEN
1509 7196 : c_Bd(long n, long d, GEN F, GEN A)
1510 : {
1511 7196 : pari_sp av = avma;
1512 7196 : long a = itou(A), ad = ugcd(a,d), aad = a/ad, i, j;
1513 7196 : GEN w, v = mfcoefs_i(F, n/aad, d/ad);
1514 7196 : if (a == 1) return v;
1515 7196 : n++; w = zerovec(n);
1516 209139 : for (i = j = 1; j <= n; i++, j += aad) gel(w,j) = gcopy(gel(v,i));
1517 7196 : return gerepileupto(av, w);
1518 : }
1519 :
1520 : static GEN
1521 5579 : c_dihedral(long n, long d, GEN F)
1522 : {
1523 5579 : pari_sp av = avma;
1524 5579 : GEN CHI = mf_get_CHI(F);
1525 5579 : GEN w = gel(F,3), V = dihan(gel(F,2), w, gel(F,4), mfcharorder(CHI), n*d);
1526 5579 : GEN Tinit = gel(w,3), Pm = gel(Tinit,1);
1527 5579 : GEN A = c_deflate(n, d, V);
1528 5579 : if (degpol(Pm) == 1 || RgV_is_ZV(A)) return gerepilecopy(av, A);
1529 1043 : return gerepileupto(av, gmodulo(A, Pm));
1530 : }
1531 :
1532 : static GEN
1533 315 : c_mfEH(long n, long d, GEN F)
1534 : {
1535 315 : pari_sp av = avma;
1536 : GEN v, M, A;
1537 315 : long i, r = mf_get_r(F);
1538 315 : if (n == 1)
1539 14 : return gerepilecopy(av, mkvec2(mfEHcoef(r,0),mfEHcoef(r,d)));
1540 : /* speedup mfcoef */
1541 301 : if (r == 1)
1542 : {
1543 70 : v = cgetg(n+2, t_VEC);
1544 70 : gel(v,1) = sstoQ(-1,12);
1545 83258 : for (i = 1; i <= n; i++)
1546 : {
1547 83188 : long id = i*d, a = id & 3;
1548 83188 : gel(v,i+1) = (a==1 || a==2)? gen_0: uutoQ(hclassno6u(id), 6);
1549 : }
1550 70 : return v; /* no gerepile needed */
1551 : }
1552 231 : M = mfEHmat(n*d+1,r);
1553 231 : if (d > 1)
1554 : {
1555 35 : long l = lg(M);
1556 119 : for (i = 1; i < l; i++) gel(M,i) = c_deflate(n, d, gel(M,i));
1557 : }
1558 231 : A = gel(F,2); /* [num(B), den(B)] */
1559 231 : v = RgC_Rg_div(RgM_RgC_mul(M, gel(A,1)), gel(A,2));
1560 231 : settyp(v,t_VEC); return gerepileupto(av, v);
1561 : }
1562 :
1563 : static GEN
1564 11228 : c_mfeisen(long n, long d, GEN F)
1565 : {
1566 11228 : pari_sp av = avma;
1567 11228 : GEN v, vchi, E0, P, T, CHI, gk = mf_get_gk(F);
1568 : long i, k;
1569 11228 : if (typ(gk) != t_INT) return c_mfEH(n, d, F);
1570 10913 : k = itou(gk);
1571 10913 : vchi = gel(F,2);
1572 10913 : E0 = gel(vchi,1);
1573 10913 : T = gel(vchi,2);
1574 10913 : P = gel(T,1);
1575 10913 : CHI = gel(vchi,3);
1576 10913 : v = cgetg(n+2, t_VEC);
1577 10913 : gel(v, 1) = gcopy(E0); /* E(0) */
1578 10913 : if (lg(vchi) == 5)
1579 : { /* E_k(chi1,chi2) */
1580 8820 : GEN CHI2 = gel(vchi,4), F3 = gel(F,3);
1581 8820 : long ord = F3[1], j = F3[2];
1582 508634 : for (i = 1; i <= n; i++) gel(v, i+1) = sigchi2(k, CHI, CHI2, i*d, ord);
1583 8820 : v = QabV_tracerel(T, j, v);
1584 : }
1585 : else
1586 : { /* E_k(chi) */
1587 26285 : for (i = 1; i <= n; i++) gel(v, i+1) = sigchi(k, CHI, i*d);
1588 : }
1589 10913 : if (degpol(P) != 1 && !RgV_is_QV(v)) return gerepileupto(av, gmodulo(v, P));
1590 7980 : return gerepilecopy(av, v);
1591 : }
1592 :
1593 : /* N^k * (D * B_k)(x/N), set D = denom(B_k) */
1594 : static GEN
1595 1561 : bern_init(long N, long k, GEN *pD)
1596 1561 : { return ZX_rescale(Q_remove_denom(bernpol(k, 0), pD), utoi(N)); }
1597 :
1598 : /* L(chi_D, 1-k) */
1599 : static GEN
1600 28 : lfunquadneg_naive(long D, long k)
1601 : {
1602 : GEN B, dS, S;
1603 28 : long r, N = labs(D);
1604 : pari_sp av;
1605 28 : if (k == 1 && N == 1) return gneg(ghalf);
1606 28 : B = bern_init(N, k, &dS);
1607 28 : dS = mul_denom(dS, stoi(-N*k));
1608 28 : av = avma;
1609 7175 : for (r = 0, S = gen_0; r < N; r++)
1610 : {
1611 7147 : long c = kross(D, r);
1612 7147 : if (c)
1613 : {
1614 5152 : GEN t = ZX_Z_eval(B, utoi(r));
1615 5152 : S = c > 0 ? addii(S, t) : subii(S, t);
1616 5152 : S = gerepileuptoint(av, S);
1617 : }
1618 : }
1619 28 : return gdiv(S, dS);
1620 : }
1621 :
1622 : /* Returns vector of coeffs from F[0], F[d], ..., F[d*n] */
1623 : static GEN
1624 36365 : mfcoefs_i(GEN F, long n, long d)
1625 : {
1626 36365 : if (n < 0) return gen_0;
1627 36365 : switch(mf_get_type(F))
1628 : {
1629 140 : case t_MF_CONST: return c_const(n, d, gel(F,2));
1630 11228 : case t_MF_EISEN: return c_mfeisen(n, d, F);
1631 812 : case t_MF_Ek: return c_Ek(n, d, F);
1632 476 : case t_MF_DELTA: return c_delta(n, d);
1633 1617 : case t_MF_THETA: return c_theta(n, d, gel(F,2));
1634 203 : case t_MF_ETAQUO: return c_etaquo(n, d, gel(F,2), gel(F,3));
1635 77 : case t_MF_ELL: return c_ell(n, d, gel(F,2));
1636 637 : case t_MF_MUL: return c_mul(n, d, F);
1637 112 : case t_MF_POW: return c_pow(n, d, F);
1638 42 : case t_MF_BRACKET: return c_bracket(n, d, F);
1639 2961 : case t_MF_LINEAR: return c_linear(n, d, gel(F,2), gel(F,3), gel(F,4));
1640 1652 : case t_MF_LINEAR_BHN: return c_linear_bhn(n, d, F);
1641 833 : case t_MF_DIV: return c_div(n, d, F);
1642 35 : case t_MF_SHIFT: return c_shift(n, d, gel(F,2), gel(F,3));
1643 147 : case t_MF_DERIV: return c_deriv(n, d, gel(F,2), gel(F,3));
1644 14 : case t_MF_DERIVE2: return c_derivE2(n, d, gel(F,2), gel(F,3));
1645 7 : case t_MF_TWIST: return c_twist(n, d, gel(F,2), gel(F,3));
1646 994 : case t_MF_HECKE: return c_hecke(n, d, gel(F,2), gel(F,3));
1647 7196 : case t_MF_BD: return c_Bd(n, d, gel(F,2), gel(F,3));
1648 21 : case t_MF_TRACE: return c_cusptrace(n, d, F);
1649 1582 : case t_MF_NEWTRACE: return c_newtrace(n, d, F);
1650 5579 : case t_MF_DIHEDRAL: return c_dihedral(n, d, F);
1651 : default: pari_err_TYPE("mfcoefs",F); return NULL;/*LCOV_EXCL_LINE*/
1652 : }
1653 : }
1654 :
1655 : static GEN
1656 385 : matdeflate(long n, long d, GEN M)
1657 : {
1658 : long i, l;
1659 : GEN A;
1660 : /* if (d == 1) return M; */
1661 385 : A = cgetg_copy(M,&l);
1662 1575 : for (i = 1; i < l; i++) gel(A,i) = c_deflate(n,d,gel(M,i));
1663 385 : return A;
1664 : }
1665 : static int
1666 5747 : space_is_cusp(long space) { return space != mf_FULL && space != mf_EISEN; }
1667 : /* safe with flraw mf */
1668 : static GEN
1669 2576 : mfcoefs_mf(GEN mf, long n, long d)
1670 : {
1671 2576 : GEN MS, ME, E = MF_get_E(mf), S = MF_get_S(mf), M = MF_get_M(mf);
1672 2576 : long lE = lg(E), lS = lg(S), l = lE+lS-1;
1673 :
1674 2576 : if (l == 1) return cgetg(1, t_MAT);
1675 2464 : if (typ(M) == t_MAT && lg(M) != 1 && (n+1)*d < nbrows(M))
1676 21 : return matdeflate(n, d, M); /*cached; lg = 1 is possible from mfinit */
1677 2443 : ME = (lE == 1)? cgetg(1, t_MAT): mfvectomat(E, n, d);
1678 2443 : if (lS == 1)
1679 448 : MS = cgetg(1, t_MAT);
1680 1995 : else if (mf_get_type(gel(S,1)) == t_MF_DIV) /*k 1/2-integer or k=1 (exotic)*/
1681 364 : MS = matdeflate(n,d, mflineardivtomat(MF_get_N(mf), S, n*d));
1682 1631 : else if (MF_get_k(mf) == 1) /* k = 1 (dihedral) */
1683 : {
1684 308 : GEN M = mfvectomat(gmael(S,1,2), n, d);
1685 : long i;
1686 308 : MS = cgetg(lS, t_MAT);
1687 1589 : for (i = 1; i < lS; i++)
1688 : {
1689 1281 : GEN f = gel(S,i), dc = gel(f,4), c = RgM_RgC_mul(M, gel(f,3));
1690 1281 : if (!equali1(dc)) c = RgC_Rg_div(c,dc);
1691 1281 : gel(MS,i) = c;
1692 : }
1693 : }
1694 : else /* k >= 2 integer */
1695 1323 : MS = bhnmat_extend_nocache(NULL, MF_get_N(mf), n, d, S);
1696 2443 : return shallowconcat(ME,MS);
1697 : }
1698 : GEN
1699 3787 : mfcoefs(GEN F, long n, long d)
1700 : {
1701 3787 : if (!checkmf_i(F))
1702 : {
1703 42 : pari_sp av = avma;
1704 42 : GEN mf = checkMF_i(F); if (!mf) pari_err_TYPE("mfcoefs", F);
1705 42 : return gerepilecopy(av, mfcoefs_mf(mf,n,d));
1706 : }
1707 3745 : if (d <= 0) pari_err_DOMAIN("mfcoefs", "d", "<=", gen_0, stoi(d));
1708 3745 : if (n < 0) return cgetg(1, t_VEC);
1709 3745 : return mfcoefs_i(F, n, d);
1710 : }
1711 :
1712 : /* assume k >= 0 */
1713 : static GEN
1714 308 : mfak_i(GEN F, long k)
1715 : {
1716 308 : if (!k) return gel(mfcoefs_i(F,0,1), 1);
1717 154 : return gel(mfcoefs_i(F,1,k), 2);
1718 : }
1719 : GEN
1720 154 : mfcoef(GEN F, long n)
1721 : {
1722 154 : pari_sp av = avma;
1723 154 : if (!checkmf_i(F)) pari_err_TYPE("mfcoef",F);
1724 154 : return n < 0? gen_0: gerepilecopy(av, mfak_i(F, n));
1725 : }
1726 :
1727 : static GEN
1728 126 : paramconst() { return tagparams(t_MF_CONST, mkNK(1,0,mfchartrivial())); }
1729 : static GEN
1730 84 : mftrivial(void) { retmkvec2(paramconst(), cgetg(1,t_VEC)); }
1731 : static GEN
1732 42 : mf1(void) { retmkvec2(paramconst(), mkvec(gen_1)); }
1733 :
1734 : /* induce mfchar CHI to G */
1735 : static GEN
1736 307783 : induce(GEN G, GEN CHI)
1737 : {
1738 : GEN o, chi;
1739 307783 : if (typ(CHI) == t_INT) /* Kronecker */
1740 : {
1741 300776 : chi = znchar_quad(G, CHI);
1742 300776 : o = ZV_equal0(chi)? gen_1: gen_2;
1743 300776 : CHI = mkvec4(G,chi,o,cgetg(1,t_VEC));
1744 : }
1745 : else
1746 : {
1747 7007 : if (mfcharmodulus(CHI) == itos(znstar_get_N(G))) return CHI;
1748 6391 : CHI = leafcopy(CHI);
1749 6391 : chi = zncharinduce(gel(CHI,1), gel(CHI,2), G);
1750 6391 : gel(CHI,1) = G;
1751 6391 : gel(CHI,2) = chi;
1752 : }
1753 307167 : return CHI;
1754 : }
1755 : /* induce mfchar CHI to znstar(N) */
1756 : static GEN
1757 42364 : induceN(long N, GEN CHI)
1758 : {
1759 42364 : if (mfcharmodulus(CHI) != N) CHI = induce(znstar0(utoipos(N),1), CHI);
1760 42364 : return CHI;
1761 : }
1762 : /* *pCHI1 and *pCHI2 are mfchar, induce to common modulus */
1763 : static void
1764 6419 : char2(GEN *pCHI1, GEN *pCHI2)
1765 : {
1766 6419 : GEN CHI1 = *pCHI1, G1 = gel(CHI1,1), N1 = znstar_get_N(G1);
1767 6419 : GEN CHI2 = *pCHI2, G2 = gel(CHI2,1), N2 = znstar_get_N(G2);
1768 6419 : if (!equalii(N1,N2))
1769 : {
1770 4851 : GEN G, d = gcdii(N1,N2);
1771 4851 : if (equalii(N2,d)) *pCHI2 = induce(G1, CHI2);
1772 1540 : else if (equalii(N1,d)) *pCHI1 = induce(G2, CHI1);
1773 : else
1774 : {
1775 154 : if (!equali1(d)) N2 = diviiexact(N2,d);
1776 154 : G = znstar0(mulii(N1,N2), 1);
1777 154 : *pCHI1 = induce(G, CHI1);
1778 154 : *pCHI2 = induce(G, CHI2);
1779 : }
1780 : }
1781 6419 : }
1782 : /* mfchar or charinit wrt same modulus; outputs a mfchar */
1783 : static GEN
1784 301861 : mfcharmul_i(GEN CHI1, GEN CHI2)
1785 : {
1786 301861 : GEN G = gel(CHI1,1), chi3 = zncharmul(G, gel(CHI1,2), gel(CHI2,2));
1787 301861 : return mfcharGL(G, chi3);
1788 : }
1789 : /* mfchar or charinit; outputs a mfchar */
1790 : static GEN
1791 1106 : mfcharmul(GEN CHI1, GEN CHI2)
1792 : {
1793 1106 : char2(&CHI1, &CHI2); return mfcharmul_i(CHI1,CHI2);
1794 : }
1795 : /* mfchar or charinit; outputs a mfchar */
1796 : static GEN
1797 147 : mfcharpow(GEN CHI, GEN n)
1798 : {
1799 : GEN G, chi;
1800 147 : G = gel(CHI,1); chi = zncharpow(G, gel(CHI,2), n);
1801 147 : return mfchartoprimitive(mfcharGL(G, chi), NULL);
1802 : }
1803 : /* mfchar or charinit wrt same modulus; outputs a mfchar */
1804 : static GEN
1805 5313 : mfchardiv_i(GEN CHI1, GEN CHI2)
1806 : {
1807 5313 : GEN G = gel(CHI1,1), chi3 = znchardiv(G, gel(CHI1,2), gel(CHI2,2));
1808 5313 : return mfcharGL(G, chi3);
1809 : }
1810 : /* mfchar or charinit; outputs a mfchar */
1811 : static GEN
1812 5313 : mfchardiv(GEN CHI1, GEN CHI2)
1813 : {
1814 5313 : char2(&CHI1, &CHI2); return mfchardiv_i(CHI1,CHI2);
1815 : }
1816 : static GEN
1817 56 : mfcharconj(GEN CHI)
1818 : {
1819 56 : CHI = leafcopy(CHI);
1820 56 : gel(CHI,2) = zncharconj(gel(CHI,1), gel(CHI,2));
1821 56 : return CHI;
1822 : }
1823 :
1824 : /* CHI mfchar, assume 4 | N. Multiply CHI by \chi_{-4} */
1825 : static GEN
1826 980 : mfchilift(GEN CHI, long N)
1827 : {
1828 980 : CHI = induceN(N, CHI);
1829 980 : return mfcharmul_i(CHI, induce(gel(CHI,1), stoi(-4)));
1830 : }
1831 : /* CHI defined mod N, N4 = N/4;
1832 : * if CHI is defined mod N4 return CHI;
1833 : * else if CHI' = CHI*(-4,.) is defined mod N4, return CHI' (primitive)
1834 : * else error */
1835 : static GEN
1836 35 : mfcharchiliftprim(GEN CHI, long N4)
1837 : {
1838 35 : long FC = mfcharconductor(CHI);
1839 : GEN CHIP;
1840 35 : if (N4 % FC == 0) return CHI;
1841 14 : CHIP = mfchartoprimitive(mfchilift(CHI, N4 << 2), &FC);
1842 14 : if (N4 % FC) pari_err_TYPE("mfkohnenbasis [incorrect CHI]", CHI);
1843 14 : return CHIP;
1844 : }
1845 : /* ensure CHI(-1) = (-1)^k [k integer] or 1 [half-integer], by multiplying
1846 : * by (-4/.) if needed */
1847 : static GEN
1848 2821 : mfchiadjust(GEN CHI, GEN gk, long N)
1849 : {
1850 2821 : long par = mfcharparity(CHI);
1851 2821 : if (typ(gk) == t_INT && mpodd(gk)) par = -par;
1852 2821 : return par == 1 ? CHI : mfchilift(CHI, N);
1853 : }
1854 :
1855 : static GEN
1856 3878 : mfsamefield(GEN T, GEN P, GEN Q)
1857 : {
1858 3878 : if (degpol(P) == 1) return Q;
1859 602 : if (degpol(Q) == 1) return P;
1860 511 : if (!gequal(P,Q)) pari_err_TYPE("mfsamefield [different fields]",mkvec2(P,Q));
1861 504 : if (T) err_cyclo();
1862 504 : return P;
1863 : }
1864 :
1865 : GEN
1866 455 : mfmul(GEN f, GEN g)
1867 : {
1868 455 : pari_sp av = avma;
1869 : GEN T, N, K, NK, CHI, CHIf, CHIg;
1870 455 : if (!checkmf_i(f)) pari_err_TYPE("mfmul",f);
1871 455 : if (!checkmf_i(g)) pari_err_TYPE("mfmul",g);
1872 455 : N = lcmii(mf_get_gN(f), mf_get_gN(g));
1873 455 : K = gadd(mf_get_gk(f), mf_get_gk(g));
1874 455 : CHIf = mf_get_CHI(f);
1875 455 : CHIg = mf_get_CHI(g);
1876 455 : CHI = mfchiadjust(mfcharmul(CHIf,CHIg), K, itos(N));
1877 455 : T = chicompat(CHI, CHIf, CHIg);
1878 455 : NK = mkgNK(N, K, CHI, mfsamefield(T, mf_get_field(f), mf_get_field(g)));
1879 448 : return gerepilecopy(av, T? tag3(t_MF_MUL,NK,f,g,T): tag2(t_MF_MUL,NK,f,g));
1880 : }
1881 : GEN
1882 77 : mfpow(GEN f, long n)
1883 : {
1884 77 : pari_sp av = avma;
1885 : GEN T, KK, NK, gn, CHI, CHIf;
1886 77 : if (!checkmf_i(f)) pari_err_TYPE("mfpow",f);
1887 77 : if (!n) return mf1();
1888 77 : if (n == 1) return gcopy(f);
1889 77 : KK = gmulsg(n,mf_get_gk(f));
1890 77 : gn = stoi(n);
1891 77 : CHIf = mf_get_CHI(f);
1892 77 : CHI = mfchiadjust(mfcharpow(CHIf,gn), KK, mf_get_N(f));
1893 77 : T = chicompat(CHI, CHIf, CHIf);
1894 70 : NK = mkgNK(mf_get_gN(f), KK, CHI, mf_get_field(f));
1895 70 : return gerepilecopy(av, T? tag3(t_MF_POW,NK,f,gn,T): tag2(t_MF_POW,NK,f,gn));
1896 : }
1897 : GEN
1898 28 : mfbracket(GEN f, GEN g, long m)
1899 : {
1900 28 : pari_sp av = avma;
1901 : GEN T, N, K, NK, CHI, CHIf, CHIg;
1902 28 : if (!checkmf_i(f)) pari_err_TYPE("mfbracket",f);
1903 28 : if (!checkmf_i(g)) pari_err_TYPE("mfbracket",g);
1904 28 : if (m < 0) pari_err_TYPE("mfbracket [m<0]",stoi(m));
1905 28 : K = gaddgs(gadd(mf_get_gk(f), mf_get_gk(g)), 2*m);
1906 28 : if (gsigne(K) < 0) pari_err_IMPL("mfbracket for this form");
1907 28 : N = lcmii(mf_get_gN(f), mf_get_gN(g));
1908 28 : CHIf = mf_get_CHI(f);
1909 28 : CHIg = mf_get_CHI(g);
1910 28 : CHI = mfcharmul(CHIf, CHIg);
1911 28 : CHI = mfchiadjust(CHI, K, itou(N));
1912 28 : T = chicompat(CHI, CHIf, CHIg);
1913 28 : NK = mkgNK(N, K, CHI, mfsamefield(T, mf_get_field(f), mf_get_field(g)));
1914 56 : return gerepilecopy(av, T? tag4(t_MF_BRACKET, NK, f, g, utoi(m), T)
1915 28 : : tag3(t_MF_BRACKET, NK, f, g, utoi(m)));
1916 : }
1917 :
1918 : /* remove 0 entries in L */
1919 : static int
1920 1260 : mflinear_strip(GEN *pF, GEN *pL)
1921 : {
1922 1260 : pari_sp av = avma;
1923 1260 : GEN F = *pF, L = *pL;
1924 1260 : long i, j, l = lg(L);
1925 1260 : GEN F2 = cgetg(l, t_VEC), L2 = cgetg(l, t_VEC);
1926 7693 : for (i = j = 1; i < l; i++)
1927 : {
1928 6433 : if (gequal0(gel(L,i))) continue;
1929 3633 : gel(F2,j) = gel(F,i);
1930 3633 : gel(L2,j) = gel(L,i); j++;
1931 : }
1932 1260 : if (j == l) set_avma(av);
1933 : else
1934 : {
1935 371 : setlg(F2,j); *pF = F2;
1936 371 : setlg(L2,j); *pL = L2;
1937 : }
1938 1260 : return (j > 1);
1939 : }
1940 : static GEN
1941 6356 : taglinear_i(long t, GEN NK, GEN F, GEN L)
1942 : {
1943 : GEN dL;
1944 6356 : L = Q_remove_denom(L, &dL); if (!dL) dL = gen_1;
1945 6356 : return tag3(t, NK, F, L, dL);
1946 : }
1947 : static GEN
1948 2569 : taglinear(GEN NK, GEN F, GEN L)
1949 : {
1950 2569 : long t = ok_bhn_linear(F)? t_MF_LINEAR_BHN: t_MF_LINEAR;
1951 2569 : return taglinear_i(t, NK, F, L);
1952 : }
1953 : /* assume F has parameters NK = [N,K,CHI] */
1954 : static GEN
1955 294 : mflinear_i(GEN NK, GEN F, GEN L)
1956 : {
1957 294 : if (!mflinear_strip(&F,&L)) return mftrivial();
1958 294 : return taglinear(NK, F,L);
1959 : }
1960 : static GEN
1961 511 : mflinear_bhn(GEN mf, GEN L)
1962 : {
1963 : long i, l;
1964 511 : GEN P, NK, F = MF_get_S(mf);
1965 511 : if (!mflinear_strip(&F,&L)) return mftrivial();
1966 504 : l = lg(L); P = pol_x(1);
1967 2653 : for (i = 1; i < l; i++)
1968 : {
1969 2149 : GEN c = gel(L,i);
1970 2149 : if (typ(c) == t_POLMOD && varn(gel(c,1)) == 1)
1971 518 : P = mfsamefield(NULL, P, gel(c,1));
1972 : }
1973 504 : NK = mkgNK(MF_get_gN(mf), MF_get_gk(mf), MF_get_CHI(mf), P);
1974 504 : return taglinear_i(t_MF_LINEAR_BHN, NK, F,L);
1975 : }
1976 :
1977 : /* F vector of forms with same weight and character but varying level, return
1978 : * global [N,k,chi,P] */
1979 : static GEN
1980 3227 : vecmfNK(GEN F)
1981 : {
1982 3227 : long i, l = lg(F);
1983 : GEN N, f;
1984 3227 : if (l == 1) return mkNK(1, 0, mfchartrivial());
1985 3227 : f = gel(F,1); N = mf_get_gN(f);
1986 45255 : for (i = 2; i < l; i++) N = lcmii(N, mf_get_gN(gel(F,i)));
1987 3227 : return mkgNK(N, mf_get_gk(f), mf_get_CHI(f), mf_get_field(f));
1988 : }
1989 : /* do not use mflinear: mflineardivtomat rely on F being constant across the
1990 : * basis where mflinear strips the ones matched by 0 coeffs. Assume k and CHI
1991 : * constant, N is allowed to vary. */
1992 : static GEN
1993 1211 : vecmflinear(GEN F, GEN C)
1994 : {
1995 1211 : long i, t, l = lg(C);
1996 1211 : GEN NK, v = cgetg(l, t_VEC);
1997 1211 : if (l == 1) return v;
1998 1211 : t = ok_bhn_linear(F)? t_MF_LINEAR_BHN: t_MF_LINEAR;
1999 1211 : NK = vecmfNK(F);
2000 4494 : for (i = 1; i < l; i++) gel(v,i) = taglinear_i(t, NK, F, gel(C,i));
2001 1211 : return v;
2002 : }
2003 : /* vecmflinear(F,C), then divide everything by E, which has valuation 0 */
2004 : static GEN
2005 427 : vecmflineardiv0(GEN F, GEN C, GEN E)
2006 : {
2007 427 : GEN v = vecmflinear(F, C);
2008 427 : long i, l = lg(v);
2009 427 : if (l == 1) return v;
2010 427 : gel(v,1) = mfdiv_val(gel(v,1), E, 0);
2011 1631 : for (i = 2; i < l; i++)
2012 : { /* v[i] /= E */
2013 1204 : GEN f = shallowcopy(gel(v,1));
2014 1204 : gel(f,2) = gel(v,i);
2015 1204 : gel(v,i) = f;
2016 : }
2017 427 : return v;
2018 : }
2019 :
2020 : /* Non empty linear combination of linear combinations of same
2021 : * F_j=\sum_i \mu_{i,j}G_i so R = \sum_i (\sum_j(\la_j\mu_{i,j})) G_i */
2022 : static GEN
2023 2016 : mflinear_linear(GEN F, GEN L, int strip)
2024 : {
2025 2016 : long l = lg(F), j;
2026 2016 : GEN vF, M = cgetg(l, t_MAT);
2027 2016 : L = shallowcopy(L);
2028 18522 : for (j = 1; j < l; j++)
2029 : {
2030 16506 : GEN f = gel(F,j), c = gel(f,3), d = gel(f,4);
2031 16506 : if (typ(c) == t_VEC) c = shallowtrans(c);
2032 16506 : if (!isint1(d)) gel(L,j) = gdiv(gel(L,j),d);
2033 16506 : gel(M,j) = c;
2034 : }
2035 2016 : vF = gmael(F,1,2); L = RgM_RgC_mul(M,L);
2036 2016 : if (strip && !mflinear_strip(&vF,&L)) return mftrivial();
2037 2016 : return taglinear(vecmfNK(vF), vF, L);
2038 : }
2039 : /* F nonempty vector of forms of the form mfdiv(mflinear(B,v), E) where E
2040 : * does not vanish at oo, or mflinear(B,v). Apply mflinear(F, L) */
2041 : static GEN
2042 2016 : mflineardiv_linear(GEN F, GEN L, int strip)
2043 : {
2044 2016 : long l = lg(F), j;
2045 : GEN v, E, f;
2046 2016 : if (lg(L) != l) pari_err_DIM("mflineardiv_linear");
2047 2016 : f = gel(F,1); /* l > 1 */
2048 2016 : if (mf_get_type(f) != t_MF_DIV) return mflinear_linear(F,L,strip);
2049 1708 : E = gel(f,3);
2050 1708 : v = cgetg(l, t_VEC);
2051 17059 : for (j = 1; j < l; j++) { GEN f = gel(F,j); gel(v,j) = gel(f,2); }
2052 1708 : return mfdiv_val(mflinear_linear(v,L,strip), E, 0);
2053 : }
2054 : static GEN
2055 476 : vecmflineardiv_linear(GEN F, GEN M)
2056 : {
2057 476 : long i, l = lg(M);
2058 476 : GEN v = cgetg(l, t_VEC);
2059 1918 : for (i = 1; i < l; i++) gel(v,i) = mflineardiv_linear(F, gel(M,i), 0);
2060 476 : return v;
2061 : }
2062 :
2063 : static GEN
2064 630 : tobasis(GEN mf, GEN F, GEN L)
2065 : {
2066 630 : if (checkmf_i(L) && mf) return mftobasis(mf, L, 0);
2067 623 : if (typ(F) != t_VEC) pari_err_TYPE("mflinear",F);
2068 623 : if (!is_vec_t(typ(L))) pari_err_TYPE("mflinear",L);
2069 623 : if (lg(L) != lg(F)) pari_err_DIM("mflinear");
2070 623 : return L;
2071 : }
2072 : GEN
2073 672 : mflinear(GEN F, GEN L)
2074 : {
2075 672 : pari_sp av = avma;
2076 672 : GEN G, NK, P, mf = checkMF_i(F), N = NULL, K = NULL, CHI = NULL;
2077 : long i, l;
2078 672 : if (mf)
2079 : {
2080 525 : GEN gk = MF_get_gk(mf);
2081 525 : F = MF_get_basis(F);
2082 525 : if (typ(gk) != t_INT)
2083 42 : return gerepilecopy(av, mflineardiv_linear(F, L, 1));
2084 483 : if (itou(gk) > 1 && space_is_cusp(MF_get_space(mf)))
2085 : {
2086 266 : L = tobasis(mf, F, L);
2087 266 : return gerepilecopy(av, mflinear_bhn(mf, L));
2088 : }
2089 : }
2090 364 : L = tobasis(mf, F, L);
2091 364 : if (!mflinear_strip(&F,&L)) return mftrivial();
2092 :
2093 357 : l = lg(F);
2094 357 : if (l == 2 && gequal1(gel(L,1))) return gerepilecopy(av, gel(F,1));
2095 273 : P = pol_x(1);
2096 868 : for (i = 1; i < l; i++)
2097 : {
2098 602 : GEN f = gel(F,i), c = gel(L,i), Ni, Ki;
2099 602 : if (!checkmf_i(f)) pari_err_TYPE("mflinear", f);
2100 602 : Ni = mf_get_gN(f); N = N? lcmii(N, Ni): Ni;
2101 602 : Ki = mf_get_gk(f);
2102 602 : if (!K) K = Ki;
2103 329 : else if (!gequal(K, Ki))
2104 7 : pari_err_TYPE("mflinear [different weights]", mkvec2(K,Ki));
2105 595 : P = mfsamefield(NULL, P, mf_get_field(f));
2106 595 : if (typ(c) == t_POLMOD && varn(gel(c,1)) == 1)
2107 126 : P = mfsamefield(NULL, P, gel(c,1));
2108 : }
2109 266 : G = znstar0(N,1);
2110 847 : for (i = 1; i < l; i++)
2111 : {
2112 588 : GEN CHI2 = mf_get_CHI(gel(F,i));
2113 588 : CHI2 = induce(G, CHI2);
2114 588 : if (!CHI) CHI = CHI2;
2115 322 : else if (!gequal(CHI, CHI2))
2116 7 : pari_err_TYPE("mflinear [different characters]", mkvec2(CHI,CHI2));
2117 : }
2118 259 : NK = mkgNK(N, K, CHI, P);
2119 259 : return gerepilecopy(av, taglinear(NK,F,L));
2120 : }
2121 :
2122 : GEN
2123 42 : mfshift(GEN F, long sh)
2124 : {
2125 42 : pari_sp av = avma;
2126 42 : if (!checkmf_i(F)) pari_err_TYPE("mfshift",F);
2127 42 : return gerepilecopy(av, tag2(t_MF_SHIFT, mf_get_NK(F), F, stoi(sh)));
2128 : }
2129 : static long
2130 49 : mfval(GEN F)
2131 : {
2132 49 : pari_sp av = avma;
2133 49 : long i = 0, n, sb;
2134 : GEN gk, gN;
2135 49 : if (!checkmf_i(F)) pari_err_TYPE("mfval", F);
2136 49 : gN = mf_get_gN(F);
2137 49 : gk = mf_get_gk(F);
2138 49 : sb = mfsturmNgk(itou(gN), gk);
2139 70 : for (n = 1; n <= sb;)
2140 : {
2141 : GEN v;
2142 63 : if (n > 0.5*sb) n = sb+1;
2143 63 : v = mfcoefs_i(F, n, 1);
2144 119 : for (; i <= n; i++)
2145 98 : if (!gequal0(gel(v, i+1))) return gc_long(av,i);
2146 21 : n <<= 1;
2147 : }
2148 7 : return gc_long(av,-1);
2149 : }
2150 :
2151 : GEN
2152 2163 : mfdiv_val(GEN f, GEN g, long vg)
2153 : {
2154 : GEN T, N, K, NK, CHI, CHIf, CHIg;
2155 2163 : if (vg) { f = mfshift(f,vg); g = mfshift(g,vg); }
2156 2163 : N = lcmii(mf_get_gN(f), mf_get_gN(g));
2157 2163 : K = gsub(mf_get_gk(f), mf_get_gk(g));
2158 2163 : CHIf = mf_get_CHI(f);
2159 2163 : CHIg = mf_get_CHI(g);
2160 2163 : CHI = mfchiadjust(mfchardiv(CHIf, CHIg), K, itos(N));
2161 2163 : T = chicompat(CHI, CHIf, CHIg);
2162 2156 : NK = mkgNK(N, K, CHI, mfsamefield(T, mf_get_field(f), mf_get_field(g)));
2163 2156 : return T? tag3(t_MF_DIV, NK, f, g, T): tag2(t_MF_DIV, NK, f, g);
2164 : }
2165 : GEN
2166 49 : mfdiv(GEN F, GEN G)
2167 : {
2168 49 : pari_sp av = avma;
2169 49 : long v = mfval(G);
2170 49 : if (!checkmf_i(F)) pari_err_TYPE("mfdiv", F);
2171 42 : if (v < 0 || (v && !gequal0(mfcoefs(F, v-1, 1))))
2172 14 : pari_err_DOMAIN("mfdiv", "ord(G)", ">", strtoGENstr("ord(F)"),
2173 : mkvec2(F, G));
2174 28 : return gerepilecopy(av, mfdiv_val(F, G, v));
2175 : }
2176 : GEN
2177 154 : mfderiv(GEN F, long m)
2178 : {
2179 154 : pari_sp av = avma;
2180 : GEN NK, gk;
2181 154 : if (!checkmf_i(F)) pari_err_TYPE("mfderiv",F);
2182 154 : gk = gaddgs(mf_get_gk(F), 2*m);
2183 154 : NK = mkgNK(mf_get_gN(F), gk, mf_get_CHI(F), mf_get_field(F));
2184 154 : return gerepilecopy(av, tag2(t_MF_DERIV, NK, F, stoi(m)));
2185 : }
2186 : GEN
2187 21 : mfderivE2(GEN F, long m)
2188 : {
2189 21 : pari_sp av = avma;
2190 : GEN NK, gk;
2191 21 : if (!checkmf_i(F)) pari_err_TYPE("mfderivE2",F);
2192 21 : if (m < 0) pari_err_DOMAIN("mfderivE2","m","<",gen_0,stoi(m));
2193 21 : gk = gaddgs(mf_get_gk(F), 2*m);
2194 21 : NK = mkgNK(mf_get_gN(F), gk, mf_get_CHI(F), mf_get_field(F));
2195 21 : return gerepilecopy(av, tag2(t_MF_DERIVE2, NK, F, stoi(m)));
2196 : }
2197 :
2198 : GEN
2199 14 : mftwist(GEN F, GEN D)
2200 : {
2201 14 : pari_sp av = avma;
2202 : GEN NK, CHI, NT, Da;
2203 : long q;
2204 14 : if (!checkmf_i(F)) pari_err_TYPE("mftwist", F);
2205 14 : if (typ(D) != t_INT) pari_err_TYPE("mftwist", D);
2206 14 : Da = mpabs_shallow(D);
2207 14 : CHI = mf_get_CHI(F); q = mfcharconductor(CHI);
2208 14 : NT = glcm(glcm(mf_get_gN(F), mulsi(q, Da)), sqri(Da));
2209 14 : NK = mkgNK(NT, mf_get_gk(F), CHI, mf_get_field(F));
2210 14 : return gerepilecopy(av, tag2(t_MF_TWIST, NK, F, D));
2211 : }
2212 :
2213 : /***************************************************************/
2214 : /* Generic cache handling */
2215 : /***************************************************************/
2216 : enum { cache_FACT, cache_DIV, cache_H, cache_D, cache_DIH };
2217 : typedef struct {
2218 : const char *name;
2219 : GEN cache;
2220 : ulong minself, maxself;
2221 : void (*init)(long);
2222 : ulong miss, maxmiss;
2223 : long compressed;
2224 : } cache;
2225 :
2226 : static void constfact(long lim);
2227 : static void constdiv(long lim);
2228 : static void consttabh(long lim);
2229 : static void consttabdihedral(long lim);
2230 : static void constcoredisc(long lim);
2231 : static THREAD cache caches[] = {
2232 : { "Factors", NULL, 50000, 50000, &constfact, 0, 0, 0 },
2233 : { "Divisors", NULL, 50000, 50000, &constdiv, 0, 0, 0 },
2234 : { "H", NULL, 100000, 10000000, &consttabh, 0, 0, 1 },
2235 : { "CorediscF",NULL, 100000, 10000000, &constcoredisc, 0, 0, 0 },
2236 : { "Dihedral", NULL, 1000, 3000, &consttabdihedral, 0, 0, 0 },
2237 : };
2238 :
2239 : static void
2240 598 : cache_reset(long id) { caches[id].miss = caches[id].maxmiss = 0; }
2241 : static void
2242 8995 : cache_delete(long id) { guncloneNULL(caches[id].cache); }
2243 : static void
2244 612 : cache_set(long id, GEN S)
2245 : {
2246 612 : GEN old = caches[id].cache;
2247 612 : caches[id].cache = gclone(S);
2248 612 : guncloneNULL(old);
2249 612 : }
2250 :
2251 : /* handle a cache miss: store stats, possibly reset table; return value
2252 : * if (now) cached; return NULL on failure. HACK: some caches contain an
2253 : * ulong where the 0 value is impossible, and return it (typecast to GEN) */
2254 : static GEN
2255 447780063 : cache_get(long id, ulong D)
2256 : {
2257 447780063 : cache *S = &caches[id];
2258 447780063 : const ulong d = S->compressed? D>>1: D;
2259 : ulong max, l;
2260 :
2261 447780063 : if (!S->cache)
2262 : {
2263 440 : max = maxuu(minuu(D, S->maxself), S->minself);
2264 440 : S->init(max);
2265 440 : l = lg(S->cache);
2266 : }
2267 : else
2268 : {
2269 447779623 : l = lg(S->cache);
2270 447779623 : if (l <= d)
2271 : {
2272 327 : if (D > S->maxmiss) S->maxmiss = D;
2273 327 : if (DEBUGLEVEL >= 3)
2274 0 : err_printf("miss in cache %s: %lu, max = %lu\n",
2275 : S->name, D, S->maxmiss);
2276 327 : if (S->miss++ >= 5 && D < S->maxself)
2277 : {
2278 14 : max = minuu(S->maxself, (long)(S->maxmiss * 1.2));
2279 14 : if (max <= S->maxself)
2280 : {
2281 14 : if (DEBUGLEVEL >= 3)
2282 0 : err_printf("resetting cache %s to %lu\n", S->name, max);
2283 14 : S->init(max); l = lg(S->cache);
2284 : }
2285 : }
2286 : }
2287 : }
2288 447780063 : return (l <= d)? NULL: gel(S->cache, d);
2289 : }
2290 : static GEN
2291 70 : cache_report(long id)
2292 : {
2293 70 : cache *S = &caches[id];
2294 70 : GEN v = zerocol(5);
2295 70 : gel(v,1) = strtoGENstr(S->name);
2296 70 : if (S->cache)
2297 : {
2298 35 : gel(v,2) = utoi(lg(S->cache)-1);
2299 35 : gel(v,3) = utoi(S->miss);
2300 35 : gel(v,4) = utoi(S->maxmiss);
2301 35 : gel(v,5) = utoi(gsizebyte(S->cache));
2302 : }
2303 70 : return v;
2304 : }
2305 : GEN
2306 14 : getcache(void)
2307 : {
2308 14 : pari_sp av = avma;
2309 14 : GEN M = cgetg(6, t_MAT);
2310 14 : gel(M,1) = cache_report(cache_FACT);
2311 14 : gel(M,2) = cache_report(cache_DIV);
2312 14 : gel(M,3) = cache_report(cache_H);
2313 14 : gel(M,4) = cache_report(cache_D);
2314 14 : gel(M,5) = cache_report(cache_DIH);
2315 14 : return gerepilecopy(av, shallowtrans(M));
2316 : }
2317 :
2318 : void
2319 1799 : pari_close_mf(void)
2320 : {
2321 1799 : cache_delete(cache_FACT);
2322 1799 : cache_delete(cache_DIV);
2323 1799 : cache_delete(cache_H);
2324 1799 : cache_delete(cache_D);
2325 1799 : cache_delete(cache_DIH);
2326 1799 : }
2327 :
2328 : /*************************************************************************/
2329 : /* a odd, update local cache (recycle memory) */
2330 : static GEN
2331 2956 : update_factor_cache(long a, long lim, long *pb)
2332 : {
2333 2956 : const long step = 16000; /* even; don't increase this: RAM cache thrashing */
2334 2956 : if (a + 2*step > lim)
2335 233 : *pb = lim; /* fuse last 2 chunks */
2336 : else
2337 2723 : *pb = a + step;
2338 2956 : return vecfactoroddu_i(a, *pb);
2339 : }
2340 : /* assume lim < MAX_LONG/8 */
2341 : static void
2342 47 : constcoredisc(long lim)
2343 : {
2344 47 : pari_sp av2, av = avma;
2345 47 : GEN D = caches[cache_D].cache, CACHE = NULL;
2346 47 : long cachea, cacheb, N, LIM = !D ? 4 : lg(D)-1;
2347 47 : if (lim <= 0) lim = 5;
2348 47 : if (lim <= LIM) return;
2349 47 : cache_reset(cache_D);
2350 47 : D = zero_zv(lim);
2351 36 : av2 = avma;
2352 36 : cachea = cacheb = 0;
2353 4369396 : for (N = 1; N <= lim; N+=2)
2354 : { /* N odd */
2355 : long i, d, d2;
2356 : GEN F;
2357 4369349 : if (N > cacheb)
2358 : {
2359 530 : set_avma(av2); cachea = N;
2360 530 : CACHE = update_factor_cache(N, lim, &cacheb);
2361 : }
2362 4369349 : F = gel(CACHE, ((N-cachea)>>1)+1); /* factoru(N) */
2363 4369349 : D[N] = d = corediscs_fact(F); /* = 3 mod 4 or 4 mod 16 */
2364 4369400 : d2 = odd(d)? d<<3: d<<1;
2365 4369974 : for (i = 1;;)
2366 : {
2367 5826312 : if ((N << i) > lim) break;
2368 2913890 : D[N<<i] = d2; i++;
2369 2913890 : if ((N << i) > lim) break;
2370 1456338 : D[N<<i] = d; i++;
2371 : }
2372 : }
2373 47 : cache_set(cache_D, D);
2374 47 : set_avma(av);
2375 : }
2376 :
2377 : static void
2378 207 : constfact(long lim)
2379 : {
2380 : pari_sp av;
2381 207 : GEN VFACT = caches[cache_FACT].cache;
2382 207 : long LIM = VFACT? lg(VFACT)-1: 4;
2383 207 : if (lim <= 0) lim = 5;
2384 207 : if (lim <= LIM) return;
2385 186 : cache_reset(cache_FACT); av = avma;
2386 186 : cache_set(cache_FACT, vecfactoru_i(1,lim)); set_avma(av);
2387 : }
2388 : static void
2389 179 : constdiv(long lim)
2390 : {
2391 : pari_sp av;
2392 179 : GEN VFACT, VDIV = caches[cache_DIV].cache;
2393 179 : long N, LIM = VDIV? lg(VDIV)-1: 4;
2394 179 : if (lim <= 0) lim = 5;
2395 179 : if (lim <= LIM) return;
2396 179 : constfact(lim);
2397 179 : VFACT = caches[cache_FACT].cache;
2398 179 : cache_reset(cache_DIV); av = avma;
2399 179 : VDIV = cgetg(lim+1, t_VEC);
2400 8236502 : for (N = 1; N <= lim; N++) gel(VDIV,N) = divisorsu_fact(gel(VFACT,N));
2401 179 : cache_set(cache_DIV, VDIV); set_avma(av);
2402 : }
2403 :
2404 : /* n > 1, D = divisors(n); sets L = 2*lambda(n), S = sigma(n) */
2405 : static void
2406 19482374 : lamsig(GEN D, long *pL, long *pS)
2407 : {
2408 19482374 : pari_sp av = avma;
2409 19482374 : long i, l = lg(D), L = 1, S = D[l-1]+1;
2410 73369637 : for (i = 2; i < l; i++) /* skip d = 1 */
2411 : {
2412 76190977 : long d = D[i], nd = D[l-i]; /* nd = n/d */
2413 76190977 : if (d < nd) { L += d; S += d + nd; }
2414 : else
2415 : {
2416 22303714 : L <<= 1; if (d == nd) { L += d; S += d; }
2417 22303714 : break;
2418 : }
2419 : }
2420 19482374 : set_avma(av); *pL = L; *pS = S;
2421 22710665 : }
2422 : /* table of 6 * Hurwitz class numbers D <= lim */
2423 : static void
2424 186 : consttabh(long lim)
2425 : {
2426 186 : pari_sp av = avma, av2;
2427 186 : GEN VHDH0, VDIV, CACHE = NULL;
2428 186 : GEN VHDH = caches[cache_H].cache;
2429 186 : long r, N, cachea, cacheb, lim0 = VHDH? lg(VHDH)-1: 2, LIM = lim0 << 1;
2430 :
2431 186 : if (lim <= 0) lim = 5;
2432 186 : if (lim <= LIM) return;
2433 186 : cache_reset(cache_H);
2434 186 : r = lim&3L; if (r) lim += 4-r;
2435 186 : cache_get(cache_DIV, lim);
2436 186 : VDIV = caches[cache_DIV].cache;
2437 186 : VHDH0 = cgetg(lim/2 + 1, t_VECSMALL);
2438 186 : VHDH0[1] = 2;
2439 186 : VHDH0[2] = 3;
2440 483976 : for (N = 3; N <= lim0; N++) VHDH0[N] = VHDH[N];
2441 186 : av2 = avma;
2442 186 : cachea = cacheb = 0;
2443 11727235 : for (N = LIM + 3; N <= lim; N += 4)
2444 : {
2445 11775327 : long s = 0, limt = usqrt(N>>2), flsq = 0, ind, t, L, S;
2446 : GEN DN, DN2;
2447 11670331 : if (N + 2 >= lg(VDIV))
2448 : { /* use local cache */
2449 : GEN F;
2450 9511273 : if (N + 2 > cacheb)
2451 : {
2452 2426 : set_avma(av2); cachea = N;
2453 2426 : CACHE = update_factor_cache(N, lim+2, &cacheb);
2454 : }
2455 9511272 : F = gel(CACHE, ((N-cachea)>>1)+1); /* factoru(N) */
2456 9511272 : DN = divisorsu_fact(F);
2457 9179435 : F = gel(CACHE, ((N-cachea)>>1)+2); /* factoru(N+2) */
2458 9179435 : DN2 = divisorsu_fact(F);
2459 : }
2460 : else
2461 : { /* use global cache */
2462 2159058 : DN = gel(VDIV,N);
2463 2159058 : DN2 = gel(VDIV,N+2);
2464 : }
2465 11178428 : ind = N >> 1;
2466 974847083 : for (t = 1; t <= limt; t++)
2467 : {
2468 963668655 : ind -= (t<<2)-2; /* N/2 - 2t^2 */
2469 963668655 : if (ind) s += VHDH0[ind]; else flsq = 1;
2470 : }
2471 11178428 : lamsig(DN, &L,&S);
2472 11280541 : VHDH0[N >> 1] = 2*S - 3*L - 2*s + flsq;
2473 11280541 : s = 0; flsq = 0; limt = (usqrt(N+2) - 1) >> 1;
2474 10504600 : ind = (N+1) >> 1;
2475 974189365 : for (t = 1; t <= limt; t++)
2476 : {
2477 963684765 : ind -= t<<2; /* (N+1)/2 - 2t(t+1) */
2478 963684765 : if (ind) s += VHDH0[ind]; else flsq = 1;
2479 : }
2480 10504600 : lamsig(DN2, &L,&S);
2481 11727049 : VHDH0[(N+1) >> 1] = S - 3*(L >> 1) - s - flsq;
2482 : }
2483 78 : cache_set(cache_H, VHDH0); set_avma(av);
2484 : }
2485 :
2486 : /*************************************************************************/
2487 : /* Core functions using factorizations, divisors of class numbers caches */
2488 : /* TODO: myfactoru and factorization cache should be exported */
2489 : static GEN
2490 33529903 : myfactoru(long N)
2491 : {
2492 33529903 : GEN z = cache_get(cache_FACT, N);
2493 33529903 : return z? gcopy(z): factoru(N);
2494 : }
2495 : static GEN
2496 68799368 : mydivisorsu(long N)
2497 : {
2498 68799368 : GEN z = cache_get(cache_DIV, N);
2499 68799368 : return z? leafcopy(z): divisorsu(N);
2500 : }
2501 : /* write -n = Df^2, D < 0 fundamental discriminant. Return D, set f. */
2502 : static long
2503 176273777 : mycoredisc2neg(ulong n, long *pf)
2504 : {
2505 176273777 : ulong m, D = (ulong)cache_get(cache_D, n);
2506 176273777 : if (D) { *pf = usqrt(n/D); return -(long)D; }
2507 56 : m = mycore(n, pf);
2508 56 : if ((m&3) != 3) { m <<= 2; *pf >>= 1; }
2509 56 : return (long)-m;
2510 : }
2511 : /* write n = Df^2, D > 0 fundamental discriminant. Return D, set f. */
2512 : static long
2513 14 : mycoredisc2pos(ulong n, long *pf)
2514 : {
2515 14 : ulong m = mycore(n, pf);
2516 14 : if ((m&3) != 1) { m <<= 2; *pf >>= 1; }
2517 14 : return (long)m;
2518 : }
2519 :
2520 : /* D < 0 fundamental. Return 6*hclassno(-D); faster than quadclassunit up
2521 : * to 5*10^5 or so */
2522 : static ulong
2523 43 : hclassno6_count(long D)
2524 : {
2525 43 : ulong a, b, b2, h = 0, d = -D;
2526 43 : int f = 0;
2527 :
2528 43 : if (d > 500000) return 6 * quadclassnos(D);
2529 : /* this part would work with -d non fundamental */
2530 36 : b = d&1; b2 = (1+d)>>2;
2531 36 : if (!b)
2532 : {
2533 876 : for (a=1; a*a<b2; a++)
2534 873 : if (b2%a == 0) h++;
2535 3 : f = (a*a==b2); b=2; b2=(4+d)>>2;
2536 : }
2537 7175 : while (b2*3 < d)
2538 : {
2539 7139 : if (b2%b == 0) h++;
2540 1172517 : for (a=b+1; a*a < b2; a++)
2541 1165378 : if (b2%a == 0) h += 2;
2542 7139 : if (a*a == b2) h++;
2543 7139 : b += 2; b2 = (b*b+d)>>2;
2544 : }
2545 36 : if (b2*3 == d) return 6*h+2;
2546 36 : if (f) return 6*h+3;
2547 36 : return 6*h;
2548 : }
2549 : /* D0 < 0; 6 * hclassno(-D), using D = D0*F^2 */
2550 : static long
2551 61 : hclassno6u_2(long D0, long F)
2552 : {
2553 : long h;
2554 61 : if (F == 1) h = hclassno6_count(D0);
2555 : else
2556 : { /* second chance */
2557 18 : h = (ulong)cache_get(cache_H, -D0);
2558 18 : if (!h) h = hclassno6_count(D0);
2559 18 : h *= uhclassnoF_fact(myfactoru(F), D0);
2560 : }
2561 61 : return h;
2562 : }
2563 : /* D > 0; 6 * hclassno(D) (6*Hurwitz). Beware, cached value for D (=0,3 mod 4)
2564 : * is stored at D>>1 */
2565 : ulong
2566 2235036 : hclassno6u(ulong D)
2567 : {
2568 2235036 : ulong z = (ulong)cache_get(cache_H, D);
2569 : long D0, F;
2570 2235037 : if (z) return z;
2571 61 : D0 = mycoredisc2neg(D, &F);
2572 61 : return hclassno6u_2(D0,F);
2573 : }
2574 : /* same as hclassno6u without creating caches */
2575 : ulong
2576 86918 : hclassno6u_no_cache(ulong D)
2577 : {
2578 86918 : cache *S = &caches[cache_H];
2579 : long D0, F;
2580 86918 : if (S->cache)
2581 : {
2582 76156 : const ulong d = D>>1; /* compressed */
2583 76156 : if ((ulong)lg(S->cache) > d) return S->cache[d];
2584 : }
2585 86648 : S = &caches[cache_D];
2586 86648 : if (!S->cache || (ulong)lg(S->cache) <= D) return 0;
2587 0 : D0 = mycoredisc2neg(D, &F);
2588 0 : return hclassno6u_2(D0,F);
2589 : }
2590 : /* same, where the decomposition D = D0*F^2 is already known */
2591 : static ulong
2592 156310125 : hclassno6u_i(ulong D, long D0, long F)
2593 : {
2594 156310125 : ulong z = (ulong)cache_get(cache_H, D);
2595 156310125 : if (z) return z;
2596 0 : return hclassno6u_2(D0,F);
2597 : }
2598 :
2599 : /* D < -4 fundamental, h(D), ordinary class number */
2600 : static long
2601 10619294 : myh(long D)
2602 : {
2603 10619294 : ulong z = (ulong)cache_get(cache_H, -D);
2604 10619294 : return z? z / 6: quadclassnos(D);
2605 : }
2606 :
2607 : /*************************************************************************/
2608 : /* TRACE FORMULAS */
2609 : /* CHIP primitive, initialize for t_POLMOD output */
2610 : static GEN
2611 30926 : mfcharinit(GEN CHIP)
2612 : {
2613 30926 : long n, o, l, vt, N = mfcharmodulus(CHIP);
2614 : GEN c, v, V, G, Pn;
2615 30926 : if (N == 1) return mkvec2(mkvec(gen_1), pol_x(0));
2616 5460 : G = gel(CHIP,1);
2617 5460 : v = ncharvecexpo(G, znconrey_normalized(G, gel(CHIP,2)));
2618 5460 : l = lg(v); V = cgetg(l, t_VEC);
2619 5460 : o = mfcharorder(CHIP);
2620 5460 : Pn = mfcharpol(CHIP); vt = varn(Pn);
2621 5460 : if (o <= 2)
2622 : {
2623 59143 : for (n = 1; n < l; n++)
2624 : {
2625 54635 : if (v[n] < 0) c = gen_0; else c = v[n]? gen_m1: gen_1;
2626 54635 : gel(V,n) = c;
2627 : }
2628 : }
2629 : else
2630 : {
2631 16835 : for (n = 1; n < l; n++)
2632 : {
2633 15883 : if (v[n] < 0) c = gen_0;
2634 : else
2635 : {
2636 8890 : c = Qab_zeta(v[n], o, vt);
2637 8890 : if (typ(c) == t_POL && lg(c) >= lg(Pn)) c = RgX_rem(c, Pn);
2638 : }
2639 15883 : gel(V,n) = c;
2640 : }
2641 : }
2642 5460 : return mkvec2(V, Pn);
2643 : }
2644 : static GEN
2645 407470 : vchip_lift(GEN VCHI, long x, GEN C)
2646 : {
2647 407470 : GEN V = gel(VCHI,1);
2648 407470 : long F = lg(V)-1;
2649 407470 : if (F == 1) return C;
2650 18368 : x %= F;
2651 18368 : if (!x) return C;
2652 18368 : if (x <= 0) x += F;
2653 18368 : return gmul(C, gel(V, x));
2654 : }
2655 : static long
2656 279152309 : vchip_FC(GEN VCHI) { return lg(gel(VCHI,1))-1; }
2657 : static GEN
2658 6406926 : vchip_mod(GEN VCHI, GEN S)
2659 6406926 : { return (typ(S) == t_POL)? RgX_rem(S, gel(VCHI,2)): S; }
2660 : static GEN
2661 1900490 : vchip_polmod(GEN VCHI, GEN S)
2662 1900490 : { return (typ(S) == t_POL)? mkpolmod(S, gel(VCHI,2)): S; }
2663 :
2664 : /* contribution of scalar matrices in dimension formula */
2665 : static GEN
2666 350490 : A1(long N, long k) { return uutoQ(mypsiu(N)*(k-1), 12); }
2667 : static long
2668 7483 : ceilA1(long N, long k) { return ceildivuu(mypsiu(N) * (k-1), 12); }
2669 :
2670 : /* sturm bound, slightly larger than dimension */
2671 : long
2672 21476 : mfsturmNk(long N, long k) { return (mypsiu(N) * k) / 12; }
2673 : long
2674 2492 : mfsturmNgk(long N, GEN k)
2675 : {
2676 2492 : long n,d; Qtoss(k,&n,&d);
2677 2492 : return 1 + (mypsiu(N)*n)/(d == 1? 12: 24);
2678 : }
2679 : static long
2680 49 : mfsturmmf(GEN F) { return mfsturmNgk(mf_get_N(F), mf_get_gk(F)); }
2681 :
2682 : /* List of all solutions of x^2 + x + 1 = 0 modulo N, x modulo N */
2683 : static GEN
2684 539 : sqrtm3modN(long N)
2685 : {
2686 : pari_sp av;
2687 : GEN fa, P, E, B, mB, A, Q, T, R, v, gen_m3;
2688 539 : long l, i, n, ct, fl3 = 0, Ninit;
2689 539 : if (!odd(N) || (N%9) == 0) return cgetg(1,t_VECSMALL);
2690 511 : Ninit = N;
2691 511 : if ((N%3) == 0) { N /= 3; fl3 = 1; }
2692 511 : fa = myfactoru(N); P = gel(fa, 1); E = gel(fa, 2);
2693 511 : l = lg(P);
2694 707 : for (i = 1; i < l; i++)
2695 518 : if ((P[i]%3) == 2) return cgetg(1,t_VECSMALL);
2696 189 : A = cgetg(l, t_VECSMALL);
2697 189 : B = cgetg(l, t_VECSMALL);
2698 189 : mB= cgetg(l, t_VECSMALL);
2699 189 : Q = cgetg(l, t_VECSMALL); gen_m3 = utoineg(3);
2700 385 : for (i = 1; i < l; i++)
2701 : {
2702 196 : long p = P[i], e = E[i];
2703 196 : Q[i] = upowuu(p,e);
2704 196 : B[i] = itou( Zp_sqrt(gen_m3, utoipos(p), e) );
2705 196 : mB[i]= Q[i] - B[i];
2706 : }
2707 189 : ct = 1 << (l-1);
2708 189 : T = ZV_producttree(Q);
2709 189 : R = ZV_chinesetree(Q,T);
2710 189 : v = cgetg(ct+1, t_VECSMALL);
2711 189 : av = avma;
2712 581 : for (n = 1; n <= ct; n++)
2713 : {
2714 392 : long m = n-1, r;
2715 812 : for (i = 1; i < l; i++)
2716 : {
2717 420 : A[i] = (m&1L)? mB[i]: B[i];
2718 420 : m >>= 1;
2719 : }
2720 392 : r = itou( ZV_chinese_tree(A, Q, T, R) );
2721 462 : if (fl3) while (r%3) r += N;
2722 392 : set_avma(av); v[n] = odd(r) ? (r-1) >> 1 : (r+Ninit-1) >> 1;
2723 : }
2724 189 : return v;
2725 : }
2726 :
2727 : /* number of elliptic points of order 3 in X0(N) */
2728 : static long
2729 10101 : nu3(long N)
2730 : {
2731 : long i, l;
2732 : GEN P;
2733 10101 : if (!odd(N) || (N%9) == 0) return 0;
2734 8897 : if ((N%3) == 0) N /= 3;
2735 8897 : P = gel(myfactoru(N), 1); l = lg(P);
2736 13048 : for (i = 1; i < l; i++) if ((P[i]%3) == 2) return 0;
2737 3969 : return 1L<<(l-1);
2738 : }
2739 : /* number of elliptic points of order 2 in X0(N) */
2740 : static long
2741 17297 : nu2(long N)
2742 : {
2743 : long i, l;
2744 : GEN P;
2745 17297 : if ((N&3L) == 0) return 0;
2746 17297 : if (!odd(N)) N >>= 1;
2747 17297 : P = gel(myfactoru(N), 1); l = lg(P);
2748 21700 : for (i = 1; i < l; i++) if ((P[i]&3L) == 3) return 0;
2749 3941 : return 1L<<(l-1);
2750 : }
2751 :
2752 : /* contribution of elliptic matrices of order 3 in dimension formula
2753 : * Only depends on CHIP the primitive char attached to CHI */
2754 : static GEN
2755 43043 : A21(long N, long k, GEN CHI)
2756 : {
2757 : GEN res, G, chi, o;
2758 : long a21, i, limx, S;
2759 43043 : if ((N&1L) == 0) return gen_0;
2760 20825 : a21 = k%3 - 1;
2761 20825 : if (!a21) return gen_0;
2762 20181 : if (N <= 3) return sstoQ(a21, 3);
2763 10640 : if (!CHI) return sstoQ(nu3(N) * a21, 3);
2764 539 : res = sqrtm3modN(N); limx = (N - 1) >> 1;
2765 539 : G = gel(CHI,1); chi = gel(CHI,2);
2766 539 : o = gmfcharorder(CHI);
2767 931 : for (S = 0, i = 1; i < lg(res); i++)
2768 : { /* (x,N) = 1; S += chi(x) + chi(x^2) */
2769 392 : long x = res[i];
2770 392 : if (x <= limx)
2771 : { /* CHI(x)=e(c/o), 3rd-root of 1 */
2772 196 : GEN c = znchareval(G, chi, utoi(x), o);
2773 196 : if (!signe(c)) S += 2; else S--;
2774 : }
2775 : }
2776 539 : return sstoQ(a21 * S, 3);
2777 : }
2778 :
2779 : /* List of all square roots of -1 modulo N */
2780 : static GEN
2781 595 : sqrtm1modN(long N)
2782 : {
2783 : pari_sp av;
2784 : GEN fa, P, E, B, mB, A, Q, T, R, v;
2785 595 : long l, i, n, ct, fleven = 0;
2786 595 : if ((N&3L) == 0) return cgetg(1,t_VECSMALL);
2787 595 : if ((N&1L) == 0) { N >>= 1; fleven = 1; }
2788 595 : fa = myfactoru(N); P = gel(fa,1); E = gel(fa,2);
2789 595 : l = lg(P);
2790 945 : for (i = 1; i < l; i++)
2791 665 : if ((P[i]&3L) == 3) return cgetg(1,t_VECSMALL);
2792 280 : A = cgetg(l, t_VECSMALL);
2793 280 : B = cgetg(l, t_VECSMALL);
2794 280 : mB= cgetg(l, t_VECSMALL);
2795 280 : Q = cgetg(l, t_VECSMALL);
2796 574 : for (i = 1; i < l; i++)
2797 : {
2798 294 : long p = P[i], e = E[i];
2799 294 : Q[i] = upowuu(p,e);
2800 294 : B[i] = itou( Zp_sqrt(gen_m1, utoipos(p), e) );
2801 294 : mB[i]= Q[i] - B[i];
2802 : }
2803 280 : ct = 1 << (l-1);
2804 280 : T = ZV_producttree(Q);
2805 280 : R = ZV_chinesetree(Q,T);
2806 280 : v = cgetg(ct+1, t_VECSMALL);
2807 280 : av = avma;
2808 868 : for (n = 1; n <= ct; n++)
2809 : {
2810 588 : long m = n-1, r;
2811 1232 : for (i = 1; i < l; i++)
2812 : {
2813 644 : A[i] = (m&1L)? mB[i]: B[i];
2814 644 : m >>= 1;
2815 : }
2816 588 : r = itou( ZV_chinese_tree(A, Q, T, R) );
2817 588 : if (fleven && !odd(r)) r += N;
2818 588 : set_avma(av); v[n] = r;
2819 : }
2820 280 : return v;
2821 : }
2822 :
2823 : /* contribution of elliptic matrices of order 4 in dimension formula.
2824 : * Only depends on CHIP the primitive char attached to CHI */
2825 : static GEN
2826 43043 : A22(long N, long k, GEN CHI)
2827 : {
2828 : GEN G, chi, o, res;
2829 : long S, a22, i, limx, o2;
2830 43043 : if ((N&3L) == 0) return gen_0;
2831 29617 : a22 = (k & 3L) - 1; /* (k % 4) - 1 */
2832 29617 : if (!a22) return gen_0;
2833 29617 : if (N <= 2) return sstoQ(a22, 4);
2834 18102 : if (!CHI) return sstoQ(nu2(N)*a22, 4);
2835 805 : if (mfcharparity(CHI) == -1) return gen_0;
2836 595 : res = sqrtm1modN(N); limx = (N - 1) >> 1;
2837 595 : G = gel(CHI,1); chi = gel(CHI,2);
2838 595 : o = gmfcharorder(CHI);
2839 595 : o2 = itou(o)>>1;
2840 1183 : for (S = 0, i = 1; i < lg(res); i++)
2841 : { /* (x,N) = 1, S += real(chi(x)) */
2842 588 : long x = res[i];
2843 588 : if (x <= limx)
2844 : { /* CHI(x)=e(c/o), 4th-root of 1 */
2845 294 : long c = itou( znchareval(G, chi, utoi(x), o) );
2846 294 : if (!c) S++; else if (c == o2) S--;
2847 : }
2848 : }
2849 595 : return sstoQ(a22 * S, 2);
2850 : }
2851 :
2852 : /* sumdiv(N,d,eulerphi(gcd(d,N/d))) */
2853 : static long
2854 38269 : nuinf(long N)
2855 : {
2856 38269 : GEN fa = myfactoru(N), P = gel(fa,1), E = gel(fa,2);
2857 38269 : long i, t = 1, l = lg(P);
2858 81361 : for (i=1; i<l; i++)
2859 : {
2860 43092 : long p = P[i], e = E[i];
2861 43092 : if (odd(e))
2862 34475 : t *= upowuu(p,e>>1) << 1;
2863 : else
2864 8617 : t *= upowuu(p,(e>>1)-1) * (p+1);
2865 : }
2866 38269 : return t;
2867 : }
2868 :
2869 : /* contribution of hyperbolic matrices in dimension formula */
2870 : static GEN
2871 43491 : A3(long N, long FC)
2872 : {
2873 : long i, S, NF, l;
2874 : GEN D;
2875 43491 : if (FC == 1) return uutoQ(nuinf(N),2);
2876 5222 : D = mydivisorsu(N); l = lg(D);
2877 5222 : S = 0; NF = N/FC;
2878 41209 : for (i = 1; i < l; i++)
2879 : {
2880 35987 : long g = ugcd(D[i], D[l-i]);
2881 35987 : if (NF%g == 0) S += myeulerphiu(g);
2882 : }
2883 5222 : return uutoQ(S, 2);
2884 : }
2885 :
2886 : /* special contribution in weight 2 in dimension formula */
2887 : static long
2888 42609 : A4(long k, long FC)
2889 42609 : { return (k==2 && FC==1)? 1: 0; }
2890 : /* gcd(x,N) */
2891 : static long
2892 282856308 : myugcd(GEN GCD, ulong x)
2893 : {
2894 282856308 : ulong N = lg(GCD)-1;
2895 282856308 : if (x >= N) x %= N;
2896 282856308 : return GCD[x+1];
2897 : }
2898 : /* 1_{gcd(x,N) = 1} * chi(x), return NULL if 0 */
2899 : static GEN
2900 401925058 : mychicgcd(GEN GCD, GEN VCHI, long x)
2901 : {
2902 401925058 : long N = lg(GCD)-1;
2903 401925058 : if (N == 1) return gen_1;
2904 327568442 : x = umodsu(x, N);
2905 327568442 : if (GCD[x+1] != 1) return NULL;
2906 271535724 : x %= vchip_FC(VCHI); if (!x) return gen_1;
2907 4468548 : return gel(gel(VCHI,1), x);
2908 : }
2909 :
2910 : /* contribution of scalar matrices to trace formula */
2911 : static GEN
2912 6346506 : TA1(long N, long k, GEN VCHI, GEN GCD, long n)
2913 : {
2914 : GEN S;
2915 : ulong m;
2916 6346506 : if (!uissquareall(n, &m)) return gen_0;
2917 376117 : if (m == 1) return A1(N,k); /* common */
2918 339906 : S = mychicgcd(GCD, VCHI, m);
2919 339906 : return S? gmul(gmul(powuu(m, k-2), A1(N,k)), S): gen_0;
2920 : }
2921 :
2922 : /* All square roots modulo 4N, x modulo 2N, precomputed to accelerate TA2 */
2923 : static GEN
2924 120183 : mksqr(long N)
2925 : {
2926 120183 : pari_sp av = avma;
2927 120183 : long x, N2 = N << 1, N4 = N << 2;
2928 120183 : GEN v = const_vec(N2, cgetg(1, t_VECSMALL));
2929 120183 : gel(v, N2) = mkvecsmall(0); /* x = 0 */
2930 3412724 : for (x = 1; x <= N; x++)
2931 : {
2932 3292541 : long r = (((x*x - 1)%N4) >> 1) + 1;
2933 3292541 : gel(v,r) = vecsmall_append(gel(v,r), x);
2934 : }
2935 120183 : return gerepilecopy(av, v);
2936 : }
2937 :
2938 : static GEN
2939 120183 : mkgcd(long N)
2940 : {
2941 : GEN GCD, d;
2942 : long i, N2;
2943 120183 : if (N == 1) return mkvecsmall(N);
2944 99232 : GCD = cgetg(N + 1, t_VECSMALL);
2945 99232 : d = GCD+1; /* GCD[i+1] = d[i] = gcd(i,N) = gcd(N-i,N), i = 0..N-1 */
2946 99232 : d[0] = N; d[1] = d[N-1] = 1; N2 = N>>1;
2947 1616146 : for (i = 2; i <= N2; i++) d[i] = d[N-i] = ugcd(N, i);
2948 99232 : return GCD;
2949 : }
2950 :
2951 : /* Table of \sum_{x^2-tx+n=0 mod Ng}chi(x) for all g dividing gcd(N,F),
2952 : * F^2 largest such that (t^2-4n)/F^2=0 or 1 mod 4; t >= 0 */
2953 : static GEN
2954 15168332 : mutglistall(long t, long N, long NF, GEN VCHI, long n, GEN MUP, GEN li, GEN GCD)
2955 : {
2956 15168332 : long i, lx = lg(li);
2957 15168332 : GEN DNF = mydivisorsu(NF), v = zerovec(NF);
2958 15168332 : long j, g, lDNF = lg(DNF);
2959 42336102 : for (i = 1; i < lx; i++)
2960 : {
2961 27167770 : long x = (li[i] + t) >> 1, y, lD;
2962 27167770 : GEN D, c = mychicgcd(GCD, VCHI, x);
2963 27167770 : if (li[i] && li[i] != N)
2964 : {
2965 18064080 : GEN c2 = mychicgcd(GCD, VCHI, t - x);
2966 18064080 : if (c2) c = c? gadd(c, c2): c2;
2967 : }
2968 27167770 : if (!c) continue;
2969 22035685 : y = (x*(x - t) + n) / N; /* exact division */
2970 22035685 : D = mydivisorsu(ugcd(labs(y), NF)); lD = lg(D);
2971 59375885 : for (j=1; j < lD; j++) { g = D[j]; gel(v,g) = gadd(gel(v,g), c); }
2972 : }
2973 : /* j = 1 corresponds to g = 1, and MUP[1] = 1 */
2974 35048060 : for (j=2; j < lDNF; j++) { g = DNF[j]; gel(v,g) = gmulsg(MUP[g], gel(v,g)); }
2975 15168332 : return v;
2976 : }
2977 :
2978 : /* special case (N,F) = 1: easier */
2979 : static GEN
2980 161105370 : mutg1(long t, long N, GEN VCHI, GEN li, GEN GCD)
2981 : { /* (N,F) = 1 */
2982 161105370 : GEN S = NULL;
2983 161105370 : long i, lx = lg(li);
2984 338082946 : for (i = 1; i < lx; i++)
2985 : {
2986 176977576 : long x = (li[i] + t) >> 1;
2987 176977576 : GEN c = mychicgcd(GCD, VCHI, x);
2988 176977576 : if (c) S = S? gadd(S, c): c;
2989 176977576 : if (li[i] && li[i] != N)
2990 : {
2991 97904849 : c = mychicgcd(GCD, VCHI, t - x);
2992 97904849 : if (c) S = S? gadd(S, c): c;
2993 : }
2994 176977576 : if (S && !signe(S)) S = NULL; /* strive hard to add gen_0 */
2995 : }
2996 161105370 : return S; /* single value */
2997 : }
2998 :
2999 : /* Gegenbauer pol; n > 2, P = \sum_{0<=j<=n/2} (-1)^j (n-j)!/j!(n-2*j)! X^j */
3000 : GEN
3001 360603 : mfrhopol(long n)
3002 : {
3003 : #ifdef LONG_IS_64BIT
3004 309132 : const long M = 2642249;
3005 : #else
3006 51471 : const long M = 1629;
3007 : #endif
3008 360603 : long j, d = n >> 1; /* >= 1 */
3009 360603 : GEN P = cgetg(d + 3, t_POL);
3010 :
3011 360603 : if (n > M) pari_err_IMPL("mfrhopol for large weight"); /* avoid overflow */
3012 360603 : P[1] = evalvarn(0)|evalsigne(1);
3013 360603 : gel(P,2) = gen_1;
3014 360603 : gel(P,3) = utoineg(n-1); /* j = 1 */
3015 360603 : if (d > 1) gel(P,4) = utoipos(((n-3)*(n-2)) >> 1); /* j = 2 */
3016 360603 : if (d > 2) gel(P,5) = utoineg(((n-5)*(n-4)*(n-3)) / 6); /* j = 3 */
3017 1515452 : for (j = 4; j <= d; j++)
3018 1154849 : gel(P,j+2) = divis(mulis(gel(P,j+1), (n-2*j+1)*(n-2*j+2)), (n-j+1)*(-j));
3019 360603 : return P;
3020 : }
3021 :
3022 : /* polrecip(Q)(t2), assume Q(0) = 1 */
3023 : GEN
3024 3248424 : mfrhopol_u_eval(GEN Q, ulong t2)
3025 : {
3026 3248424 : GEN T = addiu(gel(Q,3), t2);
3027 3248427 : long l = lg(Q), j;
3028 37882090 : for (j = 4; j < l; j++) T = addii(gel(Q,j), mului(t2, T));
3029 3248422 : return T;
3030 : }
3031 : GEN
3032 56611 : mfrhopol_eval(GEN Q, GEN t2)
3033 : {
3034 : long l, j;
3035 : GEN T;
3036 56611 : if (lgefint(t2) == 3) return mfrhopol_u_eval(Q, t2[2]);
3037 0 : l = lg(Q); T = addii(gel(Q,3), t2);
3038 0 : for (j = 4; j < l; j++) T = addii(gel(Q,j), mulii(t2, T));
3039 0 : return T;
3040 : }
3041 : /* return sh * sqrt(n)^nu * G_nu(t/(2*sqrt(n))) for t != 0
3042 : * else (sh/2) * sqrt(n)^nu * G_nu(0) [ implies nu is even ]
3043 : * G_nu(z) = \sum_{0<=j<=nu/2} (-1)^j (nu-j)!/j!(nu-2*j)! * (2z)^(nu-2*j)) */
3044 : static GEN
3045 167881458 : mfrhopowsimp(GEN Q, GEN sh, long nu, long t, long t2, long n)
3046 : {
3047 : GEN T;
3048 167881458 : switch (nu)
3049 : {
3050 161999103 : case 0: return t? sh: gmul2n(sh,-1);
3051 1125222 : case 1: return gmulsg(t, sh);
3052 1519427 : case 2: return t? gmulsg(t2 - n, sh): gmul(gmul2n(stoi(-n), -1), sh);
3053 427 : case 3: return gmul(mulss(t, t2 - 2*n), sh);
3054 3237279 : default:
3055 3237279 : if (!t) return gmul(gmul2n(gel(Q, lg(Q) - 1), -1), sh);
3056 3191809 : T = mfrhopol_u_eval(Q, t2); if (odd(nu)) T = mulsi(t, T);
3057 3191809 : return gmul(T, sh);
3058 : }
3059 : }
3060 :
3061 : /* contribution of elliptic matrices to trace formula */
3062 : static GEN
3063 6346506 : TA2(long N, long k, GEN VCHI, long n, GEN SQRTS, GEN MUP, GEN GCD)
3064 : {
3065 6346506 : const long n4 = n << 2, N4 = N << 2, nu = k - 2;
3066 6346506 : const long st = (!odd(N) && odd(n)) ? 2 : 1;
3067 : long limt, t;
3068 : GEN S, Q;
3069 :
3070 6346506 : limt = usqrt(n4);
3071 6346506 : if (limt*limt == n4) limt--;
3072 6346506 : Q = nu > 3 ? ZX_z_unscale(mfrhopol(nu), n) : NULL;
3073 6346506 : S = gen_0;
3074 325461462 : for (t = odd(k)? st: 0; t <= limt; t += st) /* t^2 < 4n */
3075 : {
3076 319114956 : pari_sp av = avma;
3077 319114956 : long t2 = t*t, D = n4 - t2, F, D0, NF;
3078 : GEN sh, li;
3079 :
3080 319114956 : li = gel(SQRTS, (umodsu(-D - 1, N4) >> 1) + 1);
3081 327507200 : if (lg(li) == 1) continue;
3082 176273702 : D0 = mycoredisc2neg(D, &F);
3083 176273702 : NF = myugcd(GCD, F);
3084 176273702 : if (NF == 1)
3085 : { /* (N,F) = 1 => single value in mutglistall */
3086 161105370 : GEN mut = mutg1(t, N, VCHI, li, GCD);
3087 161105370 : if (!mut) { set_avma(av); continue; }
3088 156310125 : sh = gmul(uutoQ(hclassno6u_i(D,D0,F),6), mut);
3089 : }
3090 : else
3091 : {
3092 15168332 : GEN v = mutglistall(t, N, NF, VCHI, n, MUP, li, GCD);
3093 15168332 : GEN DF = mydivisorsu(F);
3094 15168332 : long i, lDF = lg(DF);
3095 15168332 : sh = gen_0;
3096 61172560 : for (i = 1; i < lDF; i++)
3097 : {
3098 46004228 : long Ff, f = DF[i], g = myugcd(GCD, f);
3099 46004228 : GEN mut = gel(v, g);
3100 46004228 : if (gequal0(mut)) continue;
3101 31110100 : Ff = DF[lDF-i]; /* F/f */
3102 31110100 : if (Ff == 1) sh = gadd(sh, mut);
3103 : else
3104 : {
3105 22300784 : GEN P = gel(myfactoru(Ff), 1);
3106 22300784 : long j, lP = lg(P);
3107 49187570 : for (j = 1; j < lP; j++) { long p = P[j]; Ff -= kross(D0, p)*Ff/p; }
3108 22300784 : sh = gadd(sh, gmulsg(Ff, mut));
3109 : }
3110 : }
3111 15168332 : if (gequal0(sh)) { set_avma(av); continue; }
3112 11571333 : if (D0 == -3) sh = gdivgu(sh, 3);
3113 11085851 : else if (D0 == -4) sh = gdivgu(sh, 2);
3114 10619294 : else sh = gmulgu(sh, myh(D0));
3115 : }
3116 167881458 : S = gerepileupto(av, gadd(S, mfrhopowsimp(Q,sh,nu,t,t2,n)));
3117 : }
3118 6346506 : return S;
3119 : }
3120 :
3121 : /* compute global auxiliary data for TA3 */
3122 : static GEN
3123 120183 : mkbez(long N, long FC)
3124 : {
3125 120183 : long ct, i, NF = N/FC;
3126 120183 : GEN w, D = mydivisorsu(N);
3127 120183 : long l = lg(D);
3128 :
3129 120183 : w = cgetg(l, t_VEC);
3130 349902 : for (i = ct = 1; i < l; i++)
3131 : {
3132 328951 : long u, v, h, c = D[i], Nc = D[l-i];
3133 328951 : if (c > Nc) break;
3134 229719 : h = cbezout(c, Nc, &u, &v);
3135 229719 : if (h == 1) /* shortcut */
3136 165410 : gel(w, ct++) = mkvecsmall4(1,u*c,1,i);
3137 64309 : else if (!(NF%h))
3138 54439 : gel(w, ct++) = mkvecsmall4(h,u*(c/h),myeulerphiu(h),i);
3139 : }
3140 120183 : setlg(w,ct); stackdummy((pari_sp)(w+ct),(pari_sp)(w+l));
3141 120183 : return w;
3142 : }
3143 :
3144 : /* contribution of hyperbolic matrices to trace formula, d * nd = n,
3145 : * DN = divisorsu(N) */
3146 : static GEN
3147 33101424 : auxsum(GEN VCHI, GEN GCD, long d, long nd, GEN DN, GEN BEZ)
3148 : {
3149 33101424 : GEN S = gen_0;
3150 33101424 : long ct, g = nd - d, lDN = lg(DN), lBEZ = lg(BEZ);
3151 85010205 : for (ct = 1; ct < lBEZ; ct++)
3152 : {
3153 51908781 : GEN y, B = gel(BEZ, ct);
3154 51908781 : long ic, c, Nc, uch, h = B[1];
3155 51908781 : if (g%h) continue;
3156 50704319 : uch = B[2];
3157 50704319 : ic = B[4];
3158 50704319 : c = DN[ic];
3159 50704319 : Nc= DN[lDN - ic]; /* Nc = N/c */
3160 50704319 : if (ugcd(Nc, nd) == 1)
3161 43286041 : y = mychicgcd(GCD, VCHI, d + uch*g); /* 0 if (c,d) > 1 */
3162 : else
3163 7418278 : y = NULL;
3164 50704319 : if (c != Nc && ugcd(Nc, d) == 1)
3165 : {
3166 38184836 : GEN y2 = mychicgcd(GCD, VCHI, nd - uch*g); /* 0 if (c,nd) > 1 */
3167 38184836 : if (y2) y = y? gadd(y, y2): y2;
3168 : }
3169 50704319 : if (y) S = gadd(S, gmulsg(B[3], y));
3170 : }
3171 33101424 : return S;
3172 : }
3173 :
3174 : static GEN
3175 6346506 : TA3(long N, long k, GEN VCHI, GEN GCD, GEN Dn, GEN BEZ)
3176 : {
3177 6346506 : GEN S = gen_0, DN = mydivisorsu(N);
3178 6346506 : long i, l = lg(Dn);
3179 39447930 : for (i = 1; i < l; i++)
3180 : {
3181 39411719 : long d = Dn[i], nd = Dn[l-i]; /* = n/d */
3182 : GEN t, u;
3183 39411719 : if (d > nd) break;
3184 33101424 : t = auxsum(VCHI, GCD, d, nd, DN, BEZ);
3185 33101424 : if (isintzero(t)) continue;
3186 31987577 : u = powuu(d,k-1); if (d == nd) u = gmul2n(u,-1);
3187 31987577 : S = gadd(S, gmul(u,t));
3188 : }
3189 6346506 : return S;
3190 : }
3191 :
3192 : /* special contribution in weight 2 in trace formula */
3193 : static long
3194 6346506 : TA4(long k, GEN VCHIP, GEN Dn, GEN GCD)
3195 : {
3196 : long i, l, S;
3197 6346506 : if (k != 2 || vchip_FC(VCHIP) != 1) return 0;
3198 5662951 : l = lg(Dn); S = 0;
3199 66241329 : for (i = 1; i < l; i++)
3200 : {
3201 60578378 : long d = Dn[i]; /* gcd(N,n/d) == 1? */
3202 60578378 : if (myugcd(GCD, Dn[l-i]) == 1) S += d;
3203 : }
3204 5662951 : return S;
3205 : }
3206 :
3207 : /* precomputation of products occurring im mutg, again to accelerate TA2 */
3208 : static GEN
3209 120183 : mkmup(long N)
3210 : {
3211 120183 : GEN fa = myfactoru(N), P = gel(fa,1), D = divisorsu_fact(fa);
3212 120183 : long i, lP = lg(P), lD = lg(D);
3213 120183 : GEN MUP = zero_zv(N);
3214 120183 : MUP[1] = 1;
3215 424445 : for (i = 2; i < lD; i++)
3216 : {
3217 304262 : long j, g = D[i], Ng = D[lD-i]; /* N/g */
3218 834575 : for (j = 1; j < lP; j++) { long p = P[j]; if (Ng%p) g += g/p; }
3219 304262 : MUP[D[i]] = g;
3220 : }
3221 120183 : return MUP;
3222 : }
3223 :
3224 : /* quadratic nonresidues mod p; p odd prime, p^2 fits in a long */
3225 : static GEN
3226 2702 : non_residues(long p)
3227 : {
3228 2702 : long i, j, p2 = p >> 1;
3229 2702 : GEN v = cgetg(p2+1, t_VECSMALL), w = const_vecsmall(p-1, 1);
3230 4459 : for (i = 2; i <= p2; i++) w[(i*i) % p] = 0; /* no need to check 1 */
3231 8918 : for (i = 2, j = 1; i < p; i++) if (w[i]) v[j++] = i;
3232 2702 : return v;
3233 : }
3234 :
3235 : /* CHIP primitive. Return t_VECSMALL v of length q such that
3236 : * Tr^new_{N,CHIP}(n) = 0 whenever v[(n%q) + 1] is nonzero */
3237 : static GEN
3238 31024 : mfnewzerodata(long N, GEN CHIP)
3239 : {
3240 31024 : GEN V, M, L, faN = myfactoru(N), PN = gel(faN,1), EN = gel(faN,2);
3241 31024 : GEN G = gel(CHIP,1), chi = gel(CHIP,2);
3242 31024 : GEN fa = znstar_get_faN(G), P = ZV_to_zv(gel(fa,1)), E = gel(fa,2);
3243 31024 : long i, mod, j = 1, l = lg(PN);
3244 :
3245 31024 : M = cgetg(l, t_VECSMALL); M[1] = 0;
3246 31024 : V = cgetg(l, t_VEC);
3247 : /* Tr^new(n) = 0 if (n mod M[i]) in V[i] */
3248 31024 : if ((N & 3) == 0)
3249 : {
3250 12467 : long e = EN[1];
3251 12467 : long c = (lg(P) > 1 && P[1] == 2)? E[1]: 0; /* c = v_2(FC) */
3252 : /* e >= 2 */
3253 12467 : if (c == e-1) return NULL; /* Tr^new = 0 */
3254 12362 : if (c == e)
3255 : {
3256 3696 : if (e == 2)
3257 : { /* sc: -4 */
3258 1764 : gel(V,1) = mkvecsmall(3);
3259 1764 : M[1] = 4;
3260 : }
3261 1932 : else if (e == 3)
3262 : { /* sc: -8 (CHI_2(-1)=-1<=>chi[1]=1) and 8 (CHI_2(-1)=1 <=> chi[1]=0) */
3263 1932 : long t = signe(gel(chi,1))? 7: 3;
3264 1932 : gel(V,1) = mkvecsmall2(5, t);
3265 1932 : M[1] = 8;
3266 : }
3267 : }
3268 8666 : else if (e == 5 && c == 3)
3269 154 : { /* sc: -8 (CHI_2(-1)=-1<=>chi[1]=1) and 8 (CHI_2(-1)=1 <=> chi[1]=0) */
3270 154 : long t = signe(gel(chi,1))? 7: 3;
3271 154 : gel(V,1) = mkvecsmalln(6, 2L,4L,5L,6L,8L,t);
3272 154 : M[1] = 8;
3273 : }
3274 8512 : else if ((e == 4 && c == 2) || (e == 5 && c <= 2) || (e == 6 && c <= 2)
3275 6937 : || (e >= 7 && c == e - 3))
3276 : { /* sc: 4 */
3277 1575 : gel(V,1) = mkvecsmall3(0,2,3);
3278 1575 : M[1] = 4;
3279 : }
3280 6937 : else if ((e <= 4 && c == 0) || (e >= 5 && c == e - 2))
3281 : { /* sc: 2 */
3282 6580 : gel(V,1) = mkvecsmall(0);
3283 6580 : M[1] = 2;
3284 : }
3285 357 : else if ((e == 6 && c == 3) || (e >= 7 && c <= e - 4))
3286 : { /* sc: -2 */
3287 357 : gel(V,1) = mkvecsmalln(7, 0L,2L,3L,4L,5L,6L,7L);
3288 357 : M[1] = 8;
3289 : }
3290 : }
3291 30919 : j = M[1]? 2: 1;
3292 66276 : for (i = odd(N)? 1: 2; i < l; i++) /* skip p=2, done above */
3293 : {
3294 35357 : long p = PN[i], e = EN[i];
3295 35357 : long z = zv_search(P, p), c = z? E[z]: 0; /* c = v_p(FC) */
3296 35357 : if ((e <= 2 && c == 1 && itos(gel(chi,z)) == (p>>1)) /* ord(CHI_p)=2 */
3297 33166 : || (e >= 3 && c <= e - 2))
3298 2702 : { /* sc: -p */
3299 2702 : GEN v = non_residues(p);
3300 2702 : if (e != 1) v = vecsmall_prepend(v, 0);
3301 2702 : gel(V,j) = v;
3302 2702 : M[j] = p; j++;
3303 : }
3304 32655 : else if (e >= 2 && c < e)
3305 : { /* sc: p */
3306 2233 : gel(V,j) = mkvecsmall(0);
3307 2233 : M[j] = p; j++;
3308 : }
3309 : }
3310 30919 : if (j == 1) return cgetg(1, t_VECSMALL);
3311 14539 : setlg(V,j); setlg(M,j); mod = zv_prod(M);
3312 14539 : L = zero_zv(mod);
3313 31836 : for (i = 1; i < j; i++)
3314 : {
3315 17297 : GEN v = gel(V,i);
3316 17297 : long s, m = M[i], lv = lg(v);
3317 45507 : for (s = 1; s < lv; s++)
3318 : {
3319 28210 : long a = v[s] + 1;
3320 54796 : do { L[a] = 1; a += m; } while (a <= mod);
3321 : }
3322 : }
3323 14539 : return L;
3324 : }
3325 : /* v=mfnewzerodata(N,CHI); returns TRUE if newtrace(n) must be zero,
3326 : * (but newtrace(n) may still be zero if we return FALSE) */
3327 : static long
3328 2580436 : mfnewchkzero(GEN v, long n) { long q = lg(v)-1; return q && v[(n%q) + 1]; }
3329 :
3330 : /* if (!VCHIP): from mftraceform_cusp;
3331 : * else from initnewtrace and CHI is known to be primitive */
3332 : static GEN
3333 120183 : inittrace(long N, GEN CHI, GEN VCHIP)
3334 : {
3335 : long FC;
3336 120183 : if (VCHIP)
3337 120176 : FC = mfcharmodulus(CHI);
3338 : else
3339 7 : VCHIP = mfcharinit(mfchartoprimitive(CHI, &FC));
3340 120183 : return mkvecn(5, mksqr(N), mkmup(N), mkgcd(N), VCHIP, mkbez(N, FC));
3341 : }
3342 :
3343 : /* p > 2 prime; return a sorted t_VECSMALL of primes s.t Tr^new(p) = 0 for all
3344 : * weights > 2 */
3345 : static GEN
3346 30919 : inittrconj(long N, long FC)
3347 : {
3348 : GEN fa, P, E, v;
3349 : long i, k, l;
3350 :
3351 30919 : if (FC != 1) return cgetg(1,t_VECSMALL);
3352 :
3353 25459 : fa = myfactoru(N >> vals(N));
3354 25459 : P = gel(fa,1); l = lg(P);
3355 25459 : E = gel(fa,2);
3356 25459 : v = cgetg(l, t_VECSMALL);
3357 55874 : for (i = k = 1; i < l; i++)
3358 : {
3359 30415 : long j, p = P[i]; /* > 2 */
3360 74186 : for (j = 1; j < l; j++)
3361 43771 : if (j != i && E[j] == 1 && kross(-p, P[j]) == 1) v[k++] = p;
3362 : }
3363 25459 : setlg(v,k); return v;
3364 : }
3365 :
3366 : /* assume CHIP primitive, f(CHIP) | N; NZ = mfnewzerodata(N,CHIP) */
3367 : static GEN
3368 30919 : initnewtrace_i(long N, GEN CHIP, GEN NZ)
3369 : {
3370 30919 : GEN T = const_vec(N, cgetg(1,t_VEC)), D, VCHIP;
3371 30919 : long FC = mfcharmodulus(CHIP), N1, N2, i, l;
3372 :
3373 30919 : if (!NZ) NZ = mkvecsmall(1); /*Tr^new = 0; initialize data nevertheless*/
3374 30919 : VCHIP = mfcharinit(CHIP);
3375 30919 : N1 = N/FC; newd_params(N1, &N2);
3376 30919 : D = mydivisorsu(N1/N2); l = lg(D);
3377 30919 : N2 *= FC;
3378 151095 : for (i = 1; i < l; i++)
3379 : {
3380 120176 : long M = D[i]*N2;
3381 120176 : gel(T,M) = inittrace(M, CHIP, VCHIP);
3382 : }
3383 30919 : gel(T,N) = shallowconcat(gel(T,N), mkvec2(NZ, inittrconj(N,FC)));
3384 30919 : return T;
3385 : }
3386 : /* don't initialize if Tr^new = 0, return NULL */
3387 : static GEN
3388 31024 : initnewtrace(long N, GEN CHI)
3389 : {
3390 31024 : GEN CHIP = mfchartoprimitive(CHI, NULL), NZ = mfnewzerodata(N,CHIP);
3391 31024 : return NZ? initnewtrace_i(N, CHIP, NZ): NULL;
3392 : }
3393 :
3394 : /* (-1)^k */
3395 : static long
3396 8092 : m1pk(long k) { return odd(k)? -1 : 1; }
3397 : static long
3398 7735 : badchar(long N, long k, GEN CHI)
3399 7735 : { return mfcharparity(CHI) != m1pk(k) || (CHI && N % mfcharconductor(CHI)); }
3400 :
3401 :
3402 : static long
3403 42686 : mfcuspdim_i(long N, long k, GEN CHI, GEN vSP)
3404 : {
3405 42686 : pari_sp av = avma;
3406 : long FC;
3407 : GEN s;
3408 42686 : if (k <= 0) return 0;
3409 42686 : if (k == 1) return CHI? mf1cuspdim(N, CHI, vSP): 0;
3410 42427 : FC = CHI? mfcharconductor(CHI): 1;
3411 42427 : if (FC == 1) CHI = NULL;
3412 42427 : s = gsub(A1(N, k), gadd(A21(N, k, CHI), A22(N, k, CHI)));
3413 42427 : s = gadd(s, gsubsg(A4(k, FC), A3(N, FC)));
3414 42427 : return gc_long(av, itos(s));
3415 : }
3416 : /* dimension of space of cusp forms S_k(\G_0(N),CHI)
3417 : * Only depends on CHIP the primitive char attached to CHI */
3418 : long
3419 3339 : mfcuspdim(long N, long k, GEN CHI) { return mfcuspdim_i(N, k, CHI, NULL); }
3420 :
3421 : /* dimension of whole space M_k(\G_0(N),CHI)
3422 : * Only depends on CHIP the primitive char attached to CHI; assumes !badchar */
3423 : long
3424 833 : mffulldim(long N, long k, GEN CHI)
3425 : {
3426 833 : pari_sp av = avma;
3427 833 : long FC = CHI? mfcharconductor(CHI): 1;
3428 : GEN s;
3429 833 : if (k <= 0) return (k == 0 && FC == 1)? 1: 0;
3430 833 : if (k == 1) return gc_long(av, itos(A3(N, FC)) + mf1cuspdim(N, CHI, NULL));
3431 616 : if (FC == 1) CHI = NULL;
3432 616 : s = gsub(A1(N, k), gadd(A21(N, k, CHI), A22(N, k, CHI)));
3433 616 : s = gadd(s, A3(N, FC));
3434 616 : return gc_long(av, itos(s));
3435 : }
3436 :
3437 : /* Dimension of the space of Eisenstein series */
3438 : long
3439 231 : mfeisensteindim(long N, long k, GEN CHI)
3440 : {
3441 231 : pari_sp av = avma;
3442 231 : long s, FC = CHI? mfcharconductor(CHI): 1;
3443 231 : if (k <= 0) return (k == 0 && FC == 1)? 1: 0;
3444 231 : s = itos(gmul2n(A3(N, FC), 1));
3445 231 : if (k > 1) s -= A4(k, FC); else s >>= 1;
3446 231 : return gc_long(av,s);
3447 : }
3448 :
3449 : enum { _SQRTS = 1, _MUP, _GCD, _VCHIP, _BEZ, _NEWLZ, _TRCONJ };
3450 : /* Trace of T(n) on space of cuspforms; only depends on CHIP the primitive char
3451 : * attached to CHI */
3452 : static GEN
3453 6346506 : mfcusptrace_i(long N, long k, long n, GEN Dn, GEN S)
3454 : {
3455 6346506 : pari_sp av = avma;
3456 : GEN a, b, VCHIP, GCD;
3457 : long t;
3458 6346506 : if (!n) return gen_0;
3459 6346506 : VCHIP = gel(S,_VCHIP);
3460 6346506 : GCD = gel(S,_GCD);
3461 6346506 : t = TA4(k, VCHIP, Dn, GCD);
3462 6346506 : a = TA1(N, k, VCHIP, GCD, n); if (t) a = gaddgs(a,t);
3463 6346506 : b = TA2(N, k, VCHIP, n, gel(S,_SQRTS), gel(S,_MUP), GCD);
3464 6346506 : b = gadd(b, TA3(N, k, VCHIP, GCD, Dn, gel(S,_BEZ)));
3465 6346506 : b = gsub(a,b);
3466 6346506 : if (typ(b) != t_POL) return gerepileupto(av, b);
3467 38675 : return gerepilecopy(av, vchip_polmod(VCHIP, b));
3468 : }
3469 :
3470 : static GEN
3471 7600969 : mfcusptracecache(long N, long k, long n, GEN Dn, GEN S, cachenew_t *cache)
3472 : {
3473 7600969 : GEN C = NULL, T = gel(cache->vfull,N);
3474 7600969 : long lcache = lg(T);
3475 7600969 : if (n < lcache) C = gel(T, n);
3476 7600969 : if (C) cache->cuspHIT++; else C = mfcusptrace_i(N, k, n, Dn, S);
3477 7600969 : cache->cuspTOTAL++;
3478 7600969 : if (n < lcache) gel(T,n) = C;
3479 7600969 : return C;
3480 : }
3481 :
3482 : /* return the divisors of n, known to be among the elements of D */
3483 : static GEN
3484 318955 : div_restrict(GEN D, ulong n)
3485 : {
3486 : long i, j, l;
3487 318955 : GEN v, VDIV = caches[cache_DIV].cache;
3488 318955 : if (lg(VDIV) > n) return gel(VDIV,n);
3489 0 : l = lg(D);
3490 0 : v = cgetg(l, t_VECSMALL);
3491 0 : for (i = j = 1; i < l; i++)
3492 : {
3493 0 : ulong d = D[i];
3494 0 : if (n % d == 0) v[j++] = d;
3495 : }
3496 0 : setlg(v,j); return v;
3497 : }
3498 :
3499 : /* for some prime divisors of N, Tr^new(p) = 0 */
3500 : static int
3501 199322 : trconj(GEN T, long N, long n)
3502 199322 : { return (lg(T) > 1 && N % n == 0 && zv_search(T, n)); }
3503 :
3504 : /* n > 0; trace formula on new space */
3505 : static GEN
3506 2580436 : mfnewtrace_i(long N, long k, long n, cachenew_t *cache)
3507 : {
3508 2580436 : GEN VCHIP, s, Dn, DN1, SN, S = cache->DATA;
3509 : long FC, N1, N2, N1N2, g, i, j, lDN1;
3510 :
3511 2580436 : if (!S) return gen_0;
3512 2580436 : SN = gel(S,N);
3513 2580436 : if (mfnewchkzero(gel(SN,_NEWLZ), n)) return gen_0;
3514 1861843 : if (k > 2 && trconj(gel(SN,_TRCONJ), N, n)) return gen_0;
3515 1861815 : VCHIP = gel(SN, _VCHIP); FC = vchip_FC(VCHIP);
3516 1861815 : N1 = N/FC; newt_params(N1, n, FC, &g, &N2);
3517 1861815 : N1N2 = N1/N2;
3518 1861815 : DN1 = mydivisorsu(N1N2); lDN1 = lg(DN1);
3519 1861815 : N2 *= FC;
3520 1861815 : Dn = mydivisorsu(n); /* this one is probably out of cache */
3521 1861815 : s = gmulsg(mubeta2(N1N2,n), mfcusptracecache(N2, k, n, Dn, gel(S,N2), cache));
3522 7282014 : for (i = 2; i < lDN1; i++)
3523 : { /* skip M1 = 1, done above */
3524 5420199 : long M1 = DN1[i], N1M1 = DN1[lDN1-i];
3525 5420199 : GEN Dg = mydivisorsu(ugcd(M1, g));
3526 5420199 : M1 *= N2;
3527 5420199 : s = gadd(s, gmulsg(mubeta2(N1M1,n),
3528 5420199 : mfcusptracecache(M1, k, n, Dn, gel(S,M1), cache)));
3529 5739154 : for (j = 2; j < lg(Dg); j++) /* skip d = 1, done above */
3530 : {
3531 318955 : long d = Dg[j], ndd = n/(d*d), M = M1/d;
3532 318955 : GEN z = mulsi(mubeta2(N1M1,ndd), powuu(d,k-1)), C = vchip_lift(VCHIP,d,z);
3533 318955 : GEN Dndd = div_restrict(Dn, ndd);
3534 318955 : s = gadd(s, gmul(C, mfcusptracecache(M, k, ndd, Dndd, gel(S,M), cache)));
3535 : }
3536 5420199 : s = vchip_mod(VCHIP, s);
3537 : }
3538 1861815 : return vchip_polmod(VCHIP, s);
3539 : }
3540 :
3541 : static GEN
3542 12355 : get_DIH(long N)
3543 : {
3544 12355 : GEN x = cache_get(cache_DIH, N);
3545 12355 : return x? gcopy(x): mfdihedral(N);
3546 : }
3547 : static GEN
3548 2373 : get_vDIH(long N, GEN D)
3549 : {
3550 2373 : GEN x = const_vec(N, NULL);
3551 : long i, l;
3552 2373 : if (!D) D = mydivisorsu(N);
3553 2373 : l = lg(D);
3554 14504 : for (i = 1; i < l; i++) { long d = D[i]; gel(x, d) = get_DIH(d); }
3555 2373 : return x;
3556 : }
3557 :
3558 : /* divisors of N which are multiple of F */
3559 : static GEN
3560 322 : divisorsNF(long N, long F)
3561 : {
3562 322 : GEN D = mydivisorsu(N / F);
3563 322 : long l = lg(D), i;
3564 833 : for (i = 1; i < l; i++) D[i] = N / D[i];
3565 322 : return D;
3566 : }
3567 : /* mfcuspdim(N,k,CHI) - mfnewdim(N,k,CHI); CHIP primitive (for efficiency) */
3568 : static long
3569 8239 : mfolddim_i(long N, long k, GEN CHIP, GEN vSP)
3570 : {
3571 8239 : long S, i, l, F = mfcharmodulus(CHIP), N1 = N / F, N2;
3572 : GEN D;
3573 8239 : newd_params(N1, &N2); /* will ensure mubeta != 0 */
3574 8239 : D = mydivisorsu(N1/N2); l = lg(D); S = 0;
3575 8239 : if (k == 1 && !vSP) vSP = get_vDIH(N, divisorsNF(N, F));
3576 32011 : for (i = 2; i < l; i++)
3577 : {
3578 23772 : long d = mfcuspdim_i(N / D[i], k, CHIP, vSP);
3579 23772 : if (d) S -= mubeta(D[i]) * d;
3580 : }
3581 8239 : return S;
3582 : }
3583 : long
3584 224 : mfolddim(long N, long k, GEN CHI)
3585 : {
3586 224 : pari_sp av = avma;
3587 224 : GEN CHIP = mfchartoprimitive(CHI, NULL);
3588 224 : return gc_long(av, mfolddim_i(N, k, CHIP, NULL));
3589 : }
3590 : /* Only depends on CHIP the primitive char attached to CHI; assumes !badchar */
3591 : long
3592 15575 : mfnewdim(long N, long k, GEN CHI)
3593 : {
3594 : pari_sp av;
3595 : long S, F;
3596 15575 : GEN vSP, CHIP = mfchartoprimitive(CHI, &F);
3597 15575 : vSP = (k == 1)? get_vDIH(N, divisorsNF(N, F)): NULL;
3598 15575 : S = mfcuspdim_i(N, k, CHIP, vSP); if (!S) return 0;
3599 7742 : av = avma; return gc_long(av, S - mfolddim_i(N, k, CHIP, vSP));
3600 : }
3601 :
3602 : /* trace form, given as closure */
3603 : static GEN
3604 938 : mftraceform_new(long N, long k, GEN CHI)
3605 : {
3606 : GEN T;
3607 938 : if (k == 1) return initwt1newtrace(mfinit_Nkchi(N, 1, CHI, mf_CUSP, 0));
3608 917 : T = initnewtrace(N,CHI); if (!T) return mftrivial();
3609 917 : return tag(t_MF_NEWTRACE, mkNK(N,k,CHI), T);
3610 : }
3611 : static GEN
3612 14 : mftraceform_cusp(long N, long k, GEN CHI)
3613 : {
3614 14 : if (k == 1) return initwt1trace(mfinit_Nkchi(N, 1, CHI, mf_CUSP, 0));
3615 7 : return tag(t_MF_TRACE, mkNK(N,k,CHI), inittrace(N,CHI,NULL));
3616 : }
3617 : static GEN
3618 98 : mftraceform_i(GEN NK, long space)
3619 : {
3620 : GEN CHI;
3621 : long N, k;
3622 98 : checkNK(NK, &N, &k, &CHI, 0);
3623 98 : if (!mfdim_Nkchi(N, k, CHI, space)) return mftrivial();
3624 77 : switch(space)
3625 : {
3626 56 : case mf_NEW: return mftraceform_new(N, k, CHI);
3627 14 : case mf_CUSP:return mftraceform_cusp(N, k, CHI);
3628 : }
3629 7 : pari_err_DOMAIN("mftraceform", "space", "=", utoi(space), NK);
3630 : return NULL;/*LCOV_EXCL_LINE*/
3631 : }
3632 : GEN
3633 98 : mftraceform(GEN NK, long space)
3634 98 : { pari_sp av = avma; return gerepilecopy(av, mftraceform_i(NK,space)); }
3635 :
3636 : static GEN
3637 17500 : hecke_data(long N, long n)
3638 17500 : { return mkvecsmall3(n, u_ppo(n, N), N); }
3639 : /* 1/2-integral weight */
3640 : static GEN
3641 84 : heckef2_data(long N, long n)
3642 : {
3643 : ulong f, fN, fN2;
3644 84 : if (!uissquareall(n, &f)) return NULL;
3645 77 : fN = u_ppo(f, N); fN2 = fN*fN;
3646 77 : return mkvec2(myfactoru(fN), mkvecsmall4(n, N, fN2, n/fN2));
3647 : }
3648 : /* N = mf_get_N(F) or a multiple */
3649 : static GEN
3650 24472 : mfhecke_i(long n, long N, GEN F)
3651 : {
3652 24472 : if (n == 1) return F;
3653 17129 : return tag2(t_MF_HECKE, mf_get_NK(F), hecke_data(N,n), F);
3654 : }
3655 :
3656 : GEN
3657 105 : mfhecke(GEN mf, GEN F, long n)
3658 : {
3659 105 : pari_sp av = avma;
3660 : GEN NK, CHI, gk, DATA;
3661 : long N, nk, dk;
3662 105 : mf = checkMF(mf);
3663 105 : if (!checkmf_i(F)) pari_err_TYPE("mfhecke",F);
3664 105 : if (n <= 0) pari_err_TYPE("mfhecke [n <= 0]", stoi(n));
3665 105 : if (n == 1) return gcopy(F);
3666 105 : gk = mf_get_gk(F);
3667 105 : Qtoss(gk,&nk,&dk);
3668 105 : CHI = mf_get_CHI(F);
3669 105 : N = MF_get_N(mf);
3670 105 : if (dk == 2)
3671 : {
3672 77 : DATA = heckef2_data(N,n);
3673 77 : if (!DATA) return mftrivial();
3674 : }
3675 : else
3676 28 : DATA = hecke_data(N,n);
3677 98 : NK = mkgNK(lcmii(stoi(N), mf_get_gN(F)), gk, CHI, mf_get_field(F));
3678 98 : return gerepilecopy(av, tag2(t_MF_HECKE, NK, DATA, F));
3679 : }
3680 :
3681 : /* form F given by closure, compute B(d)(F) as closure (q -> q^d) */
3682 : static GEN
3683 35399 : mfbd_i(GEN F, long d)
3684 : {
3685 : GEN D, NK, gk, CHI;
3686 35399 : if (d == 1) return F;
3687 13293 : if (d <= 0) pari_err_TYPE("mfbd [d <= 0]", stoi(d));
3688 13293 : if (mf_get_type(F) != t_MF_BD) D = utoi(d);
3689 7 : else { D = mului(d, gel(F,3)); F = gel(F,2); }
3690 13293 : gk = mf_get_gk(F); CHI = mf_get_CHI(F);
3691 13293 : if (typ(gk) != t_INT) CHI = mfcharmul(CHI, get_mfchar(utoi(d << 2)));
3692 13293 : NK = mkgNK(muliu(mf_get_gN(F), d), gk, CHI, mf_get_field(F));
3693 13293 : return tag2(t_MF_BD, NK, F, D);
3694 : }
3695 : GEN
3696 42 : mfbd(GEN F, long d)
3697 : {
3698 42 : pari_sp av = avma;
3699 42 : if (!checkmf_i(F)) pari_err_TYPE("mfbd",F);
3700 42 : return gerepilecopy(av, mfbd_i(F, d));
3701 : }
3702 :
3703 : /* A[i+1] = a(t*i^2) */
3704 : static GEN
3705 105 : RgV_shimura(GEN A, long n, long t, long N, long r, GEN CHI)
3706 : {
3707 105 : GEN R, a0, Pn = mfcharpol(CHI);
3708 105 : long m, st, ord = mfcharorder(CHI), vt = varn(Pn), Nt = t == 1? N: ulcm(N,t);
3709 :
3710 105 : R = cgetg(n + 2, t_VEC);
3711 105 : st = odd(r)? -t: t;
3712 105 : a0 = gel(A, 1);
3713 105 : if (!gequal0(a0))
3714 : {
3715 14 : long o = mfcharorder(CHI);
3716 14 : if (st != 1 && odd(o)) o <<= 1;
3717 14 : a0 = gmul(a0, charLFwtk(Nt, r, CHI, o, st));
3718 : }
3719 105 : gel(R, 1) = a0;
3720 637 : for (m = 1; m <= n; m++)
3721 : {
3722 532 : GEN Dm = mydivisorsu(u_ppo(m, Nt)), S = gel(A, m*m + 1);
3723 532 : long i, l = lg(Dm);
3724 805 : for (i = 2; i < l; i++)
3725 : { /* (e,Nt) = 1; skip i = 1: e = 1, done above */
3726 273 : long e = Dm[i], me = m / e, a = mfcharevalord(CHI, e, ord);
3727 273 : GEN c, C = powuu(e, r - 1);
3728 273 : if (kross(st, e) == -1) C = negi(C);
3729 273 : c = Qab_Czeta(a, ord, C, vt);
3730 273 : S = gadd(S, gmul(c, gel(A, me*me + 1)));
3731 : }
3732 532 : gel(R, m+1) = S;
3733 : }
3734 105 : return degpol(Pn) > 1? gmodulo(R, Pn): R;
3735 : }
3736 :
3737 : static long
3738 28 : mfisinkohnen(GEN mf, GEN F)
3739 : {
3740 28 : GEN v, gk = MF_get_gk(mf), CHI = MF_get_CHI(mf);
3741 28 : long i, eps, N4 = MF_get_N(mf) >> 2, sb = mfsturmNgk(N4 << 4, gk) + 1;
3742 28 : eps = N4 % mfcharconductor(CHI)? -1 : 1;
3743 28 : if (odd(MF_get_r(mf))) eps = -eps;
3744 28 : v = mfcoefs(F, sb, 1);
3745 686 : for (i = 2; i <= sb; i+=4) if (!gequal0(gel(v,i+1))) return 0;
3746 245 : for (i = 2+eps; i <= sb; i+=4) if (!gequal0(gel(v,i+1))) return 0;
3747 14 : return 1;
3748 : }
3749 :
3750 : static long
3751 42 : mfshimura_space_cusp(GEN mf)
3752 : {
3753 : long N4;
3754 42 : if (MF_get_r(mf) == 1 && (N4 = MF_get_N(mf) >> 2) >= 4)
3755 : {
3756 21 : GEN E = gel(myfactoru(N4), 2);
3757 21 : long ma = vecsmall_max(E);
3758 21 : if (ma > 2 || (ma == 2 && !mfcharistrivial(MF_get_CHI(mf)))) return 0;
3759 : }
3760 28 : return 1;
3761 : }
3762 :
3763 : /* D is either a discriminant (not necessarily fundamental) with
3764 : sign(D)=(-1)^{k-1/2}*eps, or a positive squarefree integer t, which is then
3765 : transformed into a fundamental discriminant of the correct sign. */
3766 : GEN
3767 49 : mfshimura(GEN mf, GEN F, long t)
3768 : {
3769 49 : pari_sp av = avma;
3770 : GEN G, res, mf2, CHI;
3771 49 : long sb, M, r, N, space = mf_FULL;
3772 :
3773 49 : if (!checkmf_i(F)) pari_err_TYPE("mfshimura",F);
3774 49 : mf = checkMF(mf);
3775 49 : r = MF_get_r(mf);
3776 49 : if (r <= 0) pari_err_DOMAIN("mfshimura", "weight", "<=", ghalf, mf_get_gk(F));
3777 49 : if (t <= 0 || !uissquarefree(t)) pari_err_TYPE("mfshimura [t]", stoi(t));
3778 42 : N = MF_get_N(mf); M = N >> 1;
3779 42 : if (mfiscuspidal(mf,F))
3780 : {
3781 28 : if (mfshimura_space_cusp(mf)) space = mf_CUSP;
3782 28 : if (mfisinkohnen(mf,F)) M = N >> 2;
3783 : }
3784 42 : CHI = MF_get_CHI(mf);
3785 42 : mf2 = mfinit_Nkchi(M, r << 1, mfcharpow(CHI, gen_2), space, 0);
3786 42 : sb = mfsturm(mf2);
3787 42 : G = RgV_shimura(mfcoefs_i(F, sb*sb, t), sb, t, N, r, CHI);
3788 42 : res = mftobasis_i(mf2, G);
3789 : /* not mflinear(mf2,): we want lowest possible level */
3790 42 : G = mflinear(MF_get_basis(mf2), res);
3791 42 : return gerepilecopy(av, mkvec3(mf2, G, res));
3792 : }
3793 :
3794 : /* W ZabM (ZM if n = 1), a t_INT or NULL, b t_INT, ZXQ mod P or NULL.
3795 : * Write a/b = A/d with d t_INT and A Zab return [W,d,A,P] */
3796 : static GEN
3797 7630 : mkMinv(GEN W, GEN a, GEN b, GEN P)
3798 : {
3799 7630 : GEN A = (b && typ(b) == t_POL)? Q_remove_denom(QXQ_inv(b,P), &b): NULL;
3800 7630 : if (a && b)
3801 : {
3802 1281 : a = Qdivii(a,b);
3803 1281 : if (typ(a) == t_INT) b = gen_1; else { b = gel(a,2); a = gel(a,1); }
3804 1281 : if (is_pm1(a)) a = NULL;
3805 : }
3806 7630 : if (a) A = A? ZX_Z_mul(A,a): a; else if (!A) A = gen_1;
3807 7630 : if (!b) b = gen_1;
3808 7630 : if (!P) P = gen_0;
3809 7630 : return mkvec4(W,b,A,P);
3810 : }
3811 : /* M square invertible QabM, return [M',d], M*M' = d*Id */
3812 : static GEN
3813 574 : QabM_Minv(GEN M, GEN P, long n)
3814 : {
3815 : GEN dW, W, dM;
3816 574 : M = Q_remove_denom(M, &dM);
3817 574 : W = P? ZabM_inv(liftpol_shallow(M), P, n, &dW): ZM_inv(M, &dW);
3818 574 : return mkMinv(W, dM, dW, P);
3819 : }
3820 : /* Simplified form of mfclean, after a QabM_indexrank: M a ZabM with full
3821 : * column rank and z = indexrank(M) is known */
3822 : static GEN
3823 833 : mfclean2(GEN M, GEN z, GEN P, long n)
3824 : {
3825 833 : GEN d, Minv, y = gel(z,1), W = rowpermute(M, y);
3826 833 : W = P? ZabM_inv(liftpol_shallow(W), P, n, &d): ZM_inv(W, &d);
3827 833 : M = rowslice(M, 1, y[lg(y)-1]);
3828 833 : Minv = mkMinv(W, NULL, d, P);
3829 833 : return mkvec3(y, Minv, M);
3830 : }
3831 : /* M QabM, lg(M)>1 and [y,z] its rank profile. Let Minv be the inverse of the
3832 : * invertible square matrix in mkMinv format. Return [y,Minv, M[..y[#y],]]
3833 : * P cyclotomic polynomial of order n > 2 or NULL */
3834 : static GEN
3835 4935 : mfclean(GEN M, GEN P, long n, int ratlift)
3836 : {
3837 4935 : GEN W, v, y, z, d, Minv, dM, MdM = Q_remove_denom(M, &dM);
3838 4935 : if (n <= 2)
3839 3843 : W = ZM_pseudoinv(MdM, &v, &d);
3840 : else
3841 1092 : W = ZabM_pseudoinv_i(liftpol_shallow(MdM), P, n, &v, &d, ratlift);
3842 4935 : y = gel(v,1);
3843 4935 : z = gel(v,2);
3844 4935 : if (lg(z) != lg(MdM)) M = vecpermute(M,z);
3845 4935 : M = rowslice(M, 1, y[lg(y)-1]);
3846 4935 : Minv = mkMinv(W, dM, d, P);
3847 4935 : return mkvec3(y, Minv, M);
3848 : }
3849 : /* call mfclean using only CHI */
3850 : static GEN
3851 3983 : mfcleanCHI(GEN M, GEN CHI, int ratlift)
3852 : {
3853 3983 : long n = mfcharorder(CHI);
3854 3983 : GEN P = (n <= 2)? NULL: mfcharpol(CHI);
3855 3983 : return mfclean(M, P, n, ratlift);
3856 : }
3857 :
3858 : /* DATA component of a t_MF_NEWTRACE. Was it stripped to save memory ? */
3859 : static int
3860 31934 : newtrace_stripped(GEN DATA)
3861 31934 : { return DATA && (lg(DATA) == 5 && typ(gel(DATA,3)) == t_INT); }
3862 : /* f a t_MF_NEWTRACE */
3863 : static GEN
3864 31934 : newtrace_DATA(long N, GEN f)
3865 : {
3866 31934 : GEN DATA = gel(f,2);
3867 31934 : return newtrace_stripped(DATA)? initnewtrace(N, DATA): DATA;
3868 : }
3869 : /* reset cachenew for new level incorporating new DATA, tf a t_MF_NEWTRACE
3870 : * (+ possibly initialize 'full' for new allowed levels) */
3871 : static void
3872 31934 : reset_cachenew(cachenew_t *cache, long N, GEN tf)
3873 : {
3874 : long i, n, l;
3875 31934 : GEN v, DATA = newtrace_DATA(N,tf);
3876 31934 : cache->DATA = DATA;
3877 31934 : if (!DATA) return;
3878 31829 : n = cache->n;
3879 31829 : v = cache->vfull; l = N+1; /* = lg(DATA) */
3880 2155909 : for (i = 1; i < l; i++)
3881 2124080 : if (typ(gel(v,i)) == t_INT && lg(gel(DATA,i)) != 1)
3882 48965 : gel(v,i) = const_vec(n, NULL);
3883 31829 : cache->VCHIP = gel(gel(DATA,N),_VCHIP);
3884 : }
3885 : /* initialize a cache of newtrace / cusptrace up to index n and level | N;
3886 : * DATA may be NULL (<=> Tr^new = 0). tf a t_MF_NEWTRACE */
3887 : static void
3888 12173 : init_cachenew(cachenew_t *cache, long n, long N, GEN tf)
3889 : {
3890 12173 : long i, l = N+1; /* = lg(tf.DATA) when DATA != NULL */
3891 : GEN v;
3892 12173 : cache->n = n;
3893 12173 : cache->vnew = v = cgetg(l, t_VEC);
3894 914998 : for (i = 1; i < l; i++) gel(v,i) = (N % i)? gen_0: const_vec(n, NULL);
3895 12173 : cache->newHIT = cache->newTOTAL = cache->cuspHIT = cache->cuspTOTAL = 0;
3896 12173 : cache->vfull = v = zerovec(N);
3897 12173 : reset_cachenew(cache, N, tf);
3898 12173 : }
3899 : static void
3900 16415 : dbg_cachenew(cachenew_t *C)
3901 : {
3902 16415 : if (DEBUGLEVEL >= 2 && C)
3903 0 : err_printf("newtrace cache hits: new = %ld/%ld, cusp = %ld/%ld\n",
3904 : C->newHIT, C->newTOTAL, C->cuspHIT, C->cuspTOTAL);
3905 16415 : }
3906 :
3907 : /* newtrace_{N,k}(d*i), i = n0, ..., n */
3908 : static GEN
3909 177898 : colnewtrace(long n0, long n, long d, long N, long k, cachenew_t *cache)
3910 : {
3911 177898 : GEN v = cgetg(n-n0+2, t_COL);
3912 : long i;
3913 4657394 : for (i = n0; i <= n; i++) gel(v, i-n0+1) = mfnewtracecache(N, k, i*d, cache);
3914 177898 : return v;
3915 : }
3916 : /* T_n(l*m0, l*(m0+1), ..., l*m) F, F = t_MF_NEWTRACE [N,k],DATA, cache
3917 : * contains DATA != NULL as well as cached values of F */
3918 : static GEN
3919 87801 : heckenewtrace(long m0, long m, long l, long N, long NBIG, long k, long n, cachenew_t *cache)
3920 : {
3921 87801 : long lD, a, k1, nl = n*l;
3922 87801 : GEN D, V, v = colnewtrace(m0, m, nl, N, k, cache); /* d=1 */
3923 : GEN VCHIP;
3924 87801 : if (n == 1) return v;
3925 60718 : VCHIP = cache->VCHIP;
3926 60718 : D = mydivisorsu(u_ppo(n, NBIG)); lD = lg(D);
3927 60718 : k1 = k - 1;
3928 149233 : for (a = 2; a < lD; a++)
3929 : { /* d > 1, (d,NBIG) = 1 */
3930 88515 : long i, j, d = D[a], c = ugcd(l, d), dl = d/c, m0d = ceildivuu(m0, dl);
3931 88515 : GEN C = vchip_lift(VCHIP, d, powuu(d, k1));
3932 : /* m0=0: i = 1 => skip F(0) = 0 */
3933 88515 : if (!m0) { i = 1; j = dl; } else { i = 0; j = m0d*dl; }
3934 88515 : V = colnewtrace(m0d, m/dl, nl/(d*c), N, k, cache);
3935 : /* C = chi(d) d^(k-1) */
3936 1075242 : for (; j <= m; i++, j += dl)
3937 986727 : gel(v,j-m0+1) = gadd(gel(v,j-m0+1), vchip_mod(VCHIP, gmul(C,gel(V,i+1))));
3938 : }
3939 60718 : return v;
3940 : }
3941 :
3942 : /* Given v = an[i], return an[d*i], i=0..n */
3943 : static GEN
3944 2618 : anextract(GEN v, long n, long d)
3945 : {
3946 2618 : long i, id, l = n + 2;
3947 2618 : GEN w = cgetg(l, t_VEC);
3948 2618 : if (d == 1)
3949 7245 : for (i = 1; i < l; i++) gel(w, i) = gel(v, i);
3950 : else
3951 22036 : for (i = id = 1; i < l; i++, id += d) gel(w, i) = gel(v, id);
3952 2618 : return w;
3953 : }
3954 : /* T_n(F)(0, l, ..., l*m) */
3955 : static GEN
3956 2471 : hecke_i(long m, long l, GEN V, GEN F, GEN DATA)
3957 : {
3958 : long k, n, nNBIG, NBIG, lD, M, a, t, nl;
3959 : GEN D, v, CHI;
3960 2471 : if (typ(DATA) == t_VEC)
3961 : { /* 1/2-integral k */
3962 98 : if (!V) { GEN S = gel(DATA,2); V = mfcoefs_i(F, m*l*S[3], S[4]); }
3963 98 : return RgV_heckef2(m, l, V, F, DATA);
3964 : }
3965 2373 : k = mf_get_k(F);
3966 2373 : n = DATA[1]; nl = n*l;
3967 2373 : nNBIG = DATA[2];
3968 2373 : NBIG = DATA[3];
3969 2373 : if (nNBIG == 1) return V? V: mfcoefs_i(F,m,nl);
3970 1631 : if (!V && mf_get_type(F) == t_MF_NEWTRACE)
3971 : { /* inline F to allow cache, T_n at level NBIG acting on Tr^new(N,k,CHI) */
3972 : cachenew_t cache;
3973 322 : long N = mf_get_N(F);
3974 322 : init_cachenew(&cache, m*nl, N, F);
3975 322 : v = heckenewtrace(0, m, l, N, NBIG, k, n, &cache);
3976 322 : dbg_cachenew(&cache);
3977 322 : settyp(v, t_VEC); return v;
3978 : }
3979 1309 : CHI = mf_get_CHI(F);
3980 1309 : D = mydivisorsu(nNBIG); lD = lg(D);
3981 1309 : M = m + 1;
3982 1309 : t = nNBIG * ugcd(nNBIG, l);
3983 1309 : if (!V) V = mfcoefs_i(F, m * t, nl / t); /* usually nl = t */
3984 1309 : v = anextract(V, m, t); /* mfcoefs(F, m, nl); d = 1 */
3985 2618 : for (a = 2; a < lD; a++)
3986 : { /* d > 1, (d, NBIG) = 1 */
3987 1309 : long d = D[a], c = ugcd(l, d), dl = d/c, i, idl;
3988 1309 : GEN C = gmul(mfchareval(CHI, d), powuu(d, k-1));
3989 1309 : GEN w = anextract(V, m/dl, t/(d*c)); /* mfcoefs(F, m/dl, nl/(d*c)) */
3990 7245 : for (i = idl = 1; idl <= M; i++, idl += dl)
3991 5936 : gel(v,idl) = gadd(gel(v,idl), gmul(C, gel(w,i)));
3992 : }
3993 1309 : return v;
3994 : }
3995 :
3996 : static GEN
3997 12159 : mkmf(GEN x1, GEN x2, GEN x3, GEN x4, GEN x5)
3998 : {
3999 12159 : GEN MF = obj_init(5, MF_SPLITN);
4000 12159 : gel(MF,1) = x1;
4001 12159 : gel(MF,2) = x2;
4002 12159 : gel(MF,3) = x3;
4003 12159 : gel(MF,4) = x4;
4004 12159 : gel(MF,5) = x5; return MF;
4005 : }
4006 :
4007 : /* return an integer b such that p | b => T_p^k Tr^new = 0, for all k > 0 */
4008 : static long
4009 7483 : get_badj(long N, long FC)
4010 : {
4011 7483 : GEN fa = myfactoru(N), P = gel(fa,1), E = gel(fa,2);
4012 7483 : long i, b = 1, l = lg(P);
4013 19929 : for (i = 1; i < l; i++)
4014 12446 : if (E[i] > 1 && u_lval(FC, P[i]) < E[i]) b *= P[i];
4015 7483 : return b;
4016 : }
4017 : /* in place, assume perm strictly increasing */
4018 : static void
4019 1330 : vecpermute_inplace(GEN v, GEN perm)
4020 : {
4021 1330 : long i, l = lg(perm);
4022 11522 : for (i = 1; i < l; i++) gel(v,i) = gel(v,perm[i]);
4023 1330 : }
4024 :
4025 : /* Find basis of newspace using closures; assume k >= 2 and !badchar.
4026 : * Return NULL if space is empty, else
4027 : * [mf1, list of closures T(j)traceform, list of corresponding j, matrix] */
4028 : static GEN
4029 15330 : mfnewinit(long N, long k, GEN CHI, cachenew_t *cache, long init)
4030 : {
4031 : GEN S, vj, M, CHIP, mf1, listj, P, tf;
4032 : long j, ct, ctlj, dim, jin, SB, sb, two, ord, FC, badj;
4033 :
4034 15330 : dim = mfnewdim(N, k, CHI);
4035 15330 : if (!dim && !init) return NULL;
4036 7483 : sb = mfsturmNk(N, k);
4037 7483 : CHIP = mfchartoprimitive(CHI, &FC);
4038 : /* remove newtrace data from S to save space in output: negligible slowdown */
4039 7483 : tf = tag(t_MF_NEWTRACE, mkNK(N,k,CHIP), CHIP);
4040 7483 : badj = get_badj(N, FC);
4041 : /* try sbsmall first: Sturm bound not sharp for new space */
4042 7483 : SB = ceilA1(N, k);
4043 7483 : listj = cgetg(2*sb + 3, t_VECSMALL);
4044 369054 : for (j = ctlj = 1; ctlj < 2*sb + 3; j++)
4045 361571 : if (ugcd(j, badj) == 1) listj[ctlj++] = j;
4046 7483 : if (init)
4047 : {
4048 4060 : init_cachenew(cache, (SB+1)*listj[dim+1], N, tf);
4049 4060 : if (init == -1 || !dim) return NULL; /* old space or dim = 0 */
4050 : }
4051 : else
4052 3423 : reset_cachenew(cache, N, tf);
4053 : /* cache.DATA is not NULL */
4054 7028 : ord = mfcharorder(CHIP);
4055 7028 : P = ord <= 2? NULL: mfcharpol(CHIP);
4056 7028 : vj = cgetg(dim+1, t_VECSMALL);
4057 7028 : M = cgetg(dim+1, t_MAT);
4058 7035 : for (two = 1, ct = 0, jin = 1; two <= 2; two++)
4059 : {
4060 7035 : long a, jlim = jin + sb;
4061 21819 : for (a = jin; a <= jlim; a++)
4062 : {
4063 : GEN z, vecz;
4064 21812 : ct++; vj[ct] = listj[a];
4065 21812 : gel(M, ct) = heckenewtrace(0, SB, 1, N, N, k, vj[ct], cache);
4066 21812 : if (ct < dim) continue;
4067 :
4068 7693 : z = QabM_indexrank(M, P, ord);
4069 7693 : vecz = gel(z, 2); ct = lg(vecz) - 1;
4070 7693 : if (ct == dim) { M = mkvec3(z, gen_0, M); break; } /*maximal rank, done*/
4071 665 : vecpermute_inplace(M, vecz);
4072 665 : vecpermute_inplace(vj, vecz);
4073 : }
4074 7035 : if (a <= jlim) break;
4075 : /* sbsmall was not sufficient, use Sturm bound: must extend M */
4076 70 : for (j = 1; j <= ct; j++)
4077 : {
4078 63 : GEN t = heckenewtrace(SB + 1, sb, 1, N, N, k, vj[j], cache);
4079 63 : gel(M,j) = shallowconcat(gel(M, j), t);
4080 : }
4081 7 : jin = jlim + 1; SB = sb;
4082 : }
4083 7028 : S = cgetg(dim + 1, t_VEC);
4084 28133 : for (j = 1; j <= dim; j++) gel(S, j) = mfhecke_i(vj[j], N, tf);
4085 7028 : dbg_cachenew(cache);
4086 7028 : mf1 = mkvec4(utoipos(N), utoipos(k), CHI, utoi(mf_NEW));
4087 7028 : return mkmf(mf1, cgetg(1,t_VEC), S, vj, M);
4088 : }
4089 : /* k > 1 integral, mf space is mf_CUSP or mf_FULL */
4090 : static GEN
4091 42 : mfinittonew(GEN mf)
4092 : {
4093 42 : GEN CHI = MF_get_CHI(mf), S = MF_get_S(mf), vMjd = MFcusp_get_vMjd(mf);
4094 42 : GEN M = MF_get_M(mf), vj, mf1;
4095 42 : long i, j, l, l0 = lg(S), N0 = MF_get_N(mf);
4096 203 : for (i = l0-1; i > 0; i--)
4097 : {
4098 189 : long N = gel(vMjd,i)[1];
4099 189 : if (N != N0) break;
4100 : }
4101 42 : if (i == l0-1) return NULL;
4102 35 : S = vecslice(S, i+1, l0-1); /* forms of conductor N0 */
4103 35 : l = lg(S); vj = cgetg(l, t_VECSMALL);
4104 196 : for (j = 1; j < l; j++) vj[j] = gel(vMjd,j+i)[2];
4105 35 : M = vecslice(M, lg(M)-lg(S)+1, lg(M)-1); /* their coefficients */
4106 35 : M = mfcleanCHI(M, CHI, 0);
4107 35 : mf1 = mkvec4(utoipos(N0), MF_get_gk(mf), CHI, utoi(mf_NEW));
4108 35 : return mkmf(mf1, cgetg(1,t_VEC), S, vj, M);
4109 : }
4110 :
4111 : /* Bd(f)[m0..m], v = f[ceil(m0/d)..floor(m/d)], m0d = ceil(m0/d) */
4112 : static GEN
4113 81662 : RgC_Bd_expand(long m0, long m, GEN v, long d, long m0d)
4114 : {
4115 : long i, j;
4116 : GEN w;
4117 81662 : if (d == 1) return v;
4118 23492 : w = zerocol(m-m0+1);
4119 23492 : if (!m0) { i = 1; j = d; } else { i = 0; j = m0d*d; }
4120 467859 : for (; j <= m; i++, j += d) gel(w,j-m0+1) = gel(v,i+1);
4121 23492 : return w;
4122 : }
4123 : /* S a nonempty vector of t_MF_BD(t_MF_HECKE(t_MF_NEWTRACE)); M the matrix
4124 : * of their coefficients r*0, r*1, ..., r*m0 (~ mfvectomat) or NULL (empty),
4125 : * extend it to coeffs up to m > m0. The forms B_d(T_j(tf_N))in S should be
4126 : * sorted by level N, then j, then increasing d. No reordering here. */
4127 : static GEN
4128 8414 : bhnmat_extend(GEN M, long m, long r, GEN S, cachenew_t *cache)
4129 : {
4130 8414 : long i, mr, m0, m0r, Nold = 0, jold = 0, l = lg(S);
4131 8414 : GEN MAT = cgetg(l, t_MAT), v = NULL;
4132 8414 : if (M) { m0 = nbrows(M); m0r = m0 * r; } else m0 = m0r = 0;
4133 8414 : mr = m*r;
4134 90076 : for (i = 1; i < l; i++)
4135 : {
4136 : long d, j, md, N;
4137 81662 : GEN c, f = bhn_parse(gel(S,i), &d,&j); /* t_MF_NEWTRACE */
4138 81662 : N = mf_get_N(f);
4139 81662 : md = ceildivuu(m0r,d);
4140 81662 : if (N != Nold) { reset_cachenew(cache, N, f); Nold = N; jold = 0; }
4141 81662 : if (!cache->DATA) { gel(MAT,i) = zerocol(m+1); continue; }
4142 81662 : if (j != jold || md)
4143 65604 : { v = heckenewtrace(md, mr/d, 1, N, N, mf_get_k(f), j,cache); jold=j; }
4144 81662 : c = RgC_Bd_expand(m0r, mr, v, d, md);
4145 81662 : if (r > 1) c = c_deflate(m-m0, r, c);
4146 81662 : if (M) c = shallowconcat(gel(M,i), c);
4147 81662 : gel(MAT,i) = c;
4148 : }
4149 8414 : return MAT;
4150 : }
4151 :
4152 : /* k > 1 */
4153 : static GEN
4154 3157 : mfinitcusp(long N, long k, GEN CHI, cachenew_t *cache, long space)
4155 : {
4156 : long L, l, lDN1, FC, N1, d1, i, init;
4157 3157 : GEN vS, vMjd, DN1, vmf, CHIP = mfchartoprimitive(CHI, &FC);
4158 :
4159 3157 : d1 = (space == mf_OLD)? mfolddim_i(N, k, CHIP, NULL): mfcuspdim(N, k, CHIP);
4160 3157 : if (!d1) return NULL;
4161 2856 : N1 = N/FC; DN1 = mydivisorsu(N1); lDN1 = lg(DN1);
4162 2856 : init = (space == mf_OLD)? -1: 1;
4163 2856 : vmf = cgetg(lDN1, t_VEC);
4164 16982 : for (i = lDN1 - 1, l = 1; i; i--)
4165 : { /* by decreasing level to allow cache */
4166 14126 : GEN mf = mfnewinit(FC*DN1[i], k, CHIP, cache, init);
4167 14126 : if (mf) gel(vmf, l++) = mf;
4168 14126 : init = 0;
4169 : }
4170 2856 : setlg(vmf,l); vmf = vecreverse(vmf); /* reorder by increasing level */
4171 :
4172 2856 : L = mfsturmNk(N, k)+1;
4173 2856 : vS = vectrunc_init(L);
4174 2856 : vMjd = vectrunc_init(L);
4175 9051 : for (i = 1; i < l; i++)
4176 : {
4177 6195 : GEN DNM, mf = gel(vmf,i), S = MF_get_S(mf), vj = MFnew_get_vj(mf);
4178 6195 : long a, lDNM, lS = lg(S), M = MF_get_N(mf);
4179 6195 : DNM = mydivisorsu(N / M); lDNM = lg(DNM);
4180 25228 : for (a = 1; a < lS; a++)
4181 : {
4182 19033 : GEN tf = gel(S,a);
4183 19033 : long b, j = vj[a];
4184 47327 : for (b = 1; b < lDNM; b++)
4185 : {
4186 28294 : long d = DNM[b];
4187 28294 : vectrunc_append(vS, mfbd_i(tf, d));
4188 28294 : vectrunc_append(vMjd, mkvecsmall3(M, j, d));
4189 : }
4190 : }
4191 : }
4192 2856 : return mkmf(NULL, cgetg(1, t_VEC), vS, vMjd, NULL);
4193 : }
4194 :
4195 : long
4196 4340 : mfsturm_mf(GEN mf)
4197 : {
4198 4340 : GEN Mindex = MF_get_Mindex(mf);
4199 4340 : long n = lg(Mindex)-1;
4200 4340 : return n? Mindex[n]-1: 0;
4201 : }
4202 :
4203 : long
4204 623 : mfsturm(GEN T)
4205 : {
4206 : long N, nk, dk;
4207 623 : GEN CHI, mf = checkMF_i(T);
4208 623 : if (mf) return mfsturm_mf(mf);
4209 7 : checkNK2(T, &N, &nk, &dk, &CHI, 0);
4210 7 : return dk == 1 ? mfsturmNk(N, nk) : mfsturmNk(N, (nk + 1) >> 1);
4211 : }
4212 : long
4213 7 : mfisequal(GEN F, GEN G, long lim)
4214 : {
4215 7 : pari_sp av = avma;
4216 : long b;
4217 7 : if (!checkmf_i(F)) pari_err_TYPE("mfisequal",F);
4218 7 : if (!checkmf_i(G)) pari_err_TYPE("mfisequal",G);
4219 7 : b = lim? lim: maxss(mfsturmmf(F), mfsturmmf(G));
4220 7 : return gc_long(av, gequal(mfcoefs_i(F, b, 1), mfcoefs_i(G, b, 1)));
4221 : }
4222 :
4223 : GEN
4224 35 : mffields(GEN mf)
4225 : {
4226 35 : if (checkmf_i(mf)) return gcopy(mf_get_field(mf));
4227 35 : mf = checkMF(mf); return gcopy(MF_get_fields(mf));
4228 : }
4229 :
4230 : GEN
4231 336 : mfeigenbasis(GEN mf)
4232 : {
4233 336 : pari_sp ltop = avma;
4234 : GEN F, S, v, vP;
4235 : long i, l, k, dS;
4236 :
4237 336 : mf = checkMF(mf);
4238 336 : k = MF_get_k(mf);
4239 336 : S = MF_get_S(mf); dS = lg(S)-1;
4240 336 : if (!dS) return cgetg(1, t_VEC);
4241 329 : F = MF_get_newforms(mf);
4242 329 : vP = MF_get_fields(mf);
4243 329 : if (k == 1)
4244 : {
4245 210 : if (MF_get_space(mf) == mf_FULL)
4246 : {
4247 14 : long dE = lg(MF_get_E(mf)) - 1;
4248 14 : if (dE) F = rowslice(F, dE+1, dE+dS);
4249 : }
4250 210 : v = vecmflineardiv_linear(S, F);
4251 210 : l = lg(v);
4252 : }
4253 : else
4254 : {
4255 119 : GEN (*L)(GEN, GEN) = (MF_get_space(mf) == mf_FULL)? mflinear: mflinear_bhn;
4256 119 : l = lg(F); v = cgetg(l, t_VEC);
4257 413 : for (i = 1; i < l; i++) gel(v,i) = L(mf, gel(F,i));
4258 : }
4259 847 : for (i = 1; i < l; i++) mf_setfield(gel(v,i), gel(vP,i));
4260 329 : return gerepilecopy(ltop, v);
4261 : }
4262 :
4263 : /* Minv = [M, d, A], v a t_COL; A a Zab, d a t_INT; return (A/d) * M*v */
4264 : static GEN
4265 7077 : Minv_RgC_mul(GEN Minv, GEN v)
4266 : {
4267 7077 : GEN M = gel(Minv,1), d = gel(Minv,2), A = gel(Minv,3);
4268 7077 : v = RgM_RgC_mul(M, v);
4269 7077 : if (!equali1(A))
4270 : {
4271 1764 : if (typ(A) == t_POL && degpol(A) > 0) A = mkpolmod(A, gel(Minv,4));
4272 1764 : v = RgC_Rg_mul(v, A);
4273 : }
4274 7077 : if (!equali1(d)) v = RgC_Rg_div(v, d);
4275 7077 : return v;
4276 : }
4277 : static GEN
4278 1267 : Minv_RgM_mul(GEN Minv, GEN B)
4279 : {
4280 1267 : long j, l = lg(B);
4281 1267 : GEN M = cgetg(l, t_MAT);
4282 5887 : for (j = 1; j < l; j++) gel(M,j) = Minv_RgC_mul(Minv, gel(B,j));
4283 1267 : return M;
4284 : }
4285 : /* B * Minv; allow B = NULL for Id */
4286 : static GEN
4287 2436 : RgM_Minv_mul(GEN B, GEN Minv)
4288 : {
4289 2436 : GEN M = gel(Minv,1), d = gel(Minv,2), A = gel(Minv,3);
4290 2436 : if (B) M = RgM_mul(B, M);
4291 2436 : if (!equali1(A))
4292 : {
4293 980 : if (typ(A) == t_POL) A = mkpolmod(A, gel(Minv,4));
4294 980 : M = RgM_Rg_mul(M, A);
4295 : }
4296 2436 : if (!equali1(d)) M = RgM_Rg_div(M,d);
4297 2436 : return M;
4298 : }
4299 :
4300 : /* perm vector of strictly increasing indices, v a vector or arbitrary length;
4301 : * the last r entries of perm fall beyond v.
4302 : * Return v o perm[1..(-r)], discarding the last r entries of v */
4303 : static GEN
4304 1176 : vecpermute_partial(GEN v, GEN perm, long *r)
4305 : {
4306 1176 : long i, n = lg(v)-1, l = lg(perm);
4307 : GEN w;
4308 1176 : if (perm[l-1] <= n) { *r = 0; return vecpermute(v,perm); }
4309 63 : for (i = 1; i < l; i++)
4310 63 : if (perm[i] > n) break;
4311 21 : *r = l - i; l = i;
4312 21 : w = cgetg(l, typ(v));
4313 63 : for (i = 1; i < l; i++) gel(w,i) = gel(v,perm[i]);
4314 21 : return w;
4315 : }
4316 :
4317 : /* given form F, find coeffs of F on mfbasis(mf). If power series, not
4318 : * guaranteed correct if precision less than Sturm bound */
4319 : static GEN
4320 1197 : mftobasis_i(GEN mf, GEN F)
4321 : {
4322 : GEN v, Mindex, Minv;
4323 1197 : if (!MF_get_dim(mf)) return cgetg(1, t_COL);
4324 1197 : Mindex = MF_get_Mindex(mf);
4325 1197 : Minv = MF_get_Minv(mf);
4326 1197 : if (checkmf_i(F))
4327 : {
4328 259 : long n = Mindex[lg(Mindex)-1];
4329 259 : v = vecpermute(mfcoefs_i(F, n, 1), Mindex);
4330 259 : return Minv_RgC_mul(Minv, v);
4331 : }
4332 : else
4333 : {
4334 938 : GEN A = gel(Minv,1), d = gel(Minv,2);
4335 : long r;
4336 938 : v = F;
4337 938 : switch(typ(F))
4338 : {
4339 0 : case t_SER: v = sertocol(v);
4340 938 : case t_VEC: case t_COL: break;
4341 0 : default: pari_err_TYPE("mftobasis", F);
4342 : }
4343 938 : if (lg(v) == 1) pari_err_TYPE("mftobasis",v);
4344 938 : v = vecpermute_partial(v, Mindex, &r);
4345 938 : if (!r) return Minv_RgC_mul(Minv, v); /* single solution */
4346 : /* affine space of dimension r */
4347 21 : v = RgM_RgC_mul(vecslice(A, 1, lg(v)-1), v);
4348 21 : if (!equali1(d)) v = RgC_Rg_div(v,d);
4349 21 : return mkvec2(v, vecslice(A, lg(A)-r, lg(A)-1));
4350 : }
4351 : }
4352 :
4353 : static GEN
4354 546 : const_mat(long n, GEN x)
4355 : {
4356 546 : long j, l = n+1;
4357 546 : GEN A = cgetg(l,t_MAT);
4358 3990 : for (j = 1; j < l; j++) gel(A,j) = const_col(n, x);
4359 546 : return A;
4360 : }
4361 :
4362 : /* L is the mftobasis of a form on CUSP space. We allow mf_FULL or mf_CUSP */
4363 : static GEN
4364 273 : mftonew_i(GEN mf, GEN L, long *plevel)
4365 : {
4366 : GEN S, listMjd, CHI, res, Aclos, Acoef, D, perm;
4367 273 : long N1, LC, lD, i, l, t, level, N = MF_get_N(mf);
4368 :
4369 273 : if (MF_get_k(mf) == 1) pari_err_IMPL("mftonew in weight 1");
4370 273 : listMjd = MFcusp_get_vMjd(mf);
4371 273 : CHI = MF_get_CHI(mf); LC = mfcharconductor(CHI);
4372 273 : S = MF_get_S(mf);
4373 :
4374 273 : N1 = N/LC;
4375 273 : D = mydivisorsu(N1); lD = lg(D);
4376 273 : perm = cgetg(N1+1, t_VECSMALL);
4377 1995 : for (i = 1; i < lD; i++) perm[D[i]] = i;
4378 273 : Aclos = const_mat(lD-1, cgetg(1,t_VEC));
4379 273 : Acoef = const_mat(lD-1, cgetg(1,t_VEC));
4380 273 : l = lg(listMjd);
4381 2863 : for (i = 1; i < l; i++)
4382 : {
4383 : long M, d;
4384 : GEN v;
4385 2590 : if (gequal0(gel(L,i))) continue;
4386 266 : v = gel(listMjd, i);
4387 266 : M = perm[ v[1]/LC ];
4388 266 : d = perm[ v[3] ];
4389 266 : gcoeff(Aclos,M,d) = vec_append(gcoeff(Aclos,M,d), gel(S,i));
4390 266 : gcoeff(Acoef,M,d) = shallowconcat(gcoeff(Acoef,M,d), gel(L,i));
4391 : }
4392 273 : res = cgetg(l, t_VEC); level = 1;
4393 1995 : for (i = t = 1; i < lD; i++)
4394 : {
4395 1722 : long j, M = D[i]*LC;
4396 1722 : GEN gM = utoipos(M);
4397 15120 : for (j = 1; j < lD; j++)
4398 : {
4399 13398 : GEN f = gcoeff(Aclos,i,j), C, NK;
4400 : long d;
4401 13398 : if (lg(f) == 1) continue;
4402 238 : NK = mf_get_NK(gel(f,1));
4403 238 : d = D[j];
4404 238 : C = gcoeff(Acoef,i,j);
4405 238 : level = ulcm(level, M*d);
4406 238 : gel(res,t++) = mkvec3(gM, utoipos(d), mflinear_i(NK,f,C));
4407 : }
4408 : }
4409 273 : if (plevel) *plevel = level;
4410 273 : setlg(res, t); return res;
4411 : }
4412 : GEN
4413 35 : mftonew(GEN mf, GEN F)
4414 : {
4415 35 : pari_sp av = avma;
4416 : GEN ES;
4417 : long s;
4418 35 : mf = checkMF(mf);
4419 35 : s = MF_get_space(mf);
4420 35 : if (s != mf_FULL && s != mf_CUSP)
4421 7 : pari_err_TYPE("mftonew [not a full or cuspidal space]", mf);
4422 28 : ES = mftobasisES(mf,F);
4423 21 : if (!gequal0(gel(ES,1)))
4424 0 : pari_err_TYPE("mftonew [not a cuspidal form]", F);
4425 21 : F = gel(ES,2);
4426 21 : return gerepilecopy(av, mftonew_i(mf,F, NULL));
4427 : }
4428 :
4429 : static GEN mfeisenstein_i(long k, GEN CHI1, GEN CHI2);
4430 :
4431 : /* mfinit(F * Theta) */
4432 : static GEN
4433 98 : mf2init(GEN mf)
4434 : {
4435 98 : GEN CHI = MF_get_CHI(mf), gk = gadd(MF_get_gk(mf), ghalf);
4436 98 : long N = MF_get_N(mf);
4437 98 : return mfinit_Nkchi(N, itou(gk), mfchiadjust(CHI, gk, N), mf_FULL, 0);
4438 : }
4439 :
4440 : static long
4441 623 : mfvec_first_cusp(GEN v)
4442 : {
4443 623 : long i, l = lg(v);
4444 1519 : for (i = 1; i < l; i++)
4445 : {
4446 1414 : GEN F = gel(v,i);
4447 1414 : long t = mf_get_type(F);
4448 1414 : if (t == t_MF_BD) { F = gel(F,2); t = mf_get_type(F); }
4449 1414 : if (t == t_MF_HECKE) { F = gel(F,3); t = mf_get_type(F); }
4450 1414 : if (t == t_MF_NEWTRACE) break;
4451 : }
4452 623 : return i;
4453 : }
4454 : /* vF a vector of mf F of type DIV(LINEAR(BAS,L), f) in (lcm) level N,
4455 : * F[2]=LINEAR(BAS,L), F[2][2]=BAS=fixed basis (Eisenstein or bhn type),
4456 : * F[2][3]=L, F[3]=f; mfvectomat(vF, n) */
4457 : static GEN
4458 630 : mflineardivtomat(long N, GEN vF, long n)
4459 : {
4460 630 : GEN F, M, f, fc, ME, dB, B, a0, V = NULL;
4461 630 : long lM, lF = lg(vF), j;
4462 :
4463 630 : if (lF == 1) return cgetg(1,t_MAT);
4464 623 : F = gel(vF,1);
4465 623 : if (lg(F) == 5)
4466 : { /* chicompat */
4467 273 : V = gmael(F,4,4);
4468 273 : if (typ(V) == t_INT) V = NULL;
4469 : }
4470 623 : M = gmael(F,2,2); /* BAS */
4471 623 : lM = lg(M);
4472 623 : j = mfvec_first_cusp(M);
4473 623 : if (j == 1) ME = NULL;
4474 : else
4475 : { /* BAS starts by Eisenstein */
4476 161 : ME = mfvectomat(vecslice(M,1,j-1), n, 1);
4477 161 : M = vecslice(M, j,lM-1);
4478 : }
4479 623 : M = bhnmat_extend_nocache(NULL, N, n, 1, M);
4480 623 : if (ME) M = shallowconcat(ME,M);
4481 : /* M = mfcoefs of BAS */
4482 623 : B = cgetg(lF, t_MAT);
4483 623 : dB= cgetg(lF, t_VEC);
4484 2947 : for (j = 1; j < lF; j++)
4485 : {
4486 2324 : GEN g = gel(vF, j); /* t_MF_DIV */
4487 2324 : gel(B,j) = RgM_RgC_mul(M, gmael(g,2,3));
4488 2324 : gel(dB,j)= gmael(g,2,4);
4489 : }
4490 623 : f = mfcoefsser(gel(F,3),n);
4491 623 : a0 = polcoef_i(f, 0, -1);
4492 623 : if (gequal0(a0) || gequal1(a0))
4493 322 : a0 = NULL;
4494 : else
4495 301 : f = gdiv(ser_unscale(f, a0), a0);
4496 623 : fc = ginv(f);
4497 2947 : for (j = 1; j < lF; j++)
4498 : {
4499 2324 : pari_sp av = avma;
4500 2324 : GEN LISer = RgV_to_ser_full(gel(B,j)), f;
4501 2324 : if (a0) LISer = gdiv(ser_unscale(LISer, a0), a0);
4502 2324 : f = gmul(LISer, fc);
4503 2324 : if (a0) f = ser_unscale(f, ginv(a0));
4504 2324 : f = sertocol(f); setlg(f, n+2);
4505 2324 : if (!gequal1(gel(dB,j))) f = RgC_Rg_div(f, gel(dB,j));
4506 2324 : gel(B,j) = gerepileupto(av,f);
4507 : }
4508 623 : if (V) B = gmodulo(QabM_tracerel(V, 0, B), gel(V,1));
4509 623 : return B;
4510 : }
4511 :
4512 : static GEN
4513 350 : mfheckemat_mfcoefs(GEN mf, GEN B, GEN DATA)
4514 : {
4515 350 : GEN Mindex = MF_get_Mindex(mf), Minv = MF_get_Minv(mf);
4516 350 : long j, l = lg(B), sb = mfsturm_mf(mf);
4517 350 : GEN b = MF_get_basis(mf), Q = cgetg(l, t_VEC);
4518 1827 : for (j = 1; j < l; j++)
4519 : {
4520 1477 : GEN v = hecke_i(sb, 1, gel(B,j), gel(b,j), DATA); /* Tn b[j] */
4521 1477 : settyp(v,t_COL); gel(Q,j) = vecpermute(v, Mindex);
4522 : }
4523 350 : return Minv_RgM_mul(Minv,Q);
4524 : }
4525 : /* T_p^2, p prime, 1/2-integral weight; B = mfcoefs(mf,sb*p^2,1) or (mf,sb,p^2)
4526 : * if p|N */
4527 : static GEN
4528 7 : mfheckemat_mfcoefs_p2(GEN mf, long p, GEN B)
4529 : {
4530 7 : pari_sp av = avma;
4531 7 : GEN DATA = heckef2_data(MF_get_N(mf), p*p);
4532 7 : return gerepileupto(av, mfheckemat_mfcoefs(mf, B, DATA));
4533 : }
4534 : /* convert Mindex from row-index to mfcoef indexation: a(n) is stored in
4535 : * mfcoefs()[n+1], so subtract 1 from all indices */
4536 : static GEN
4537 49 : Mindex_as_coef(GEN mf)
4538 : {
4539 49 : GEN v, Mindex = MF_get_Mindex(mf);
4540 49 : long i, l = lg(Mindex);
4541 49 : v = cgetg(l, t_VECSMALL);
4542 210 : for (i = 1; i < l; i++) v[i] = Mindex[i]-1;
4543 49 : return v;
4544 : }
4545 : /* T_p, p prime; B = mfcoefs(mf,sb*p,1) or (mf,sb,p) if p|N; integral weight */
4546 : static GEN
4547 35 : mfheckemat_mfcoefs_p(GEN mf, long p, GEN B)
4548 : {
4549 35 : pari_sp av = avma;
4550 35 : GEN vm, Q, C, Minv = MF_get_Minv(mf);
4551 35 : long lm, k, i, j, l = lg(B), N = MF_get_N(mf);
4552 :
4553 35 : if (N % p == 0) return Minv_RgM_mul(Minv, rowpermute(B, MF_get_Mindex(mf)));
4554 21 : k = MF_get_k(mf);
4555 21 : C = gmul(mfchareval(MF_get_CHI(mf), p), powuu(p, k-1));
4556 21 : vm = Mindex_as_coef(mf); lm = lg(vm);
4557 21 : Q = cgetg(l, t_MAT);
4558 147 : for (j = 1; j < l; j++) gel(Q,j) = cgetg(lm, t_COL);
4559 147 : for (i = 1; i < lm; i++)
4560 : {
4561 126 : long m = vm[i], mp = m*p;
4562 126 : GEN Cm = (m % p) == 0? C : NULL;
4563 1260 : for (j = 1; j < l; j++)
4564 : {
4565 1134 : GEN S = gel(B,j), s = gel(S, mp + 1);
4566 1134 : if (Cm) s = gadd(s, gmul(C, gel(S, m/p + 1)));
4567 1134 : gcoeff(Q, i, j) = s;
4568 : }
4569 : }
4570 21 : return gerepileupto(av, Minv_RgM_mul(Minv,Q));
4571 : }
4572 : /* Matrix of T(p), p prime, dim(mf) > 0 and integral weight */
4573 : static GEN
4574 343 : mfheckemat_p(GEN mf, long p)
4575 : {
4576 343 : pari_sp av = avma;
4577 343 : long N = MF_get_N(mf), sb = mfsturm_mf(mf);
4578 343 : GEN B = (N % p)? mfcoefs_mf(mf, sb * p, 1): mfcoefs_mf(mf, sb, p);
4579 343 : return gerepileupto(av, mfheckemat_mfcoefs(mf, B, hecke_data(N,p)));
4580 : }
4581 :
4582 : /* mf_NEW != (0), weight > 1, p prime. Use
4583 : * T(p) T(j) = T(j*p) + p^{k-1} \chi(p) 1_{p | j, p \nmid N} T(j/p) */
4584 : static GEN
4585 882 : mfnewmathecke_p(GEN mf, long p)
4586 : {
4587 882 : pari_sp av = avma;
4588 882 : GEN tf, vj = MFnew_get_vj(mf), CHI = MF_get_CHI(mf);
4589 882 : GEN Mindex = MF_get_Mindex(mf), Minv = MF_get_Minv(mf);
4590 882 : long N = MF_get_N(mf), k = MF_get_k(mf);
4591 882 : long i, j, lvj = lg(vj), lim = vj[lvj-1] * p;
4592 882 : GEN M, perm, V, need = zero_zv(lim);
4593 882 : GEN C = (N % p)? gmul(mfchareval(CHI,p), powuu(p,k-1)): NULL;
4594 882 : tf = mftraceform_new(N, k, CHI);
4595 3801 : for (i = 1; i < lvj; i++)
4596 : {
4597 2919 : j = vj[i]; need[j*p] = 1;
4598 2919 : if (N % p && j % p == 0) need[j/p] = 1;
4599 : }
4600 882 : perm = zero_zv(lim);
4601 882 : V = cgetg(lim+1, t_VEC);
4602 12243 : for (i = j = 1; i <= lim; i++)
4603 11361 : if (need[i]) { gel(V,j) = mfhecke_i(i, N, tf); perm[i] = j; j++; }
4604 882 : setlg(V, j);
4605 882 : V = bhnmat_extend_nocache(NULL, N, mfsturm_mf(mf), 1, V);
4606 882 : V = rowpermute(V, Mindex); /* V[perm[i]] = coeffs(T_i newtrace) */
4607 882 : M = cgetg(lvj, t_MAT);
4608 3801 : for (i = 1; i < lvj; i++)
4609 : {
4610 : GEN t;
4611 2919 : j = vj[i]; t = gel(V, perm[j*p]);
4612 2919 : if (C && j % p == 0) t = RgC_add(t, RgC_Rg_mul(gel(V, perm[j/p]),C));
4613 2919 : gel(M,i) = t;
4614 : }
4615 882 : return gerepileupto(av, Minv_RgM_mul(Minv, M));
4616 : }
4617 :
4618 : GEN
4619 77 : mfheckemat(GEN mf, GEN vn)
4620 : {
4621 77 : pari_sp av = avma;
4622 77 : long lv, lvP, i, N, dim, nk, dk, p, sb, flint = (typ(vn)==t_INT);
4623 : GEN CHI, res, vT, FA, B, vP;
4624 :
4625 77 : mf = checkMF(mf);
4626 77 : if (typ(vn) != t_VECSMALL) vn = gtovecsmall(vn);
4627 77 : N = MF_get_N(mf); CHI = MF_get_CHI(mf); Qtoss(MF_get_gk(mf), &nk, &dk);
4628 77 : dim = MF_get_dim(mf);
4629 77 : lv = lg(vn);
4630 77 : res = cgetg(lv, t_VEC);
4631 77 : FA = cgetg(lv, t_VEC);
4632 77 : vP = cgetg(lv, t_VEC);
4633 77 : vT = const_vec(vecsmall_max(vn), NULL);
4634 182 : for (i = 1; i < lv; i++)
4635 : {
4636 105 : ulong n = (ulong)labs(vn[i]);
4637 : GEN fa;
4638 105 : if (!n) pari_err_TYPE("mfheckemat", vn);
4639 105 : if (dk == 1 || uissquareall(n, &n)) fa = myfactoru(n);
4640 0 : else { n = 0; fa = myfactoru(1); } /* dummy: T_{vn[i]} = 0 */
4641 105 : vn[i] = n;
4642 105 : gel(FA,i) = fa;
4643 105 : gel(vP,i) = gel(fa,1);
4644 : }
4645 77 : vP = shallowconcat1(vP); vecsmall_sort(vP);
4646 77 : vP = vecsmall_uniq_sorted(vP); /* all primes occurring in vn */
4647 77 : lvP = lg(vP); if (lvP == 1) goto END;
4648 56 : p = vP[lvP-1];
4649 56 : sb = mfsturm_mf(mf);
4650 56 : if (dk == 1 && nk != 1 && MF_get_space(mf) == mf_NEW)
4651 21 : B = NULL; /* special purpose mfnewmathecke_p is faster */
4652 35 : else if (lvP == 2 && N % p == 0)
4653 21 : B = mfcoefs_mf(mf, sb, dk==2? p*p: p); /* single prime | N, can optimize */
4654 : else
4655 14 : B = mfcoefs_mf(mf, sb * (dk==2? p*p: p), 1); /* general initialization */
4656 126 : for (i = 1; i < lvP; i++)
4657 : {
4658 70 : long j, l, q, e = 1;
4659 : GEN C, Tp, u1, u0;
4660 70 : p = vP[i];
4661 189 : for (j = 1; j < lv; j++) e = maxss(e, z_lval(vn[j], p));
4662 70 : if (!B)
4663 28 : Tp = mfnewmathecke_p(mf, p);
4664 42 : else if (dk == 2)
4665 7 : Tp = mfheckemat_mfcoefs_p2(mf,p, (lvP==2||N%p)? B: matdeflate(sb,p*p,B));
4666 : else
4667 35 : Tp = mfheckemat_mfcoefs_p(mf, p, (lvP==2||N%p)? B: matdeflate(sb,p,B));
4668 70 : gel(vT, p) = Tp;
4669 70 : if (e == 1) continue;
4670 14 : u0 = gen_1;
4671 14 : if (dk == 2)
4672 : {
4673 0 : C = N % p? gmul(mfchareval(CHI,p*p), powuu(p, nk-2)): NULL;
4674 0 : if (e == 2) u0 = uutoQ(p+1,p); /* special case T_{p^4} */
4675 : }
4676 : else
4677 14 : C = N % p? gmul(mfchareval(CHI,p), powuu(p, nk-1)): NULL;
4678 28 : for (u1=Tp, q=p, l=2; l <= e; l++)
4679 : { /* u0 = T_{p^{l-2}}, u1 = T_{p^{l-1}} for l > 2 */
4680 14 : GEN v = gmul(Tp, u1);
4681 14 : if (C) v = gsub(v, gmul(C, u0));
4682 : /* q = p^l, vT[q] = T_q for k integer else T_{q^2} */
4683 14 : q *= p; u0 = u1; gel(vT, q) = u1 = v;
4684 : }
4685 : }
4686 56 : END:
4687 : /* vT[p^e] = T_{p^e} for all p^e occurring below */
4688 182 : for (i = 1; i < lv; i++)
4689 : {
4690 105 : long n = vn[i], j, lP;
4691 : GEN fa, P, E, M;
4692 105 : if (n == 0) { gel(res,i) = zeromat(dim,dim); continue; }
4693 105 : if (n == 1) { gel(res,i) = matid(dim); continue; }
4694 77 : fa = gel(FA,i);
4695 77 : P = gel(fa,1); lP = lg(P);
4696 77 : E = gel(fa,2); M = gel(vT, upowuu(P[1], E[1]));
4697 84 : for (j = 2; j < lP; j++) M = RgM_mul(M, gel(vT, upowuu(P[j], E[j])));
4698 77 : gel(res,i) = M;
4699 : }
4700 77 : if (flint) res = gel(res,1);
4701 77 : return gerepilecopy(av, res);
4702 : }
4703 :
4704 : /* f = \sum_i v[i] T_listj[i] (Trace Form) attached to v; replace by f/a_1(f) */
4705 : static GEN
4706 1463 : mf_normalize(GEN mf, GEN v)
4707 : {
4708 1463 : GEN c, dc = NULL, M = MF_get_M(mf), Mindex = MF_get_Mindex(mf);
4709 1463 : v = Q_primpart(v);
4710 1463 : c = RgMrow_RgC_mul(M, v, 2); /* a_1(f) */
4711 1463 : if (gequal1(c)) return v;
4712 882 : if (typ(c) == t_POL) c = gmodulo(c, mfcharpol(MF_get_CHI(mf)));
4713 882 : if (typ(c) == t_POLMOD && varn(gel(c,1)) == 1 && degpol(gel(c,1)) >= 40
4714 7 : && Mindex[1] == 2
4715 7 : && mfcharorder(MF_get_CHI(mf)) <= 2)
4716 7 : { /* normalize using expansion at infinity (small coefficients) */
4717 7 : GEN w, P = gel(c,1), a1 = gel(c,2);
4718 7 : long i, l = lg(Mindex);
4719 7 : w = cgetg(l, t_COL);
4720 7 : gel(w,1) = gen_1;
4721 280 : for (i = 2; i < l; i++)
4722 : {
4723 273 : c = liftpol_shallow(RgMrow_RgC_mul(M, v, Mindex[i]));
4724 273 : gel(w,i) = QXQ_div(c, a1, P);
4725 : }
4726 : /* w = expansion at oo of normalized form */
4727 7 : v = Minv_RgC_mul(MF_get_Minv(mf), Q_remove_denom(w, &dc));
4728 7 : v = gmodulo(v, P); /* back to mfbasis coefficients */
4729 : }
4730 : else
4731 : {
4732 875 : c = ginv(c);
4733 875 : if (typ(c) == t_POLMOD) c = Q_remove_denom(c, &dc);
4734 875 : v = RgC_Rg_mul(v, c);
4735 : }
4736 882 : if (dc) v = RgC_Rg_div(v, dc);
4737 882 : return v;
4738 : }
4739 : static void
4740 427 : pol_red(GEN NF, GEN *pP, GEN *pa, long flag)
4741 : {
4742 427 : GEN dP, a, P = *pP;
4743 427 : long d = degpol(P);
4744 :
4745 427 : *pa = a = pol_x(varn(P));
4746 427 : if (d * (NF ? nf_get_degree(NF): 1) > 30) return;
4747 :
4748 420 : dP = RgX_disc(P);
4749 420 : if (typ(dP) != t_INT)
4750 98 : { dP = gnorm(dP); if (typ(dP) != t_INT) pari_err_BUG("mfnewsplit"); }
4751 420 : if (d == 2 || expi(dP) < 62)
4752 : {
4753 385 : if (expi(dP) < 31)
4754 385 : P = NF? rnfpolredabs(NF, P,flag): polredabs0(P,flag);
4755 : else
4756 0 : P = NF? rnfpolredbest(NF,P,flag): polredbest(P,flag);
4757 385 : if (flag)
4758 : {
4759 357 : a = gel(P,2); if (typ(a) == t_POLMOD) a = gel(a,2);
4760 357 : P = gel(P,1);
4761 : }
4762 : }
4763 420 : *pP = P;
4764 420 : *pa = a;
4765 : }
4766 :
4767 : /* Diagonalize and normalize. See mfsplit for meaning of flag. */
4768 : static GEN
4769 1057 : mfspclean(GEN mf, GEN mf0, GEN NF, long ord, GEN simplesp, long flag)
4770 : {
4771 1057 : const long vz = 1;
4772 1057 : long i, l = lg(simplesp), dim = MF_get_dim(mf);
4773 1057 : GEN res = cgetg(l, t_MAT), pols = cgetg(l, t_VEC);
4774 1057 : GEN zeros = (mf == mf0)? NULL: zerocol(dim - MF_get_dim(mf0));
4775 2548 : for (i = 1; i < l; i++)
4776 : {
4777 1491 : GEN ATP = gel(simplesp, i), A = gel(ATP,1), P = gel(ATP,3);
4778 1491 : long d = degpol(P);
4779 1491 : GEN a, v = (flag && d > flag)? NULL: gel(A,1);
4780 1491 : if (d == 1) P = pol_x(vz);
4781 : else
4782 : {
4783 427 : pol_red(NF, &P, &a, !!v);
4784 427 : if (v)
4785 : { /* Mod(a,P) root of charpoly(T), K*gpowers(a) = eigenvector of T */
4786 399 : GEN K, den, M = cgetg(d+1, t_MAT), T = gel(ATP,2);
4787 : long j;
4788 399 : T = shallowtrans(T);
4789 399 : gel(M,1) = vec_ei(d,1); /* basis of cyclic vectors */
4790 1302 : for (j = 2; j <= d; j++) gel(M,j) = RgM_RgC_mul(T, gel(M,j-1));
4791 399 : M = Q_primpart(M);
4792 133 : K = NF? ZabM_inv(liftpol_shallow(M), nf_get_pol(NF), ord, &den)
4793 399 : : ZM_inv(M,&den);
4794 399 : K = shallowtrans(K);
4795 399 : v = gequalX(a)? pol_x_powers(d, vz): RgXQ_powers(a, d-1, P);
4796 399 : v = gmodulo(RgM_RgC_mul(A, RgM_RgC_mul(K,v)), P);
4797 : }
4798 : }
4799 1491 : if (v)
4800 : {
4801 1463 : v = mf_normalize(mf0, v); if (zeros) v = shallowconcat(zeros,v);
4802 1463 : gel(res,i) = v; if (flag) setlg(res,i+1);
4803 : }
4804 : else
4805 28 : gel(res,i) = zerocol(dim);
4806 1491 : gel(pols,i) = P;
4807 : }
4808 1057 : return mkvec2(res, pols);
4809 : }
4810 :
4811 : /* return v = v_{X-r}(P), and set Z = P / (X-r)^v */
4812 : static long
4813 70 : RgX_valrem_root(GEN P, GEN r, GEN *Z)
4814 : {
4815 : long v;
4816 140 : for (v = 0; degpol(P); v++)
4817 : {
4818 140 : GEN t, Q = RgX_div_by_X_x(P, r, &t);
4819 140 : if (!gequal0(t)) break;
4820 70 : P = Q;
4821 : }
4822 70 : *Z = P; return v;
4823 : }
4824 : static GEN
4825 1484 : mynffactor(GEN NF, GEN P, long dimlim)
4826 : {
4827 : long i, l, v;
4828 : GEN R, E;
4829 1484 : if (dimlim != 1)
4830 : {
4831 924 : R = NF? nffactor(NF, P): QX_factor(P);
4832 924 : if (!dimlim) return R;
4833 21 : E = gel(R,2);
4834 21 : R = gel(R,1); l = lg(R);
4835 98 : for (i = 1; i < l; i++)
4836 91 : if (degpol(gel(R,i)) > dimlim) break;
4837 21 : if (i == 1) return NULL;
4838 21 : setlg(E,i);
4839 21 : setlg(R,i); return mkmat2(R, E);
4840 : }
4841 : /* dimlim = 1 */
4842 560 : R = nfroots(NF, P); l = lg(R);
4843 560 : if (l == 1) return NULL;
4844 497 : v = varn(P);
4845 497 : settyp(R, t_COL);
4846 497 : if (degpol(P) == l-1)
4847 441 : E = const_col(l-1, gen_1);
4848 : else
4849 : {
4850 56 : E = cgetg(l, t_COL);
4851 126 : for (i = 1; i < l; i++) gel(E,i) = utoi(RgX_valrem_root(P, gel(R,i), &P));
4852 : }
4853 497 : R = deg1_from_roots(R, v);
4854 497 : return mkmat2(R, E);
4855 : }
4856 :
4857 : /* Let K be a number field attached to NF (Q if NF = NULL). A K-vector
4858 : * space of dimension d > 0 is given by a t_MAT A (n x d, full column rank)
4859 : * giving a K-basis, X a section (d x n: left pseudo-inverse of A). Return a
4860 : * pair (T, fa), where T is an element of the Hecke algebra (a sum of Tp taken
4861 : * from vector vTp) acting on A (a d x d t_MAT) and fa is the factorization of
4862 : * its characteristic polynomial, limited to factors of degree <= dimlim if
4863 : * dimlim != 0 (return NULL if there are no factors of degree <= dimlim) */
4864 : static GEN
4865 1309 : findbestsplit(GEN NF, GEN vTp, GEN A, GEN X, long dimlim, long vz)
4866 : {
4867 1309 : GEN T = NULL, Tkeep = NULL, fakeep = NULL;
4868 1309 : long lmax = 0, i, lT = lg(vTp);
4869 1729 : for (i = 1; i < lT; i++)
4870 : {
4871 1729 : GEN D, P, E, fa, TpA = gel(vTp,i);
4872 : long l;
4873 2730 : if (typ(TpA) == t_INT) break;
4874 1484 : if (lg(TpA) > lg(A)) TpA = RgM_mul(X, RgM_mul(TpA, A)); /* Tp | A */
4875 1484 : T = T ? RgM_add(T, TpA) : TpA;
4876 1484 : if (!NF) { P = QM_charpoly_ZX(T); setvarn(P, vz); }
4877 : else
4878 : {
4879 273 : P = charpoly(Q_remove_denom(T, &D), vz);
4880 273 : if (D) P = gdiv(RgX_unscale(P, D), powiu(D, degpol(P)));
4881 : }
4882 1484 : fa = mynffactor(NF, P, dimlim);
4883 1484 : if (!fa) return NULL;
4884 1421 : E = gel(fa, 2);
4885 : /* characteristic polynomial is separable ? */
4886 1421 : if (isint1(vecmax(E))) { Tkeep = T; fakeep = fa; break; }
4887 420 : l = lg(E);
4888 : /* characteristic polynomial has more factors than before ? */
4889 420 : if (l > lmax) { lmax = l; Tkeep = T; fakeep = fa; }
4890 : }
4891 1246 : return mkvec2(Tkeep, fakeep);
4892 : }
4893 :
4894 : static GEN
4895 210 : nfcontent(GEN nf, GEN v)
4896 : {
4897 210 : long i, l = lg(v);
4898 210 : GEN c = gel(v,1);
4899 1134 : for (i = 2; i < l; i++) c = idealadd(nf, c, gel(v,i));
4900 210 : if (typ(c) == t_MAT && gequal1(gcoeff(c,1,1))) c = gen_1;
4901 210 : return c;
4902 : }
4903 : static GEN
4904 329 : nf_primpart(GEN nf, GEN B)
4905 : {
4906 329 : switch(typ(B))
4907 : {
4908 210 : case t_COL:
4909 : {
4910 210 : GEN A = matalgtobasis(nf, B), c = nfcontent(nf, A);
4911 210 : if (typ(c) == t_INT) return B;
4912 21 : c = idealred_elt(nf,c);
4913 21 : A = Q_primpart( nfC_nf_mul(nf, A, Q_primpart(nfinv(nf,c))) );
4914 21 : A = liftpol_shallow( matbasistoalg(nf, A) );
4915 21 : if (gexpo(A) > gexpo(B)) A = B;
4916 21 : return A;
4917 : }
4918 119 : case t_MAT:
4919 : {
4920 : long i, l;
4921 119 : GEN A = cgetg_copy(B, &l);
4922 329 : for (i = 1; i < l; i++) gel(A,i) = nf_primpart(nf, gel(B,i));
4923 119 : return A;
4924 : }
4925 0 : default:
4926 0 : pari_err_TYPE("nf_primpart", B);
4927 : return NULL; /*LCOV_EXCL_LINE*/
4928 : }
4929 : }
4930 :
4931 : /* rotate entries of v to accomodate new entry 'x' (push out oldest entry) */
4932 : static void
4933 1197 : vecpush(GEN v, GEN x)
4934 : {
4935 : long i;
4936 5985 : for (i = lg(v)-1; i > 1; i--) gel(v,i) = gel(v,i-1);
4937 1197 : gel(v,1) = x;
4938 1197 : }
4939 :
4940 : /* sort t_VEC of vector spaces by increasing dimension */
4941 : static GEN
4942 1057 : sort_by_dim(GEN v)
4943 : {
4944 1057 : long i, l = lg(v);
4945 1057 : GEN D = cgetg(l, t_VECSMALL);
4946 2548 : for (i = 1; i < l; i++) D[i] = lg(gmael(v,i,2));
4947 1057 : return vecpermute(v , vecsmall_indexsort(D));
4948 : }
4949 : static GEN
4950 1057 : split_starting_space(GEN mf)
4951 : {
4952 1057 : long d = MF_get_dim(mf), d2;
4953 1057 : GEN id = matid(d);
4954 1057 : switch(MF_get_space(mf))
4955 : {
4956 1050 : case mf_NEW:
4957 1050 : case mf_CUSP: return mkvec2(id, id);
4958 : }
4959 7 : d2 = lg(MF_get_S(mf))-1;
4960 7 : return mkvec2(vecslice(id, d-d2+1,d),
4961 : shallowconcat(zeromat(d2,d-d2),matid(d2)));
4962 : }
4963 : /* If dimlim > 0, keep only the dimension <= dimlim eigenspaces.
4964 : * See mfsplit for the meaning of flag. */
4965 : static GEN
4966 1456 : split_ii(GEN mf, long dimlim, long flag, GEN vSP, long *pnewd)
4967 : {
4968 : forprime_t iter;
4969 1456 : GEN CHI = MF_get_CHI(mf), empty = cgetg(1, t_VEC), mf0 = mf;
4970 : GEN NF, POLCYC, todosp, Tpbigvec, simplesp;
4971 1456 : long N = MF_get_N(mf), k = MF_get_k(mf);
4972 1456 : long ord, FC, NEWT, dimsimple = 0, newd = -1;
4973 1456 : const long NBH = 5, vz = 1;
4974 : ulong p;
4975 :
4976 1456 : switch(MF_get_space(mf))
4977 : {
4978 1169 : case mf_NEW: break;
4979 280 : case mf_CUSP:
4980 : case mf_FULL:
4981 : {
4982 : GEN CHIP;
4983 280 : if (k > 1) { mf0 = mfinittonew(mf); break; }
4984 259 : CHIP = mfchartoprimitive(CHI, NULL);
4985 259 : newd = lg(MF_get_S(mf))-1 - mfolddim_i(N, k, CHIP, vSP);
4986 259 : break;
4987 : }
4988 7 : default: pari_err_TYPE("mfsplit [space does not contain newspace]", mf);
4989 : return NULL; /*LCOV_EXCL_LINE*/
4990 : }
4991 1449 : if (newd < 0) newd = mf0? MF_get_dim(mf0): 0;
4992 1449 : *pnewd = newd;
4993 1449 : if (!newd) return mkvec2(cgetg(1, t_MAT), empty);
4994 :
4995 1057 : NEWT = (k > 1 && MF_get_space(mf0) == mf_NEW);
4996 1057 : todosp = mkvec( split_starting_space(mf0) );
4997 1057 : simplesp = empty;
4998 1057 : FC = mfcharconductor(CHI);
4999 1057 : ord = mfcharorder(CHI);
5000 1057 : if (ord <= 2) NF = POLCYC = NULL;
5001 : else
5002 : {
5003 203 : POLCYC = mfcharpol(CHI);
5004 203 : NF = nfinit(POLCYC,DEFAULTPREC);
5005 : }
5006 1057 : Tpbigvec = zerovec(NBH);
5007 1057 : u_forprime_init(&iter, 2, ULONG_MAX);
5008 1484 : while (dimsimple < newd && (p = u_forprime_next(&iter)))
5009 : {
5010 : GEN nextsp;
5011 : long ind;
5012 1484 : if (N % (p*p) == 0 && N/p % FC == 0) continue; /* T_p = 0 in this case */
5013 1197 : vecpush(Tpbigvec, NEWT? mfnewmathecke_p(mf0,p): mfheckemat_p(mf0,p));
5014 1197 : nextsp = empty;
5015 1582 : for (ind = 1; ind < lg(todosp); ind++)
5016 : {
5017 1309 : GEN tmp = gel(todosp, ind), fa, P, E, D, Tp, DTp;
5018 1309 : GEN A = gel(tmp, 1);
5019 1309 : GEN X = gel(tmp, 2);
5020 : long lP, i;
5021 1309 : tmp = findbestsplit(NF, Tpbigvec, A, X, dimlim, vz);
5022 1428 : if (!tmp) continue; /* nothing there */
5023 1246 : Tp = gel(tmp, 1);
5024 1246 : fa = gel(tmp, 2);
5025 1246 : P = gel(fa, 1);
5026 1246 : E = gel(fa, 2); lP = lg(P);
5027 : /* lP > 1 */
5028 1246 : if (DEBUGLEVEL) err_printf("Exponents = %Ps\n", E);
5029 1246 : if (lP == 2)
5030 : {
5031 854 : GEN P1 = gel(P,1);
5032 854 : long e1 = itos(gel(E,1)), d1 = degpol(P1);
5033 854 : if (e1 * d1 == lg(Tp)-1)
5034 : {
5035 805 : if (e1 > 1) nextsp = vec_append(nextsp, mkvec2(A,X));
5036 : else
5037 : { /* simple module */
5038 707 : simplesp = vec_append(simplesp, mkvec3(A,Tp,P1));
5039 945 : if ((dimsimple += d1) == newd) goto END;
5040 : }
5041 119 : continue;
5042 : }
5043 : }
5044 : /* Found splitting */
5045 441 : DTp = Q_remove_denom(Tp, &D);
5046 1204 : for (i = 1; i < lP; i++)
5047 : {
5048 1001 : GEN Ai, Xi, dXi, AAi, v, y, Pi = gel(P,i);
5049 1001 : Ai = RgX_RgM_eval(D? RgX_rescale(Pi,D): Pi, DTp);
5050 1001 : Ai = QabM_ker(Ai, POLCYC, ord);
5051 1001 : if (NF) Ai = nf_primpart(NF, Ai);
5052 :
5053 1001 : AAi = RgM_mul(A, Ai);
5054 : /* gives section, works on nonsquare matrices */
5055 1001 : Xi = QabM_pseudoinv(Ai, POLCYC, ord, &v, &dXi);
5056 1001 : Xi = RgM_Rg_div(Xi, dXi);
5057 1001 : y = gel(v,1);
5058 1001 : if (isint1(gel(E,i)))
5059 : {
5060 784 : GEN Tpi = RgM_mul(Xi, RgM_mul(rowpermute(Tp,y), Ai));
5061 784 : simplesp = vec_append(simplesp, mkvec3(AAi, Tpi, Pi));
5062 784 : if ((dimsimple += degpol(Pi)) == newd) goto END;
5063 : }
5064 : else
5065 : {
5066 217 : Xi = RgM_mul(Xi, rowpermute(X,y));
5067 217 : nextsp = vec_append(nextsp, mkvec2(AAi, Xi));
5068 : }
5069 : }
5070 : }
5071 273 : todosp = nextsp; if (lg(todosp) == 1) break;
5072 : }
5073 0 : END:
5074 1057 : if (DEBUGLEVEL) err_printf("end split, need to clean\n");
5075 1057 : return mfspclean(mf, mf0, NF, ord, sort_by_dim(simplesp), flag);
5076 : }
5077 : static GEN
5078 28 : dim_filter(GEN v, long dim)
5079 : {
5080 28 : GEN P = gel(v,2);
5081 28 : long j, l = lg(P);
5082 140 : for (j = 1; j < l; j++)
5083 126 : if (degpol(gel(P,j)) > dim)
5084 : {
5085 14 : v = mkvec2(vecslice(gel(v,1),1,j-1), vecslice(P,1,j-1));
5086 14 : break;
5087 : }
5088 28 : return v;
5089 : }
5090 : static long
5091 287 : dim_sum(GEN v)
5092 : {
5093 287 : GEN P = gel(v,2);
5094 287 : long j, l = lg(P), d = 0;
5095 707 : for (j = 1; j < l; j++) d += degpol(gel(P,j));
5096 287 : return d;
5097 : }
5098 : static GEN
5099 1134 : split_i(GEN mf, long dimlim, long flag)
5100 1134 : { long junk; return split_ii(mf, dimlim, flag, NULL, &junk); }
5101 : /* mf is either already split or output by mfinit. Splitting is done only for
5102 : * newspace except in weight 1. If flag = 0 (default) split completely.
5103 : * If flag = d > 0, only give the Galois polynomials in degree > d
5104 : * Flag is ignored if dimlim = 1. */
5105 : GEN
5106 98 : mfsplit(GEN mf0, long dimlim, long flag)
5107 : {
5108 98 : pari_sp av = avma;
5109 98 : GEN v, mf = checkMF_i(mf0);
5110 98 : if (!mf) pari_err_TYPE("mfsplit", mf0);
5111 98 : if ((v = obj_check(mf, MF_SPLIT)))
5112 28 : { if (dimlim) v = dim_filter(v, dimlim); }
5113 70 : else if (dimlim && (v = obj_check(mf, MF_SPLITN)))
5114 21 : { v = (itos(gel(v,1)) >= dimlim)? dim_filter(gel(v,2), dimlim): NULL; }
5115 98 : if (!v)
5116 : {
5117 : long newd;
5118 70 : v = split_ii(mf, dimlim, flag, NULL, &newd);
5119 70 : if (lg(v) == 1) obj_insert(mf, MF_SPLITN, mkvec2(utoi(dimlim), v));
5120 70 : else if (!flag)
5121 : {
5122 49 : if (dim_sum(v) == newd) obj_insert(mf, MF_SPLIT,v);
5123 21 : else obj_insert(mf, MF_SPLITN, mkvec2(utoi(dimlim), v));
5124 : }
5125 : }
5126 98 : return gerepilecopy(av, v);
5127 : }
5128 : static GEN
5129 224 : split(GEN mf) { return split_i(mf,0,0); }
5130 : GEN
5131 770 : MF_get_newforms(GEN mf) { return gel(obj_checkbuild(mf,MF_SPLIT,&split),1); }
5132 : GEN
5133 581 : MF_get_fields(GEN mf) { return gel(obj_checkbuild(mf,MF_SPLIT,&split),2); }
5134 :
5135 : /*************************************************************************/
5136 : /* Modular forms of Weight 1 */
5137 : /*************************************************************************/
5138 : /* S_1(G_0(N)), small N. Return 1 if definitely empty; return 0 if maybe
5139 : * nonempty */
5140 : static int
5141 16632 : wt1empty(long N)
5142 : {
5143 16632 : if (N <= 100) switch (N)
5144 : { /* nonempty [32/100] */
5145 5453 : case 23: case 31: case 39: case 44: case 46:
5146 : case 47: case 52: case 55: case 56: case 57:
5147 : case 59: case 62: case 63: case 68: case 69:
5148 : case 71: case 72: case 76: case 77: case 78:
5149 : case 79: case 80: case 83: case 84: case 87:
5150 : case 88: case 92: case 93: case 94: case 95:
5151 5453 : case 99: case 100: return 0;
5152 3549 : default: return 1;
5153 : }
5154 7630 : if (N <= 600) switch(N)
5155 : { /* empty [111/500] */
5156 336 : case 101: case 102: case 105: case 106: case 109:
5157 : case 113: case 121: case 122: case 123: case 125:
5158 : case 130: case 134: case 137: case 146: case 149:
5159 : case 150: case 153: case 157: case 162: case 163:
5160 : case 169: case 170: case 173: case 178: case 181:
5161 : case 182: case 185: case 187: case 193: case 194:
5162 : case 197: case 202: case 205: case 210: case 218:
5163 : case 221: case 226: case 233: case 241: case 242:
5164 : case 245: case 246: case 250: case 257: case 265:
5165 : case 267: case 269: case 274: case 277: case 281:
5166 : case 289: case 293: case 298: case 305: case 306:
5167 : case 313: case 314: case 317: case 326: case 337:
5168 : case 338: case 346: case 349: case 353: case 361:
5169 : case 362: case 365: case 369: case 370: case 373:
5170 : case 374: case 377: case 386: case 389: case 394:
5171 : case 397: case 401: case 409: case 410: case 421:
5172 : case 425: case 427: case 433: case 442: case 449:
5173 : case 457: case 461: case 466: case 481: case 482:
5174 : case 485: case 490: case 493: case 509: case 514:
5175 : case 521: case 530: case 533: case 534: case 538:
5176 : case 541: case 545: case 554: case 557: case 562:
5177 : case 565: case 569: case 577: case 578: case 586:
5178 336 : case 593: return 1;
5179 6979 : default: return 0;
5180 : }
5181 315 : return 0;
5182 : }
5183 :
5184 : static GEN
5185 28 : initwt1trace(GEN mf)
5186 : {
5187 28 : GEN S = MF_get_S(mf), v, H;
5188 : long l, i;
5189 28 : if (lg(S) == 1) return mftrivial();
5190 28 : H = mfheckemat(mf, Mindex_as_coef(mf));
5191 28 : l = lg(H); v = cgetg(l, t_VEC);
5192 63 : for (i = 1; i < l; i++) gel(v,i) = gtrace(gel(H,i));
5193 28 : v = Minv_RgC_mul(MF_get_Minv(mf), v);
5194 28 : return mflineardiv_linear(S, v, 1);
5195 : }
5196 : static GEN
5197 21 : initwt1newtrace(GEN mf)
5198 : {
5199 21 : GEN v, D, S, Mindex, CHI = MF_get_CHI(mf);
5200 21 : long FC, lD, i, sb, N1, N2, lM, N = MF_get_N(mf);
5201 21 : CHI = mfchartoprimitive(CHI, &FC);
5202 21 : if (N % FC || mfcharparity(CHI) == 1) return mftrivial();
5203 21 : D = mydivisorsu(N/FC); lD = lg(D);
5204 21 : S = MF_get_S(mf);
5205 21 : if (lg(S) == 1) return mftrivial();
5206 21 : N2 = newd_params2(N);
5207 21 : N1 = N / N2;
5208 21 : Mindex = MF_get_Mindex(mf);
5209 21 : lM = lg(Mindex);
5210 21 : sb = Mindex[lM-1];
5211 21 : v = zerovec(sb+1);
5212 42 : for (i = 1; i < lD; i++)
5213 : {
5214 21 : long M = FC*D[i], j;
5215 21 : GEN tf = initwt1trace(M == N? mf: mfinit_Nkchi(M, 1, CHI, mf_CUSP, 0));
5216 : GEN listd, w;
5217 21 : if (mf_get_type(tf) == t_MF_CONST) continue;
5218 21 : w = mfcoefs_i(tf, sb, 1);
5219 21 : if (M == N) { v = gadd(v, w); continue; }
5220 0 : listd = mydivisorsu(u_ppo(ugcd(N/M, N1), FC));
5221 0 : for (j = 1; j < lg(listd); j++)
5222 : {
5223 0 : long d = listd[j], d2 = d*d; /* coprime to FC */
5224 0 : GEN dk = mfchareval(CHI, d);
5225 0 : long NMd = N/(M*d), m;
5226 0 : for (m = 1; m <= sb/d2; m++)
5227 : {
5228 0 : long be = mubeta2(NMd, m);
5229 0 : if (be)
5230 : {
5231 0 : GEN c = gmul(dk, gmulsg(be, gel(w, m+1)));
5232 0 : long n = m*d2;
5233 0 : gel(v, n+1) = gadd(gel(v, n+1), c);
5234 : }
5235 : }
5236 : }
5237 : }
5238 21 : if (gequal0(gel(v,2))) return mftrivial();
5239 21 : v = vecpermute(v,Mindex);
5240 21 : v = Minv_RgC_mul(MF_get_Minv(mf), v);
5241 21 : return mflineardiv_linear(S, v, 1);
5242 : }
5243 :
5244 : /* i*p + 1, i*p < lim corresponding to a_p(f_j), a_{2p}(f_j)... */
5245 : static GEN
5246 1834 : pindices(long p, long lim)
5247 : {
5248 1834 : GEN v = cgetg(lim, t_VECSMALL);
5249 : long i, ip;
5250 22190 : for (i = 1, ip = p + 1; ip < lim; i++, ip += p) v[i] = ip;
5251 1834 : setlg(v, i); return v;
5252 : }
5253 :
5254 : /* assume !wt1empty(N), in particular N>25 */
5255 : /* Returns [[lim,p], mf (weight 2), p*lim x dim matrix] */
5256 : static GEN
5257 1834 : mf1_pre(long N)
5258 : {
5259 : pari_timer tt;
5260 : GEN mf, v, L, I, M, Minv, den;
5261 : long B, lim, LIM, p;
5262 :
5263 1834 : if (DEBUGLEVEL) timer_start(&tt);
5264 1834 : mf = mfinit_Nkchi(N, 2, mfchartrivial(), mf_CUSP, 0);
5265 1834 : if (DEBUGLEVEL)
5266 0 : timer_printf(&tt, "mf1basis [pre]: S_2(%ld), dim = %ld",
5267 : N, MF_get_dim(mf));
5268 1834 : M = MF_get_M(mf); Minv = MF_get_Minv(mf); den = gel(Minv,2);
5269 1834 : B = mfsturm_mf(mf);
5270 1834 : if (uisprime(N))
5271 : {
5272 392 : lim = 2 * MF_get_dim(mf); /* ensure mfstabiter's first kernel ~ square */
5273 392 : p = 2;
5274 : }
5275 : else
5276 : {
5277 : forprime_t S;
5278 1442 : u_forprime_init(&S, 2, N);
5279 2576 : while ((p = u_forprime_next(&S)))
5280 2576 : if (N % p) break;
5281 1442 : lim = B + 1;
5282 : }
5283 1834 : LIM = (N & (N - 1))? 2 * lim: 3 * lim; /* N power of 2 ? */
5284 1834 : L = mkvecsmall4(lim, LIM, mfsturmNk(N,1), p);
5285 1834 : M = bhnmat_extend_nocache(M, N, LIM-1, 1, MF_get_S(mf));
5286 1834 : if (DEBUGLEVEL) timer_printf(&tt, "mf1basis [pre]: bnfmat_extend");
5287 1834 : v = pindices(p, LIM);
5288 1834 : if (!LIM) return mkvec4(L, mf, M, v);
5289 1834 : I = RgM_Rg_div(ZM_mul(rowslice(M, B+2, LIM), gel(Minv,1)), den);
5290 1834 : I = Q_remove_denom(I, &den);
5291 1834 : if (DEBUGLEVEL) timer_printf(&tt, "mf1basis [prec]: Iden");
5292 1834 : return mkvec5(L, mf, M, v, mkvec2(I, den));
5293 : }
5294 :
5295 : /* lg(A) > 1, E a t_POL */
5296 : static GEN
5297 686 : mfmatsermul(GEN A, GEN E)
5298 : {
5299 686 : long j, l = lg(A), r = nbrows(A);
5300 686 : GEN M = cgetg(l, t_MAT);
5301 686 : E = RgXn_red_shallow(E, r+1);
5302 5866 : for (j = 1; j < l; j++)
5303 : {
5304 5180 : GEN c = RgV_to_RgX(gel(A,j), 0);
5305 5180 : gel(M, j) = RgX_to_RgC(RgXn_mul(c, E, r+1), r);
5306 : }
5307 686 : return M;
5308 : }
5309 : /* lg(Ap) > 1, Ep an Flxn */
5310 : static GEN
5311 1141 : mfmatsermul_Fl(GEN Ap, GEN Ep, ulong p)
5312 : {
5313 1141 : long j, l = lg(Ap), r = nbrows(Ap);
5314 1141 : GEN M = cgetg(l, t_MAT);
5315 42630 : for (j = 1; j < l; j++)
5316 : {
5317 41489 : GEN c = Flv_to_Flx(gel(Ap,j), 0);
5318 41489 : gel(M,j) = Flx_to_Flv(Flxn_mul(c, Ep, r+1, p), r);
5319 : }
5320 1141 : return M;
5321 : }
5322 :
5323 : /* CHI mod F | N, return mfchar of modulus N.
5324 : * FIXME: wasteful, G should be precomputed */
5325 : static GEN
5326 13048 : mfcharinduce(GEN CHI, long N)
5327 : {
5328 : GEN G, chi;
5329 13048 : if (mfcharmodulus(CHI) == N) return CHI;
5330 1463 : G = znstar0(utoipos(N), 1);
5331 1463 : chi = zncharinduce(gel(CHI,1), gel(CHI,2), G);
5332 1463 : CHI = leafcopy(CHI);
5333 1463 : gel(CHI,1) = G;
5334 1463 : gel(CHI,2) = chi; return CHI;
5335 : }
5336 :
5337 : static GEN
5338 3983 : gmfcharno(GEN CHI)
5339 : {
5340 3983 : GEN G = gel(CHI,1), chi = gel(CHI,2);
5341 3983 : return mkintmod(znconreyexp(G, chi), znstar_get_N(G));
5342 : }
5343 : static long
5344 13664 : mfcharno(GEN CHI)
5345 : {
5346 13664 : GEN n = znconreyexp(gel(CHI,1), gel(CHI,2));
5347 13664 : return itou(n);
5348 : }
5349 :
5350 : /* return k such that minimal mfcharacter in Galois orbit of CHI is CHI^k */
5351 : static long
5352 12138 : mfconreyminimize(GEN CHI)
5353 : {
5354 12138 : GEN G = gel(CHI,1), cyc, chi;
5355 12138 : cyc = ZV_to_zv(znstar_get_cyc(G));
5356 12138 : chi = ZV_to_zv(znconreychar(G, gel(CHI,2)));
5357 12138 : return zv_cyc_minimize(cyc, chi, coprimes_zv(mfcharorder(CHI)));
5358 : }
5359 :
5360 : /* find scalar c such that first nonzero entry of c*v is 1; return c*v */
5361 : static GEN
5362 2065 : RgV_normalize(GEN v, GEN *pc)
5363 : {
5364 2065 : long i, l = lg(v);
5365 5313 : for (i = 1; i < l; i++)
5366 : {
5367 5313 : GEN c = gel(v,i);
5368 5313 : if (!gequal0(c))
5369 : {
5370 2065 : if (gequal1(c)) break;
5371 679 : *pc = ginv(c); return RgV_Rg_mul(v, *pc);
5372 : }
5373 : }
5374 1386 : *pc = gen_1; return v;
5375 : }
5376 : /* pS != NULL; dim > 0 */
5377 : static GEN
5378 784 : mftreatdihedral(long N, GEN DIH, GEN POLCYC, long ordchi, GEN *pS)
5379 : {
5380 784 : long l = lg(DIH), lim = mfsturmNk(N, 1), i;
5381 784 : GEN Minv, C = cgetg(l, t_VEC), M = cgetg(l, t_MAT);
5382 2436 : for (i = 1; i < l; i++)
5383 : {
5384 1652 : GEN c, v = mfcoefs_i(gel(DIH,i), lim, 1);
5385 1652 : gel(M,i) = RgV_normalize(v, &c);
5386 1652 : gel(C,i) = Rg_col_ei(c, l-1, i);
5387 : }
5388 784 : Minv = gel(mfclean(M,POLCYC,ordchi,0),2);
5389 784 : M = RgM_Minv_mul(M, Minv);
5390 784 : C = RgM_Minv_mul(C, Minv);
5391 784 : *pS = vecmflinear(DIH, C); return M;
5392 : }
5393 :
5394 : /* same mode a maximal ideal above q */
5395 : static GEN
5396 2408 : Tpmod(GEN Ap, GEN A, ulong chip, long p, ulong q)
5397 : {
5398 2408 : GEN B = leafcopy(Ap);
5399 2408 : long i, ip, l = lg(B);
5400 86345 : for (i = 1, ip = p; ip < l; i++, ip += p)
5401 83937 : B[ip] = Fl_add(B[ip], Fl_mul(A[i], chip, q), q);
5402 2408 : return B;
5403 : }
5404 : /* Tp(f_1), ..., Tp(f_d) mod q */
5405 : static GEN
5406 301 : matTpmod(GEN Ap, GEN A, ulong chip, long p, ulong q)
5407 : {
5408 : long i, l;
5409 301 : GEN B = cgetg_copy(A, &l);
5410 2709 : for (i = 1; i < l; i++) gel(B,i) = Tpmod(gel(Ap,i), gel(A,i), chip, p, q);
5411 301 : return B;
5412 : }
5413 :
5414 : /* Ap[i] = a_{p*i}(F), A[i] = a_i(F), i = 1..lim
5415 : * Tp(f)[n] = a_{p*n}(f) + chi(p) a_{n/p}(f) * 1_{p | n} */
5416 : static GEN
5417 469 : Tp(GEN Ap, GEN A, GEN chip, long p)
5418 : {
5419 469 : GEN B = leafcopy(Ap);
5420 469 : long i, ip, l = lg(B);
5421 12915 : for (i = 1, ip = p; ip < l; i++, ip += p)
5422 12446 : gel(B,ip) = gadd(gel(B,ip), gmul(gel(A,i), chip));
5423 469 : return B;
5424 : }
5425 : /* Tp(f_1), ..., Tp(f_d) mod q */
5426 : static GEN
5427 56 : matTp(GEN Ap, GEN A, GEN chip, long p)
5428 : {
5429 : long i, l;
5430 56 : GEN B = cgetg_copy(A, &l);
5431 525 : for (i = 1; i < l; i++) gel(B,i) = Tp(gel(Ap,i), gel(A,i), chip, p);
5432 56 : return B;
5433 : }
5434 :
5435 : static GEN
5436 378 : _RgXQM_mul(GEN x, GEN y, GEN T)
5437 378 : { return T? RgXQM_mul(x, y, T): RgM_mul(x, y); }
5438 : /* largest T-stable Q(CHI)-subspace of Q(CHI)-vector space spanned by columns
5439 : * of A */
5440 : static GEN
5441 28 : mfstabiter(GEN *pC, GEN A0, GEN chip, GEN TMP, GEN P, long ordchi)
5442 : {
5443 28 : GEN A, Ap, vp = gel(TMP,4), C = NULL;
5444 28 : long i, lA, lim1 = gel(TMP,1)[3], p = gel(TMP,1)[4];
5445 : pari_timer tt;
5446 :
5447 28 : Ap = rowpermute(A0, vp);
5448 28 : A = rowslice(A0, 2, nbrows(Ap)+1); /* remove a0 */
5449 : for(;;)
5450 28 : {
5451 56 : GEN R = shallowconcat(matTp(Ap, A, chip, p), A);
5452 56 : GEN B = QabM_ker(R, P, ordchi);
5453 56 : long lB = lg(B);
5454 56 : if (DEBUGLEVEL)
5455 0 : timer_printf(&tt, "mf1basis: Hecke intersection (dim %ld)", lB-1);
5456 56 : if (lB == 1) return NULL;
5457 56 : lA = lg(A); if (lB == lA) break;
5458 28 : B = rowslice(B, 1, lA-1);
5459 28 : Ap = _RgXQM_mul(Ap, B, P);
5460 28 : A = _RgXQM_mul(A, B, P);
5461 28 : C = C? _RgXQM_mul(C, B, P): B;
5462 : }
5463 28 : if (nbrows(A) < lim1)
5464 : {
5465 14 : A0 = rowslice(A0, 2, lim1);
5466 14 : A = C? _RgXQM_mul(A0, C, P): A0;
5467 : }
5468 : else /* all needed coefs computed */
5469 14 : A = rowslice(A, 1, lim1-1);
5470 28 : if (*pC) C = C? _RgXQM_mul(*pC, C, P): *pC;
5471 : /* put back a0 */
5472 119 : for (i = 1; i < lA; i++) gel(A,i) = vec_prepend(gel(A,i), gen_0);
5473 28 : *pC = C; return A;
5474 : }
5475 :
5476 : static long
5477 252 : mfstabitermod(GEN A, GEN vp, ulong chip, long p, ulong q)
5478 : {
5479 252 : GEN Ap, C = NULL;
5480 252 : Ap = rowpermute(A, vp);
5481 252 : A = rowslice(A, 2, nbrows(Ap)+1);
5482 : while (1)
5483 49 : {
5484 301 : GEN Rp = shallowconcat(matTpmod(Ap, A, chip, p, q), A);
5485 301 : GEN B = Flm_ker(Rp, q);
5486 301 : long lA = lg(A), lB = lg(B);
5487 301 : if (lB == 1) return 0;
5488 266 : if (lB == lA) return lA-1;
5489 49 : B = rowslice(B, 1, lA-1);
5490 49 : Ap = Flm_mul(Ap, B, q);
5491 49 : A = Flm_mul(A, B, q);
5492 49 : C = C? Flm_mul(C, B, q): B;
5493 : }
5494 : }
5495 :
5496 : static GEN
5497 595 : mfcharinv_i(GEN CHI)
5498 : {
5499 595 : GEN G = gel(CHI,1);
5500 595 : CHI = leafcopy(CHI); gel(CHI,2) = zncharconj(G, gel(CHI,2)); return CHI;
5501 : }
5502 :
5503 : /* upper bound dim S_1(Gamma_0(N),chi) performing the linear algebra mod p */
5504 : static long
5505 595 : mf1dimmod(GEN E1, GEN E, GEN chip, long ordchi, long dih, GEN TMP)
5506 : {
5507 595 : GEN E1i, A, vp, mf, C = NULL;
5508 595 : ulong q, r = QabM_init(ordchi, &q);
5509 : long lim, LIM, p;
5510 :
5511 595 : LIM = gel(TMP,1)[2]; lim = gel(TMP,1)[1];
5512 595 : mf= gel(TMP,2);
5513 595 : A = gel(TMP,3);
5514 595 : A = QabM_to_Flm(A, r, q);
5515 595 : E1 = QabX_to_Flx(E1, r, q);
5516 595 : E1i = Flxn_inv(E1, nbrows(A), q);
5517 595 : if (E)
5518 : {
5519 574 : GEN Iden = gel(TMP,5), I = gel(Iden,1), den = gel(Iden,2);
5520 574 : GEN Mindex = MF_get_Mindex(mf), F = rowslice(A, 1, LIM);
5521 574 : GEN E1ip = Flxn_red(E1i, LIM);
5522 574 : ulong d = den? umodiu(den, q): 1;
5523 574 : long i, nE = lg(E) - 1;
5524 : pari_sp av;
5525 :
5526 574 : I = ZM_to_Flm(I, q);
5527 574 : if (d != 1) I = Flm_Fl_mul(I, Fl_inv(d, q), q);
5528 574 : av = avma;
5529 1120 : for (i = 1; i <= nE; i++)
5530 : {
5531 889 : GEN e = Flxn_mul(E1ip, QabX_to_Flx(gel(E,i), r, q), LIM, q);
5532 889 : GEN B = mfmatsermul_Fl(F, e, q), z;
5533 889 : GEN B2 = Flm_mul(I, rowpermute(B, Mindex), q);
5534 889 : B = rowslice(B, lim+1,LIM);
5535 889 : z = Flm_ker(Flm_sub(B2, B, q), q);
5536 889 : if (lg(z)-1 == dih) return dih;
5537 546 : C = C? Flm_mul(C, z, q): z;
5538 546 : F = Flm_mul(F, z, q);
5539 546 : gerepileall(av, 2, &F,&C);
5540 : }
5541 231 : A = F;
5542 : }
5543 : /* use Schaeffer */
5544 252 : p = gel(TMP,1)[4]; vp = gel(TMP,4);
5545 252 : A = mfmatsermul_Fl(A, E1i, q);
5546 252 : return mfstabitermod(A, vp, Qab_to_Fl(chip, r, q), p, q);
5547 : }
5548 :
5549 : static GEN
5550 224 : mf1intermat(GEN A, GEN Mindex, GEN e, GEN Iden, long lim, GEN POLCYC)
5551 : {
5552 224 : long j, l = lg(A), LIM = nbrows(A);
5553 224 : GEN I = gel(Iden,1), den = gel(Iden,2), B = cgetg(l, t_MAT);
5554 :
5555 5257 : for (j = 1; j < l; j++)
5556 : {
5557 5033 : pari_sp av = avma;
5558 5033 : GEN c = RgV_to_RgX(gel(A,j), 0), c1, c2;
5559 5033 : c = RgX_to_RgC(RgXn_mul(c, e, LIM), LIM);
5560 5033 : if (POLCYC) c = liftpol_shallow(c);
5561 5033 : c1 = vecslice(c, lim+1, LIM);
5562 5033 : if (den) c1 = RgC_Rg_mul(c1, den);
5563 5033 : c2 = RgM_RgC_mul(I, vecpermute(c, Mindex));
5564 5033 : gel(B, j) = gerepileupto(av, RgC_sub(c2, c1));
5565 : }
5566 224 : return B;
5567 : }
5568 : /* Compute the full S_1(\G_0(N),\chi); return NULL if space is empty; else
5569 : * if pS is NULL, return stoi(dim), where dim is the dimension; else *pS is
5570 : * set to a vector of forms making up a basis, and return the matrix of their
5571 : * Fourier expansions. pdih gives the dimension of the subspace generated by
5572 : * dihedral forms; TMP is from mf1_pre or NULL. */
5573 : static GEN
5574 11284 : mf1basis(long N, GEN CHI, GEN TMP, GEN vSP, GEN *pS, long *pdih)
5575 : {
5576 11284 : GEN E = NULL, EB, E1, E1i, dE1i, mf, A, C, POLCYC, DIH, Minv, chip;
5577 11284 : long nE = 0, p, LIM, lim, lim1, i, lA, dimp, ordchi, dih;
5578 : pari_timer tt;
5579 : pari_sp av;
5580 :
5581 11284 : if (pdih) *pdih = 0;
5582 11284 : if (pS) *pS = NULL;
5583 11284 : if (wt1empty(N) || mfcharparity(CHI) != -1) return NULL;
5584 10990 : ordchi = mfcharorder(CHI);
5585 10990 : if (uisprime(N) && ordchi > 4) return NULL;
5586 10962 : if (pS)
5587 : {
5588 3857 : DIH = mfdihedralcusp(N, CHI, vSP);
5589 3857 : dih = lg(DIH) - 1;
5590 : }
5591 : else
5592 : {
5593 7105 : DIH = NULL;
5594 7105 : dih = mfdihedralcuspdim(N, CHI, vSP);
5595 : }
5596 10962 : POLCYC = (ordchi <= 2)? NULL: mfcharpol(CHI);
5597 10962 : if (pdih) *pdih = dih;
5598 10962 : if (N <= 600) switch(N)
5599 : {
5600 : long m;
5601 126 : case 219: case 273: case 283: case 331: case 333: case 344: case 416:
5602 : case 438: case 468: case 491: case 504: case 546: case 553: case 563:
5603 : case 566: case 581: case 592:
5604 126 : break; /* one chi with both exotic and dihedral forms */
5605 9499 : default: /* only dihedral forms */
5606 9499 : if (!dih) return NULL;
5607 : /* fall through */
5608 : case 124: case 133: case 148: case 171: case 201: case 209: case 224:
5609 : case 229: case 248: case 261: case 266: case 288: case 296: case 301:
5610 : case 309: case 325: case 342: case 371: case 372: case 380: case 399:
5611 : case 402: case 403: case 404: case 408: case 418: case 432: case 444:
5612 : case 448: case 451: case 453: case 458: case 496: case 497: case 513:
5613 : case 522: case 527: case 532: case 576: case 579:
5614 : /* no chi with both exotic and dihedral; one chi with exotic forms */
5615 3248 : if (dih)
5616 : {
5617 2338 : if (!pS) return utoipos(dih);
5618 728 : return mftreatdihedral(N, DIH, POLCYC, ordchi, pS) ;
5619 : }
5620 910 : m = mfcharno(mfcharinduce(CHI,N));
5621 910 : if (N == 124 && (m != 67 && m != 87)) return NULL;
5622 784 : if (N == 133 && (m != 83 && m !=125)) return NULL;
5623 490 : if (N == 148 && (m !=105 && m !=117)) return NULL;
5624 364 : if (N == 171 && (m != 94 && m !=151)) return NULL;
5625 364 : if (N == 201 && (m != 29 && m !=104)) return NULL;
5626 364 : if (N == 209 && (m != 87 && m !=197)) return NULL;
5627 364 : if (N == 224 && (m != 95 && m !=191)) return NULL;
5628 364 : if (N == 229 && (m !=107 && m !=122)) return NULL;
5629 364 : if (N == 248 && (m != 87 && m !=191)) return NULL;
5630 273 : if (N == 261 && (m != 46 && m !=244)) return NULL;
5631 273 : if (N == 266 && (m != 83 && m !=125)) return NULL;
5632 273 : if (N == 288 && (m != 31 && m !=223)) return NULL;
5633 273 : if (N == 296 && (m !=105 && m !=265)) return NULL;
5634 : }
5635 595 : if (DEBUGLEVEL)
5636 0 : err_printf("mf1basis: start character %Ps, conductor = %ld, order = %ld\n",
5637 : gmfcharno(CHI), mfcharconductor(CHI), ordchi);
5638 595 : if (!TMP) TMP = mf1_pre(N);
5639 595 : lim = gel(TMP,1)[1]; LIM = gel(TMP,1)[2]; lim1 = gel(TMP,1)[3];
5640 595 : p = gel(TMP,1)[4];
5641 595 : mf = gel(TMP,2);
5642 595 : A = gel(TMP,3);
5643 595 : EB = mfeisensteinbasis(N, 1, mfcharinv_i(CHI));
5644 595 : nE = lg(EB) - 1;
5645 595 : E1 = RgV_to_RgX(mftocol(gel(EB,1), LIM-1, 1), 0); /* + O(x^LIM) */
5646 595 : if (--nE)
5647 574 : E = RgM_to_RgXV(mfvectomat(vecslice(EB, 2, nE+1), LIM-1, 1), 0);
5648 595 : chip = mfchareval(CHI, p); /* != 0 */
5649 595 : if (DEBUGLEVEL) timer_start(&tt);
5650 595 : av = avma; dimp = mf1dimmod(E1, E, chip, ordchi, dih, TMP);
5651 595 : set_avma(av);
5652 595 : if (DEBUGLEVEL) timer_printf(&tt, "mf1basis: dim mod p is %ld", dimp);
5653 595 : if (!dimp) return NULL;
5654 280 : if (!pS) return utoi(dimp);
5655 224 : if (dimp == dih) return mftreatdihedral(N, DIH, POLCYC, ordchi, pS);
5656 168 : E1i = RgXn_inv(E1, LIM); /* E[1] does not vanish at oo */
5657 168 : if (POLCYC) E1i = liftpol_shallow(E1i);
5658 168 : E1i = Q_remove_denom(E1i, &dE1i);
5659 168 : if (DEBUGLEVEL)
5660 : {
5661 0 : GEN a0 = gel(E1,2);
5662 0 : if (typ(a0) == t_POLMOD) a0 = gnorm(a0);
5663 0 : a0 = Q_abs_shallow(a0);
5664 0 : timer_printf(&tt, "mf1basis: invert E; norm(a0(E)) = %Ps", a0);
5665 : }
5666 168 : C = NULL;
5667 168 : if (nE)
5668 : { /* mf attached to S2(N), fi = mfbasis(mf)
5669 : * M = coefs(f1,...,fd) up to LIM
5670 : * F = coefs(F1,...,FD) = M * C, for some matrix C over Q(chi),
5671 : * initially 1, eventually giving \cap_E S2 / E; D <= d.
5672 : * B = coefs(E/E1 F1, .., E/E1 FD); we want X in Q(CHI)^d and
5673 : * Y in Q(CHI)^D such that
5674 : * B * X = M * Y, i.e. Minv * rowpermute(B, Mindex * X) = Y
5675 : *(B - I * rowpermute(B, Mindex)) * X = 0.
5676 : * where I = M * Minv. Rows of (B - I * ...) are 0 up to lim so
5677 : * are not included */
5678 154 : GEN Mindex = MF_get_Mindex(mf), Iden = gel(TMP,5);
5679 : pari_timer TT;
5680 154 : pari_sp av = avma;
5681 154 : if (DEBUGLEVEL) timer_start(&TT);
5682 238 : for (i = 1; i <= nE; i++)
5683 : {
5684 224 : pari_sp av2 = avma;
5685 : GEN e, z, B;
5686 :
5687 224 : e = Q_primpart(RgXn_mul(E1i, gel(E,i), LIM));
5688 224 : if (DEBUGLEVEL) timer_printf(&TT, "mf1basis: E[%ld] / E[1]", i+1);
5689 : /* the first time A is over Z and it is more efficient to lift than
5690 : * to let RgXn_mul use Kronecker's trick */
5691 224 : if (POLCYC && i == 1) e = liftpol_shallow(e);
5692 224 : B = mf1intermat(A, Mindex, e, Iden, lim, i == 1? NULL: POLCYC);
5693 224 : if (DEBUGLEVEL) timer_printf(&TT, "mf1basis: ... intermat");
5694 224 : z = gerepileupto(av2, QabM_ker(B, POLCYC, ordchi));
5695 224 : if (DEBUGLEVEL)
5696 0 : timer_printf(&TT, "mf1basis: ... kernel (dim %ld)",lg(z)-1);
5697 224 : if (lg(z) == 1) return NULL;
5698 224 : if (lg(z) == lg(A)) { set_avma(av2); continue; } /* no progress */
5699 224 : C = C? _RgXQM_mul(C, z, POLCYC): z;
5700 224 : A = _RgXQM_mul(A, z, POLCYC);
5701 224 : if (DEBUGLEVEL) timer_printf(&TT, "mf1basis: ... updates");
5702 224 : if (lg(z)-1 == dimp) break;
5703 84 : if (gc_needed(av, 1))
5704 : {
5705 0 : if (DEBUGMEM > 1) pari_warn(warnmem,"mf1basis i = %ld", i);
5706 0 : gerepileall(av, 2, &A, &C);
5707 : }
5708 : }
5709 154 : if (DEBUGLEVEL) timer_printf(&tt, "mf1basis: intersection [total]");
5710 : }
5711 168 : lA = lg(A);
5712 168 : if (lA-1 == dimp)
5713 : {
5714 140 : A = mfmatsermul(rowslice(A, 1, lim1), E1i);
5715 140 : if (POLCYC) A = RgXQM_red(A, POLCYC);
5716 140 : if (DEBUGLEVEL) timer_printf(&tt, "mf1basis: matsermul [1]");
5717 : }
5718 : else
5719 : {
5720 28 : A = mfmatsermul(A, E1i);
5721 28 : if (POLCYC) A = RgXQM_red(A, POLCYC);
5722 28 : if (DEBUGLEVEL) timer_printf(&tt, "mf1basis: matsermul [2]");
5723 28 : A = mfstabiter(&C, A, chip, TMP, POLCYC, ordchi);
5724 28 : if (DEBUGLEVEL) timer_printf(&tt, "mf1basis: Hecke stability");
5725 28 : if (!A) return NULL;
5726 : }
5727 168 : if (dE1i) C = RgM_Rg_mul(C, dE1i);
5728 168 : if (POLCYC)
5729 : {
5730 147 : A = QXQM_to_mod_shallow(A, POLCYC);
5731 147 : C = QXQM_to_mod_shallow(C, POLCYC);
5732 : }
5733 168 : lA = lg(A);
5734 581 : for (i = 1; i < lA; i++)
5735 : {
5736 413 : GEN c, v = gel(A,i);
5737 413 : gel(A,i) = RgV_normalize(v, &c);
5738 413 : gel(C,i) = RgC_Rg_mul(gel(C,i), c);
5739 : }
5740 168 : Minv = gel(mfclean(A, POLCYC, ordchi, 0), 2);
5741 168 : A = RgM_Minv_mul(A, Minv);
5742 168 : C = RgM_Minv_mul(C, Minv);
5743 168 : *pS = vecmflineardiv0(MF_get_S(mf), C, gel(EB,1));
5744 168 : return A;
5745 : }
5746 :
5747 : static void
5748 406 : MF_set_space(GEN mf, long x) { gmael(mf,1,4) = utoi(x); }
5749 : static GEN
5750 252 : mf1_cusptonew(GEN mf, GEN vSP)
5751 : {
5752 252 : const long vy = 1;
5753 : long i, lP, dSnew, ct;
5754 252 : GEN vP, F, S, Snew, vF, v = split_ii(mf, 0, 0, vSP, &i);
5755 :
5756 252 : F = gel(v,1);
5757 252 : vP= gel(v,2); lP = lg(vP);
5758 252 : if (lP == 1) { obj_insert(mf, MF_SPLIT, v); return NULL; }
5759 238 : MF_set_space(mf, mf_NEW);
5760 238 : S = MF_get_S(mf);
5761 238 : dSnew = dim_sum(v);
5762 238 : Snew = cgetg(dSnew + 1, t_VEC); ct = 0;
5763 238 : vF = cgetg(lP, t_MAT);
5764 546 : for (i = 1; i < lP; i++)
5765 : {
5766 308 : GEN V, P = gel(vP,i), f = liftpol_shallow(gel(F,i));
5767 308 : long j, d = degpol(P);
5768 308 : gel(vF,i) = V = zerocol(dSnew);
5769 308 : if (d == 1)
5770 : {
5771 140 : gel(Snew, ct+1) = mflineardiv_linear(S, f, 0);
5772 140 : gel(V, ct+1) = gen_1;
5773 : }
5774 : else
5775 : {
5776 168 : f = RgXV_to_RgM(f,d);
5777 511 : for (j = 1; j <= d; j++)
5778 : {
5779 343 : gel(Snew, ct+j) = mflineardiv_linear(S, row(f,j), 0);
5780 343 : gel(V, ct+j) = mkpolmod(pol_xn(j-1,vy), P);
5781 : }
5782 : }
5783 308 : ct += d;
5784 : }
5785 238 : obj_insert(mf, MF_SPLIT, mkvec2(vF, vP));
5786 238 : gel(mf,3) = Snew; return mf;
5787 : }
5788 : static GEN
5789 3969 : mf1init(long N, GEN CHI, GEN TMP, GEN vSP, long space, long flraw)
5790 : {
5791 3969 : GEN mf, mf1, S, M = mf1basis(N, CHI, TMP, vSP, &S, NULL);
5792 3969 : if (!M) return NULL;
5793 952 : mf1 = mkvec4(stoi(N), gen_1, CHI, utoi(mf_CUSP));
5794 952 : mf = mkmf(mf1, cgetg(1,t_VEC), S, gen_0, NULL);
5795 952 : if (space == mf_NEW)
5796 : {
5797 252 : gel(mf,5) = mfcleanCHI(M,CHI, 0);
5798 252 : mf = mf1_cusptonew(mf, vSP); if (!mf) return NULL;
5799 238 : if (!flraw) M = mfcoefs_mf(mf, mfsturmNk(N,1)+1, 1);
5800 : }
5801 938 : gel(mf,5) = flraw? zerovec(3): mfcleanCHI(M, CHI, 0);
5802 938 : return mf;
5803 : }
5804 :
5805 : static GEN
5806 1022 : mfEMPTY(GEN mf1)
5807 : {
5808 1022 : GEN Minv = mkMinv(cgetg(1,t_MAT), NULL,NULL,NULL);
5809 1022 : GEN M = mkvec3(cgetg(1,t_VECSMALL), Minv, cgetg(1,t_MAT));
5810 1022 : return mkmf(mf1, cgetg(1,t_VEC), cgetg(1,t_VEC), cgetg(1,t_VEC), M);
5811 : }
5812 : static GEN
5813 616 : mfEMPTYall(long N, GEN gk, GEN vCHI, long space)
5814 : {
5815 : long i, l;
5816 : GEN v, gN, gs;
5817 616 : if (!vCHI) return cgetg(1, t_VEC);
5818 14 : gN = utoipos(N); gs = utoi(space);
5819 14 : l = lg(vCHI); v = cgetg(l, t_VEC);
5820 42 : for (i = 1; i < l; i++) gel(v,i) = mfEMPTY(mkvec4(gN,gk,gel(vCHI,i),gs));
5821 14 : return v;
5822 : }
5823 :
5824 : static GEN
5825 3983 : fmt_dim(GEN CHI, long d, long dih)
5826 3983 : { return mkvec4(gmfcharorder(CHI), gmfcharno(CHI), utoi(d), stoi(dih)); }
5827 : /* merge two vector of fmt_dim's for the same vector of characters. If CHI
5828 : * is not NULL, remove dim-0 spaces and add character from CHI */
5829 : static GEN
5830 7 : merge_dims(GEN V, GEN W, GEN CHI)
5831 : {
5832 7 : long i, j, id, l = lg(V);
5833 7 : GEN A = cgetg(l, t_VEC);
5834 7 : if (l == 1) return A;
5835 7 : id = CHI? 1: 3;
5836 21 : for (i = j = 1; i < l; i++)
5837 : {
5838 14 : GEN v = gel(V,i), w = gel(W,i);
5839 14 : long dv = itou(gel(v,id)), dvh = itou(gel(v,id+1)), d;
5840 14 : long dw = itou(gel(w,id)), dwh = itou(gel(w,id+1));
5841 14 : d = dv + dw;
5842 14 : if (d || CHI)
5843 14 : gel(A,j++) = CHI? fmt_dim(gel(CHI,i),d, dvh+dwh)
5844 14 : : mkvec2s(d,dvh+dwh);
5845 : }
5846 7 : setlg(A, j); return A;
5847 : }
5848 : static GEN
5849 3010 : mfdim0all(GEN w)
5850 : {
5851 3038 : if (w) retconst_vec(lg(w)-1, zerovec(2));
5852 3003 : return cgetg(1,t_VEC);
5853 : }
5854 : static long
5855 7315 : mf1cuspdim_i(long N, GEN CHI, GEN TMP, GEN vSP, long *dih)
5856 : {
5857 7315 : pari_sp av = avma;
5858 7315 : GEN b = mf1basis(N, CHI, TMP, vSP, NULL, dih);
5859 7315 : return gc_long(av, b? itou(b): 0);
5860 : }
5861 :
5862 : static long
5863 476 : mf1cuspdim(long N, GEN CHI, GEN vSP)
5864 : {
5865 476 : if (!vSP) vSP = get_vDIH(N, divisorsNF(N, mfcharconductor(CHI)));
5866 476 : return mf1cuspdim_i(N, CHI, NULL, vSP, NULL);
5867 : }
5868 : static GEN
5869 4144 : mf1cuspdimall(long N, GEN vCHI)
5870 : {
5871 : GEN z, TMP, w, vSP;
5872 : long i, j, l;
5873 4144 : if (wt1empty(N)) return mfdim0all(vCHI);
5874 1141 : w = mf1chars(N,vCHI);
5875 1141 : l = lg(w); if (l == 1) return cgetg(1,t_VEC);
5876 1141 : z = cgetg(l, t_VEC);
5877 1141 : TMP = mf1_pre(N); vSP = get_vDIH(N, NULL);
5878 7861 : for (i = j = 1; i < l; i++)
5879 : {
5880 6720 : GEN CHI = gel(w,i);
5881 6720 : long dih, d = mf1cuspdim_i(N, CHI, TMP, vSP, &dih);
5882 6720 : if (vCHI)
5883 42 : gel(z,j++) = mkvec2s(d, dih);
5884 6678 : else if (d)
5885 1428 : gel(z,j++) = fmt_dim(CHI, d, dih);
5886 : }
5887 1141 : setlg(z,j); return z;
5888 : }
5889 :
5890 : /* dimension of S_1(Gamma_1(N)) */
5891 : static long
5892 4123 : mf1cuspdimsum(long N)
5893 : {
5894 4123 : pari_sp av = avma;
5895 4123 : GEN v = mf1cuspdimall(N, NULL);
5896 4123 : long i, ct = 0, l = lg(v);
5897 5544 : for (i = 1; i < l; i++)
5898 : {
5899 1421 : GEN w = gel(v,i); /* [ord(CHI),*,dim,*] */
5900 1421 : ct += itou(gel(w,3))*myeulerphiu(itou(gel(w,1)));
5901 : }
5902 4123 : return gc_long(av,ct);
5903 : }
5904 :
5905 : static GEN
5906 56 : mf1newdimall(long N, GEN vCHI)
5907 : {
5908 : GEN z, w, vTMP, vSP, fa, P, E;
5909 : long i, c, l, lw, P1;
5910 56 : if (wt1empty(N)) return mfdim0all(vCHI);
5911 56 : w = mf1chars(N,vCHI);
5912 56 : lw = lg(w); if (lw == 1) return cgetg(1,t_VEC);
5913 56 : vTMP = const_vec(N, NULL);
5914 56 : vSP = get_vDIH(N, NULL);
5915 56 : gel(vTMP,N) = mf1_pre(N);
5916 : /* if p || N and p \nmid F(CHI), S_1^new(G0(N),chi) = 0 */
5917 56 : fa = znstar_get_faN(gmael(w,1,1));
5918 56 : P = gel(fa,1); l = lg(P);
5919 56 : E = gel(fa,2);
5920 154 : for (i = P1 = 1; i < l; i++)
5921 98 : if (E[i] == 1) P1 *= itou(gel(P,i));
5922 : /* P1 = \prod_{v_p(N) = 1} p */
5923 56 : z = cgetg(lw, t_VEC);
5924 182 : for (i = c = 1; i < lw; i++)
5925 : {
5926 : long S, j, l, F, dihnew;
5927 126 : GEN D, CHI = gel(w,i), CHIP = mfchartoprimitive(CHI,&F);
5928 :
5929 126 : S = F % P1? 0: mf1cuspdim_i(N, CHI, gel(vTMP,N), vSP, &dihnew);
5930 126 : if (!S)
5931 : {
5932 56 : if (vCHI) gel(z, c++) = zerovec(2);
5933 56 : continue;
5934 : }
5935 70 : D = mydivisorsu(N/F); l = lg(D);
5936 77 : for (j = l-2; j > 0; j--) /* skip last M = N */
5937 : {
5938 7 : long M = D[j]*F, m, s, dih;
5939 7 : GEN TMP = gel(vTMP,M);
5940 7 : if (wt1empty(M) || !(m = mubeta(D[l-j]))) continue; /*m = mubeta(N/M)*/
5941 7 : if (!TMP) gel(vTMP,M) = TMP = mf1_pre(M);
5942 7 : s = mf1cuspdim_i(M, CHIP, TMP, vSP, &dih);
5943 7 : if (s) { S += m * s; dihnew += m * dih; }
5944 : }
5945 70 : if (vCHI)
5946 63 : gel(z,c++) = mkvec2s(S, dihnew);
5947 7 : else if (S)
5948 7 : gel(z, c++) = fmt_dim(CHI, S, dihnew);
5949 : }
5950 56 : setlg(z,c); return z;
5951 : }
5952 :
5953 : static GEN
5954 28 : mf1olddimall(long N, GEN vCHI)
5955 : {
5956 : long i, j, l;
5957 : GEN z, w;
5958 28 : if (wt1empty(N)) return mfdim0all(vCHI);
5959 28 : w = mf1chars(N,vCHI);
5960 28 : l = lg(w); z = cgetg(l, t_VEC);
5961 84 : for (i = j = 1; i < l; i++)
5962 : {
5963 56 : GEN CHI = gel(w,i);
5964 56 : long d = mfolddim(N, 1, CHI);
5965 56 : if (vCHI)
5966 28 : gel(z,j++) = mkvec2s(d,d?-1:0);
5967 28 : else if (d)
5968 7 : gel(z, j++) = fmt_dim(CHI, d, -1);
5969 : }
5970 28 : setlg(z,j); return z;
5971 : }
5972 :
5973 : static long
5974 469 : mf1olddimsum(long N)
5975 : {
5976 : GEN D;
5977 469 : long N2, i, l, S = 0;
5978 469 : newd_params(N, &N2); /* will ensure mubeta != 0 */
5979 469 : D = mydivisorsu(N/N2); l = lg(D);
5980 2485 : for (i = 2; i < l; i++)
5981 : {
5982 2016 : long M = D[l-i]*N2, d = mf1cuspdimsum(M);
5983 2016 : if (d) S -= mubeta(D[i]) * d;
5984 : }
5985 469 : return S;
5986 : }
5987 : static long
5988 1050 : mf1newdimsum(long N)
5989 : {
5990 1050 : long S = mf1cuspdimsum(N);
5991 1050 : return S? S - mf1olddimsum(N): 0;
5992 : }
5993 :
5994 : /* return the automorphism of a degree-2 nf */
5995 : static GEN
5996 5768 : nf2_get_conj(GEN nf)
5997 : {
5998 5768 : GEN pol = nf_get_pol(nf);
5999 5768 : return deg1pol_shallow(gen_m1, negi(gel(pol,3)), varn(pol));
6000 : }
6001 : static int
6002 42 : foo_stable(GEN foo)
6003 42 : { return lg(foo) != 3 || equalii(gel(foo,1), gel(foo,2)); }
6004 :
6005 : static long
6006 224 : mfisdihedral(GEN vF, GEN DIH)
6007 : {
6008 224 : GEN vG = gel(DIH,1), M = gel(DIH,2), v, G, bnr, w, gen, D, f, nf, tau;
6009 224 : GEN bnr0 = NULL, f0, f0b, xin, foo;
6010 : long i, l, e, j, L, n;
6011 224 : if (lg(M) == 1) return 0;
6012 42 : v = RgM_RgC_invimage(M, vF);
6013 42 : if (!v) return 0;
6014 42 : l = lg(v);
6015 42 : for (i = 1; i < l; i++)
6016 42 : if (!gequal0(gel(v,i))) break;
6017 42 : if (i == l) return 0;
6018 42 : G = gel(vG,i);
6019 42 : bnr = gel(G,2); D = cyc_get_expo(bnr_get_cyc(bnr));
6020 42 : w = gel(G,3);
6021 42 : f = bnr_get_mod(bnr);
6022 42 : nf = bnr_get_nf(bnr);
6023 42 : tau = nf2_get_conj(nf);
6024 42 : f0 = gel(f,1); foo = gel(f,2);
6025 42 : f0b = galoisapply(nf, tau, f0);
6026 42 : xin = zv_to_ZV(gel(w,2)); /* xi(bnr.gen[i]) = e(xin[i] / D) */
6027 42 : if (!foo_stable(foo)) { foo = mkvec2(gen_1, gen_1); bnr0 = bnr; }
6028 42 : if (!gequal(f0, f0b))
6029 : {
6030 21 : f0 = idealmul(nf, f0, idealdivexact(nf, f0b, idealadd(nf, f0, f0b)));
6031 21 : bnr0 = bnr;
6032 : }
6033 42 : if (bnr0)
6034 : { /* conductor not ambiguous */
6035 : GEN S;
6036 28 : bnr = Buchray(bnr_get_bnf(bnr), mkvec2(f0, foo), nf_INIT | nf_GEN);
6037 28 : S = bnrsurjection(bnr, bnr0);
6038 28 : xin = FpV_red(RgV_RgM_mul(xin, gel(S,1)), D);
6039 : /* still xi(gen[i]) = e(xin[i] / D), for the new generators; D stays
6040 : * the same, not exponent(bnr.cyc) ! */
6041 : }
6042 42 : gen = bnr_get_gen(bnr); L = lg(gen);
6043 77 : for (j = 1, e = itou(D); j < L; j++)
6044 : {
6045 63 : GEN Ng = idealnorm(nf, gel(gen,j));
6046 63 : GEN a = shifti(gel(xin,j), 1); /* xi(g_j^2) = e(a/D) */
6047 63 : GEN b = FpV_dotproduct(xin, isprincipalray(bnr,Ng), D);
6048 63 : GEN m = Fp_sub(a, b, D); /* xi(g_j/g_j^\tau) = e(m/D) */
6049 63 : e = ugcd(e, itou(m)); if (e == 1) break;
6050 : }
6051 42 : n = itou(D) / e;
6052 42 : return n == 1? 4: 2*n;
6053 : }
6054 :
6055 : static ulong
6056 119 : myradicalu(ulong n) { return zv_prod(gel(myfactoru(n),1)); }
6057 :
6058 : /* list of fundamental discriminants unramified outside N, with sign s
6059 : * [s = 0 => no sign condition] */
6060 : static GEN
6061 119 : mfunram(long N, long s)
6062 : {
6063 119 : long cN = myradicalu(N >> vals(N)), p = 1, m = 1, l, c, i;
6064 119 : GEN D = mydivisorsu(cN), res;
6065 119 : l = lg(D);
6066 119 : if (s == 1) m = 0; else if (s == -1) p = 0;
6067 119 : res = cgetg(6*l - 5, t_VECSMALL);
6068 119 : c = 1;
6069 119 : if (!odd(N))
6070 : { /* d = 1 */
6071 56 : if (p) res[c++] = 8;
6072 56 : if (m) { res[c++] =-8; res[c++] =-4; }
6073 : }
6074 364 : for (i = 2; i < l; i++)
6075 : { /* skip d = 1, done above */
6076 245 : long d = D[i], d4 = d & 3L; /* d odd, squarefree, d4 = 1 or 3 */
6077 245 : if (d4 == 1) { if (p) res[c++] = d; }
6078 182 : else { if (m) res[c++] =-d; }
6079 245 : if (!odd(N))
6080 : {
6081 56 : if (p) { res[c++] = 8*d; if (d4 == 3) res[c++] = 4*d; }
6082 56 : if (m) { res[c++] =-8*d; if (d4 == 1) res[c++] =-4*d; }
6083 : }
6084 : }
6085 119 : setlg(res, c); return res;
6086 : }
6087 :
6088 : /* Return 1 if F is definitely not S4 type; return 0 on failure. */
6089 : static long
6090 105 : mfisnotS4(long N, GEN w)
6091 : {
6092 105 : GEN D = mfunram(N, 0);
6093 105 : long i, lD = lg(D), lw = lg(w);
6094 616 : for (i = 1; i < lD; i++)
6095 : {
6096 511 : long p, d = D[i], ok = 0;
6097 1442 : for (p = 2; p < lw; p++)
6098 1442 : if (w[p] && kross(d,p) == -1) { ok = 1; break; }
6099 511 : if (!ok) return 0;
6100 : }
6101 105 : return 1;
6102 : }
6103 :
6104 : /* Return 1 if Q(sqrt(5)) \not\subset Q(F), i.e. F is definitely not A5 type;
6105 : * return 0 on failure. */
6106 : static long
6107 105 : mfisnotA5(GEN F)
6108 : {
6109 105 : GEN CHI = mf_get_CHI(F), P = mfcharpol(CHI), T, Q;
6110 :
6111 105 : if (mfcharorder(CHI) % 5 == 0) return 0;
6112 105 : T = mf_get_field(F); if (degpol(T) == 1) return 1;
6113 105 : if (degpol(P) > 1) T = rnfequation(P,T);
6114 105 : Q = gsubgs(pol_xn(2,varn(T)), 5);
6115 105 : return (typ(nfisincl(Q, T)) == t_INT);
6116 : }
6117 :
6118 : /* v[p+1]^2 / chi(p) - 2 = z + 1/z with z primitive root of unity of order n,
6119 : * return n */
6120 : static long
6121 6741 : mffindrootof1(GEN v, long p, GEN CHI)
6122 : {
6123 6741 : GEN ap = gel(v,p+1), u0, u1, u1k, u2;
6124 6741 : long c = 1;
6125 6741 : if (gequal0(ap)) return 2;
6126 5033 : u0 = gen_2; u1k = u1 = gsubgs(gdiv(gsqr(ap), mfchareval(CHI, p)), 2);
6127 14812 : while (!gequalsg(2, liftpol_shallow(u1))) /* u1 = z^c + z^-c */
6128 : {
6129 9779 : u2 = gsub(gmul(u1k, u1), u0);
6130 9779 : u0 = u1; u1 = u2; c++;
6131 : }
6132 5033 : return c;
6133 : }
6134 :
6135 : /* we known that F is not dihedral */
6136 : static long
6137 182 : mfgaloistype_i(long N, GEN CHI, GEN F, GEN v)
6138 : {
6139 : forprime_t iter;
6140 182 : long lim = lg(v)-2;
6141 182 : GEN w = zero_zv(lim);
6142 : pari_sp av;
6143 : ulong p;
6144 182 : u_forprime_init(&iter, 2, lim);
6145 182 : av = avma;
6146 5292 : while((p = u_forprime_next(&iter))) if (N%p) switch(mffindrootof1(v, p, CHI))
6147 : {
6148 1400 : case 1: case 2: continue;
6149 3451 : case 3: w[p] = 1; break;
6150 70 : case 4: return -24; /* S4 */
6151 0 : case 5: return -60; /* A5 */
6152 7 : default: pari_err_DOMAIN("mfgaloistype", "form", "not a",
6153 : strtoGENstr("cuspidal eigenform"), F);
6154 0 : set_avma(av);
6155 : }
6156 364 : if (mfisnotS4(N,w) && mfisnotA5(F)) return -12; /* A4 */
6157 0 : return 0; /* FAILURE */
6158 : }
6159 :
6160 : static GEN
6161 224 : mfgaloistype0(long N, GEN CHI, GEN F, GEN DIH, long lim)
6162 : {
6163 224 : pari_sp av = avma;
6164 224 : GEN vF = mftocol(F, lim, 1);
6165 224 : long t = mfisdihedral(vF, DIH), bound;
6166 224 : if (t) return gc_stoi(av,t);
6167 182 : bound = maxss(200, 5*expu(N)*expu(N));
6168 : for(;;)
6169 : {
6170 182 : t = mfgaloistype_i(N, CHI, F, vF);
6171 175 : set_avma(av); if (t) return stoi(t);
6172 0 : if (lim > bound) return gen_0;
6173 0 : lim += lim >> 1;
6174 0 : vF = mfcoefs_i(F,lim,1);
6175 : }
6176 : }
6177 :
6178 : /* If f is NULL, give all the galoistypes, otherwise just for f */
6179 : /* Return 0 to indicate failure; in this case the type is either -12 or -60,
6180 : * most likely -12. FIXME using the Galois representation. */
6181 : GEN
6182 231 : mfgaloistype(GEN NK, GEN f)
6183 : {
6184 231 : pari_sp av = avma;
6185 231 : GEN CHI, T, F, DIH, SP, mf = checkMF_i(NK);
6186 : long N, k, lL, i, lim, SB;
6187 :
6188 231 : if (f && !checkmf_i(f)) pari_err_TYPE("mfgaloistype", f);
6189 224 : if (mf)
6190 : {
6191 189 : N = MF_get_N(mf);
6192 189 : k = MF_get_k(mf);
6193 189 : CHI = MF_get_CHI(mf);
6194 : }
6195 : else
6196 : {
6197 35 : checkNK(NK, &N, &k, &CHI, 0);
6198 35 : mf = f? NULL: mfinit_i(NK, mf_NEW);
6199 : }
6200 224 : if (k != 1) pari_err_DOMAIN("mfgaloistype", "k", "!=", gen_1, stoi(k));
6201 224 : SB = mf? mfsturm_mf(mf): mfsturmNk(N,1);
6202 224 : SP = get_DIH(N);
6203 224 : DIH = mfdihedralnew(N, CHI, SP);
6204 224 : lim = lg(DIH) == 1? 200: SB;
6205 224 : DIH = mkvec2(DIH, mfvectomat(DIH,SB,1));
6206 224 : if (f) return gerepileuptoint(av, mfgaloistype0(N,CHI, f, DIH, lim));
6207 126 : F = mfeigenbasis(mf); lL = lg(F);
6208 126 : T = cgetg(lL, t_VEC);
6209 252 : for (i=1; i < lL; i++) gel(T,i) = mfgaloistype0(N, CHI, gel(F,i), DIH, lim);
6210 126 : return gerepileupto(av, T);
6211 : }
6212 :
6213 : /******************************************************************/
6214 : /* Find all dihedral forms. */
6215 : /******************************************************************/
6216 : /* lim >= 2 */
6217 : static void
6218 14 : consttabdihedral(long lim) { cache_set(cache_DIH, mfdihedralall(lim)); }
6219 :
6220 : /* a ideal coprime to bnr modulus */
6221 : static long
6222 107611 : mfdiheval(GEN bnr, GEN w, GEN a)
6223 : {
6224 107611 : GEN L, cycn = gel(w,1), chin = gel(w,2);
6225 107611 : long ordmax = cycn[1];
6226 107611 : L = ZV_to_Flv(isprincipalray(bnr,a), ordmax);
6227 107611 : return Flv_dotproduct(chin, L, ordmax);
6228 : }
6229 :
6230 : /* A(x^k) mod T = polcyclo(m), 0 <= k < m */
6231 : static GEN
6232 30247 : Galois(GEN A, long k, GEN T, long m)
6233 : {
6234 : GEN B;
6235 : long i, ik, d;
6236 30247 : if (typ(A) != t_POL) return A;
6237 7413 : if (varn(A) != varn(T))
6238 : {
6239 14 : B = cgetg_copy(A, &d); B[1] = A[1];
6240 35 : for (i = 2; i < d; i++) gel(B, i) = Galois(gel(A, i), k, T, m);
6241 14 : return B;
6242 : }
6243 7399 : if ((d = degpol(A)) <= 0) return A;
6244 7042 : B = cgetg(m + 2, t_POL); B[1] = A[1]; gel(B,2) = gel(A,2);
6245 61313 : for (i = 1; i < m; i++) gel(B, i+2) = gen_0;
6246 23877 : for (i = 1, ik = k; i <= d; i++, ik = Fl_add(ik, k, m))
6247 16835 : gel(B, ik + 2) = gel(A, i+2);
6248 7042 : return QX_ZX_rem(normalizepol(B), T);
6249 : }
6250 : static GEN
6251 1001 : vecGalois(GEN v, long k, GEN T, long m)
6252 : {
6253 : long i, l;
6254 1001 : GEN w = cgetg_copy(v,&l);
6255 31227 : for (i = 1; i < l; i++) gel(w,i) = Galois(gel(v,i), k, T, m);
6256 1001 : return w;
6257 : }
6258 :
6259 : static GEN
6260 234178 : fix_pol(GEN S, GEN Pn, int *trace)
6261 : {
6262 234178 : if (typ(S) != t_POL) return S;
6263 118069 : S = RgX_rem(S, Pn);
6264 118069 : if (typ(S) == t_POL)
6265 : {
6266 118069 : switch(lg(S))
6267 : {
6268 45108 : case 2: return gen_0;
6269 20517 : case 3: return gel(S,2);
6270 : }
6271 52444 : *trace = 1;
6272 : }
6273 52444 : return S;
6274 : }
6275 :
6276 : static GEN
6277 13573 : dihan(GEN bnr, GEN w, GEN k0j, long m, ulong lim)
6278 : {
6279 13573 : GEN nf = bnr_get_nf(bnr), f = bid_get_ideal(bnr_get_bid(bnr));
6280 13573 : GEN v = zerovec(lim+1), cycn = gel(w,1), Tinit = gel(w,3);
6281 13573 : GEN Pn = gel(Tinit,lg(Tinit)==4? 2: 1);
6282 13573 : long j, ordmax = cycn[1];
6283 13573 : long D = itos(nf_get_disc(nf)), vt = varn(Pn);
6284 13573 : int trace = 0;
6285 : ulong p, n;
6286 : forprime_t T;
6287 :
6288 13573 : if (!lim) return v;
6289 13363 : gel(v,2) = gen_1;
6290 13363 : u_forprime_init(&T, 2, lim);
6291 : /* fill in prime powers first */
6292 116207 : while ((p = u_forprime_next(&T)))
6293 : {
6294 : GEN vP, vchiP, S;
6295 : long k, lP;
6296 : ulong q, qk;
6297 102844 : if (kross(D,p) >= 0) q = p;
6298 45192 : else if (!(q = umuluu_le(p,p,lim))) continue;
6299 : /* q = Norm P */
6300 65856 : vP = idealprimedec(nf, utoipos(p));
6301 65856 : lP = lg(vP);
6302 65856 : vchiP = cgetg(lP, t_VECSMALL);
6303 179081 : for (j = k = 1; j < lP; j++)
6304 : {
6305 113225 : GEN P = gel(vP,j);
6306 113225 : if (!idealval(nf, f, P)) vchiP[k++] = mfdiheval(bnr,w,P);
6307 : }
6308 65856 : if (k == 1) continue;
6309 62188 : setlg(vchiP, k); lP = k;
6310 62188 : if (lP == 2)
6311 : { /* one prime above p not dividing f */
6312 16765 : long s, s0 = vchiP[1];
6313 27069 : for (qk=q, s = s0;; s = Fl_add(s,s0,ordmax))
6314 : {
6315 27069 : S = Qab_zeta(s, ordmax, vt);
6316 27069 : gel(v, qk+1) = fix_pol(S, Pn, &trace);
6317 27069 : if (!(qk = umuluu_le(qk,q,lim))) break;
6318 : }
6319 : }
6320 : else /* two primes above p not dividing f */
6321 : {
6322 45423 : long s, s0 = vchiP[1], s1 = vchiP[2];
6323 45423 : for (qk=q, k = 1;; k++)
6324 18424 : { /* sum over a,b s.t. Norm( P1^a P2^b ) = q^k, i.e. a+b = k */
6325 : long a;
6326 63847 : GEN S = gen_0;
6327 220752 : for (a = 0; a <= k; a++)
6328 : {
6329 156905 : s = Fl_add(Fl_mul(a, s0, ordmax), Fl_mul(k-a, s1, ordmax), ordmax);
6330 156905 : S = gadd(S, Qab_zeta(s, ordmax, vt));
6331 : }
6332 63847 : gel(v, qk+1) = fix_pol(S, Pn, &trace);
6333 63847 : if (!(qk = umuluu_le(qk,q,lim))) break;
6334 : }
6335 : }
6336 : }
6337 : /* complete with nonprime powers */
6338 308098 : for (n = 2; n <= lim; n++)
6339 : {
6340 294735 : GEN S, fa = myfactoru(n), P = gel(fa, 1), E = gel(fa, 2);
6341 : long q;
6342 294735 : if (lg(P) == 2) continue;
6343 : /* not a prime power */
6344 143262 : q = upowuu(P[1],E[1]);
6345 143262 : S = gmul(gel(v, q + 1), gel(v, n/q + 1));
6346 143262 : gel(v, n+1) = fix_pol(S, Pn, &trace);
6347 : }
6348 13363 : if (trace)
6349 : {
6350 7154 : long k0 = k0j[1], jdeg = k0j[2];
6351 7154 : v = QabV_tracerel(Tinit, jdeg, v); /* Apply Galois Mod(k0, ordw) */
6352 7154 : if (k0 > 1) v = vecGalois(v, k0, gel(Tinit,1), m);
6353 : }
6354 13363 : return v;
6355 : }
6356 :
6357 : /* as cyc_normalize for t_VECSMALL cyc */
6358 : static GEN
6359 26810 : cyc_normalize_zv(GEN cyc)
6360 : {
6361 26810 : long i, o = cyc[1], l = lg(cyc); /* > 1 */
6362 26810 : GEN D = cgetg(l, t_VECSMALL);
6363 31185 : D[1] = o; for (i = 2; i < l; i++) D[i] = o / cyc[i];
6364 26810 : return D;
6365 : }
6366 : /* as char_normalize for t_VECSMALLs */
6367 : static GEN
6368 118517 : char_normalize_zv(GEN chi, GEN ncyc)
6369 : {
6370 118517 : long i, l = lg(chi);
6371 118517 : GEN c = cgetg(l, t_VECSMALL);
6372 118517 : if (l > 1) {
6373 118517 : c[1] = chi[1];
6374 160454 : for (i = 2; i < l; i++) c[i] = chi[i] * ncyc[i];
6375 : }
6376 118517 : return c;
6377 : }
6378 :
6379 : static GEN
6380 9331 : dihan_bnf(long D)
6381 : {
6382 9331 : GEN c = getrand(), bnf;
6383 9331 : setrand(gen_1);
6384 9331 : bnf = Buchall(quadpoly_i(stoi(D)), nf_FORCE, LOWDEFAULTPREC);
6385 9331 : setrand(c);
6386 9331 : return bnf;
6387 : }
6388 : static GEN
6389 37758 : dihan_bnr(GEN bnf, GEN A)
6390 : {
6391 37758 : GEN c = getrand(), bnr;
6392 37758 : setrand(gen_1);
6393 37758 : bnr = Buchray(bnf, A, nf_INIT|nf_GEN);
6394 37758 : setrand(c);
6395 37758 : return bnr;
6396 : }
6397 : /* Hecke xi * (D/.) = Dirichlet chi, return v in Q^r st chi(g_i) = e(v[i]).
6398 : * cycn = cyc_normalize_zv(bnr.cyc), chin = char_normalize_zv(chi,cyc) */
6399 : static GEN
6400 34489 : bnrchartwist2conrey(GEN chin, GEN cycn, GEN bnrconreyN, GEN kroconreyN)
6401 : {
6402 34489 : long l = lg(bnrconreyN), c1 = cycn[1], i;
6403 34489 : GEN v = cgetg(l, t_COL);
6404 125363 : for (i = 1; i < l; i++)
6405 : {
6406 90874 : GEN d = sstoQ(zv_dotproduct(chin, gel(bnrconreyN,i)), c1);
6407 90874 : if (kroconreyN[i] < 0) d = gadd(d, ghalf);
6408 90874 : gel(v,i) = d;
6409 : }
6410 34489 : return v;
6411 : }
6412 :
6413 : /* chi(g_i) = e(v[i]) denormalize wrt Conrey generators orders */
6414 : static GEN
6415 34489 : conreydenormalize(GEN znN, GEN v)
6416 : {
6417 34489 : GEN gcyc = znstar_get_conreycyc(znN), w;
6418 34489 : long l = lg(v), i;
6419 34489 : w = cgetg(l, t_COL);
6420 125363 : for (i = 1; i < l; i++)
6421 90874 : gel(w,i) = modii(gmul(gel(v,i), gel(gcyc,i)), gel(gcyc,i));
6422 34489 : return w;
6423 : }
6424 :
6425 : static long
6426 84028 : Miyake(GEN vchi, GEN gb, GEN cycn)
6427 : {
6428 84028 : long i, e = cycn[1], lb = lg(gb);
6429 84028 : GEN v = char_normalize_zv(vchi, cycn);
6430 124992 : for (i = 1; i < lb; i++)
6431 100268 : if ((zv_dotproduct(v, gel(gb,i)) - v[i]) % e) return 1;
6432 24724 : return 0;
6433 : }
6434 :
6435 : /* list of Hecke characters not induced by a Dirichlet character up to Galois
6436 : * conjugation, whose conductor is bnr.cond; cycn = cyc_normalize(bnr.cyc)*/
6437 : static GEN
6438 26810 : mklvchi(GEN bnr, GEN cycn, GEN gb)
6439 : {
6440 26810 : GEN cyc = bnr_get_cyc(bnr), cycsmall = ZV_to_zv(cyc);
6441 26810 : GEN vchi = cyc2elts(cycsmall);
6442 26810 : long ordmax = cycsmall[1], c, i, l;
6443 26810 : l = lg(vchi);
6444 304024 : for (i = c = 1; i < l; i++)
6445 : {
6446 277214 : GEN chi = gel(vchi,i);
6447 277214 : if (!gb || Miyake(chi, gb, cycn)) gel(vchi, c++) = Flv_to_ZV(chi);
6448 : }
6449 26810 : setlg(vchi, c); l = c;
6450 279300 : for (i = 1; i < l; i++)
6451 : {
6452 252490 : GEN chi = gel(vchi,i);
6453 : long n;
6454 252490 : if (!chi) continue;
6455 1055754 : for (n = 2; n < ordmax; n++)
6456 966476 : if (ugcd(n, ordmax) == 1)
6457 : {
6458 397670 : GEN tmp = ZV_ZV_mod(gmulsg(n, chi), cyc);
6459 : long j;
6460 7623539 : for (j = i+1; j < l; j++)
6461 7225869 : if (gel(vchi,j) && gequal(gel(vchi,j), tmp)) gel(vchi,j) = NULL;
6462 : }
6463 : }
6464 279300 : for (i = c = 1; i < l; i++)
6465 : {
6466 252490 : GEN chi = gel(vchi,i);
6467 252490 : if (chi && bnrisconductor(bnr, chi)) gel(vchi, c++) = chi;
6468 : }
6469 26810 : setlg(vchi, c); return vchi;
6470 : }
6471 :
6472 : static GEN
6473 7805 : get_gb(GEN bnr, GEN con)
6474 : {
6475 7805 : GEN gb, g = bnr_get_gen(bnr), nf = bnr_get_nf(bnr);
6476 7805 : long i, l = lg(g);
6477 7805 : gb = cgetg(l, t_VEC);
6478 18326 : for (i = 1; i < l; i++)
6479 10521 : gel(gb,i) = ZV_to_zv(isprincipalray(bnr, galoisapply(nf, con, gel(g,i))));
6480 7805 : return gb;
6481 : }
6482 : static GEN
6483 15862 : get_bnrconreyN(GEN bnr, GEN znN)
6484 : {
6485 15862 : GEN z, g = znstar_get_conreygen(znN);
6486 15862 : long i, l = lg(g);
6487 15862 : z = cgetg(l, t_VEC);
6488 57134 : for (i = 1; i < l; i++) gel(z,i) = ZV_to_zv(isprincipalray(bnr,gel(g,i)));
6489 15862 : return z;
6490 : }
6491 : /* con = NULL if D > 0 or if D < 0 and id != idcon. */
6492 : static GEN
6493 33698 : mfdihedralcommon(GEN bnf, GEN id, GEN znN, GEN kroconreyN, long N, long D, GEN con)
6494 : {
6495 33698 : GEN bnr = dihan_bnr(bnf, id), cyc = ZV_to_zv( bnr_get_cyc(bnr) );
6496 : GEN bnrconreyN, cycn, cycN, Lvchi, res, P, vT;
6497 : long j, ordmax, l, lc, deghecke, vt;
6498 :
6499 33698 : lc = lg(cyc); if (lc == 1) return NULL;
6500 26810 : cycn = cyc_normalize_zv(cyc);
6501 26810 : Lvchi = mklvchi(bnr, cycn, con? get_gb(bnr, con): NULL);
6502 26810 : l = lg(Lvchi);
6503 26810 : if (l == 1) return NULL;
6504 :
6505 15862 : bnrconreyN = get_bnrconreyN(bnr, znN);
6506 15862 : cycN = ZV_to_zv(znstar_get_cyc(znN));
6507 15862 : ordmax = cyc[1];
6508 15862 : vT = const_vec(odd(ordmax)? ordmax << 1: ordmax, NULL);
6509 15862 : vt = fetch_user_var("t");
6510 15862 : P = polcyclo(ordmax, vt);
6511 15862 : gel(vT,ordmax) = Qab_trace_init(ordmax, ordmax, P, P);
6512 15862 : deghecke = myeulerphiu(ordmax);
6513 15862 : res = cgetg(l, t_VEC);
6514 50351 : for (j = 1; j < l; j++)
6515 : {
6516 34489 : GEN T, v, vchi = ZV_to_zv(gel(Lvchi,j));
6517 34489 : GEN chi, chin = char_normalize_zv(vchi, cycn);
6518 : long o, vnum, k0, degrel;
6519 34489 : v = bnrchartwist2conrey(chin, cycn, bnrconreyN, kroconreyN);
6520 34489 : o = itou(Q_denom(v));
6521 34489 : T = gel(vT, o);
6522 34489 : if (!T) gel(vT,o) = T = Qab_trace_init(ordmax, o, P, polcyclo(o,vt));
6523 34489 : chi = conreydenormalize(znN, v);
6524 34489 : vnum = itou(znconreyexp(znN, chi));
6525 34489 : chi = ZV_to_zv(znconreychar(znN,chi));
6526 34489 : degrel = deghecke / degpol(gel(T,1));
6527 34489 : k0 = zv_cyc_minimize(cycN, chi, coprimes_zv(o));
6528 34489 : vnum = Fl_powu(vnum, k0, N);
6529 : /* encodes degrel forms: jdeg = 0..degrel-1 */
6530 34489 : gel(res,j) = mkvec3(mkvecsmalln(5, N, k0 % o, vnum, D, degrel),
6531 : id, mkvec3(cycn,chin,T));
6532 : }
6533 15862 : return res;
6534 : }
6535 :
6536 : static long
6537 49364 : is_cond(long D, long n)
6538 : {
6539 49364 : if (D > 0) return n != 4 || (D&7L) == 1;
6540 30114 : return n != 2 && n != 3 && (n != 4 || (D&7L)!=1);
6541 : }
6542 : /* Append to v all dihedral weight 1 forms coming from D, if fundamental.
6543 : * level in [l1, l2] */
6544 : static void
6545 18718 : append_dihedral(GEN v, long D, long l1, long l2)
6546 : {
6547 18718 : long Da = labs(D), no, i, numi, ct, min, max;
6548 : GEN bnf, con, vI, resall, arch1, arch2;
6549 : pari_sp av;
6550 :
6551 : /* min <= Nf <= max */
6552 18718 : max = l2 / Da;
6553 18718 : if (l1 == l2)
6554 : { /* assume Da | l2 */
6555 140 : min = max;
6556 140 : if (D > 0 && min < 3) return;
6557 : }
6558 : else /* assume l1 < l2 */
6559 18578 : min = (l1 + Da-1)/Da;
6560 18718 : if (!sisfundamental(D)) return;
6561 :
6562 5726 : av = avma;
6563 5726 : bnf = dihan_bnf(D);
6564 5726 : con = nf2_get_conj(bnf_get_nf(bnf));
6565 5726 : vI = ideallist(bnf, max);
6566 55090 : numi = 0; for (i = min; i <= max; i++) numi += lg(gel(vI, i)) - 1;
6567 5726 : if (D > 0)
6568 : {
6569 1428 : numi <<= 1;
6570 1428 : arch1 = mkvec2(gen_1,gen_0);
6571 1428 : arch2 = mkvec2(gen_0,gen_1);
6572 : }
6573 : else
6574 4298 : arch1 = arch2 = NULL;
6575 5726 : resall = cgetg(numi+1, t_VEC); ct = 1;
6576 55090 : for (no = min; no <= max; no++) if (is_cond(D, no))
6577 : {
6578 44646 : long N = Da*no, lc, lI;
6579 44646 : GEN I = gel(vI, no), znN = znstar0(utoipos(N), 1), conreyN, kroconreyN;
6580 :
6581 44646 : conreyN = znstar_get_conreygen(znN); lc = lg(conreyN);
6582 44646 : kroconreyN = cgetg(lc, t_VECSMALL);
6583 166054 : for (i = 1; i < lc; i++) kroconreyN[i] = krosi(D, gel(conreyN, i));
6584 44646 : lI = lg(I);
6585 87822 : for (i = 1; i < lI; i++)
6586 : {
6587 43176 : GEN id = gel(I, i), idcon, z;
6588 : long j;
6589 43176 : if (typ(id) == t_INT) continue;
6590 28182 : idcon = galoisapply(bnf, con, id);
6591 51408 : for (j = i; j < lI; j++)
6592 51408 : if (gequal(idcon, gel(I, j))) { gel(I, j) = gen_0; break; }
6593 28182 : if (D < 0)
6594 : {
6595 17479 : GEN conk = i == j ? con : NULL;
6596 17479 : z = mfdihedralcommon(bnf, id, znN, kroconreyN, N, D, conk);
6597 17479 : if (z) gel(resall, ct++) = z;
6598 : }
6599 : else
6600 : {
6601 : GEN ide;
6602 10703 : ide = mkvec2(id, arch1);
6603 10703 : z = mfdihedralcommon(bnf, ide, znN, kroconreyN, N, D, NULL);
6604 10703 : if (z) gel(resall, ct++) = z;
6605 10703 : if (gequal(idcon,id)) continue;
6606 5516 : ide = mkvec2(id, arch2);
6607 5516 : z = mfdihedralcommon(bnf, ide, znN, kroconreyN, N, D, NULL);
6608 5516 : if (z) gel(resall, ct++) = z;
6609 : }
6610 : }
6611 : }
6612 5726 : if (ct == 1) set_avma(av);
6613 : else
6614 : {
6615 4816 : setlg(resall, ct);
6616 4816 : vectrunc_append(v, gerepilecopy(av, shallowconcat1(resall)));
6617 : }
6618 : }
6619 :
6620 : static long
6621 42042 : di_N(GEN a) { return gel(a,1)[1]; }
6622 : static GEN
6623 14 : mfdihedral(long N)
6624 : {
6625 14 : GEN D = mydivisorsu(N), res = vectrunc_init(2*N);
6626 14 : long j, l = lg(D);
6627 105 : for (j = 2; j < l; j++)
6628 : { /* skip d = 1 */
6629 91 : long d = D[j];
6630 91 : if (d == 2) continue;
6631 84 : append_dihedral(res, -d, N,N);
6632 84 : if (d >= 5 && D[l-j] >= 3) append_dihedral(res, d, N,N); /* Nf >= 3 */
6633 : }
6634 14 : if (lg(res) > 1) res = shallowconcat1(res);
6635 14 : return res;
6636 : }
6637 : /* All primitive dihedral weight 1 forms of leven in [1, N], N > 1 */
6638 : static GEN
6639 14 : mfdihedralall(long N)
6640 : {
6641 14 : GEN res = vectrunc_init(2*N), z;
6642 : long D, ct, i;
6643 :
6644 13986 : for (D = -3; D >= -N; D--) append_dihedral(res, D, 1,N);
6645 : /* Nf >= 3 (GTM 193, prop 3.3.18) */
6646 4620 : for (D = N / 3; D >= 5; D--) append_dihedral(res, D, 1,N);
6647 14 : ct = lg(res);
6648 14 : if (ct > 1)
6649 : { /* sort wrt N */
6650 14 : res = shallowconcat1(res);
6651 14 : res = vecpermute(res, indexvecsort(res, mkvecsmall(1)));
6652 14 : ct = lg(res);
6653 : }
6654 14 : z = const_vec(N, cgetg(1,t_VEC));
6655 7658 : for (i = 1; i < ct;)
6656 : { /* regroup result sharing the same N */
6657 7644 : long n = di_N(gel(res,i)), j = i+1, k;
6658 : GEN v;
6659 34412 : while (j < ct && di_N(gel(res,j)) == n) j++;
6660 7644 : gel(z, n) = v = cgetg(j-i+1, t_VEC);
6661 42056 : for (k = 1; i < j; k++,i++) gel(v,k) = gel(res,i);
6662 : }
6663 14 : return z;
6664 : }
6665 :
6666 : /* return [vF, index], where vecpermute(vF,index) generates dihedral forms
6667 : * for character CHI */
6668 : static GEN
6669 24969 : mfdihedralnew_i(long N, GEN CHI, GEN SP)
6670 : {
6671 : GEN bnf, Tinit, Pm, vf, M, V, NK;
6672 : long Dold, d, ordw, i, SB, c, l, k0, k1, chino, chinoorig, lv;
6673 :
6674 24969 : lv = lg(SP); if (lv == 1) return NULL;
6675 12138 : CHI = mfcharinduce(CHI,N);
6676 12138 : ordw = mfcharorder(CHI);
6677 12138 : chinoorig = mfcharno(CHI);
6678 12138 : k0 = mfconreyminimize(CHI);
6679 12138 : chino = Fl_powu(chinoorig, k0, N);
6680 12138 : k1 = Fl_inv(k0 % ordw, ordw);
6681 12138 : V = cgetg(lv, t_VEC);
6682 12138 : d = 0;
6683 39039 : for (i = l = 1; i < lv; i++)
6684 : {
6685 26901 : GEN sp = gel(SP,i), T = gel(sp,1);
6686 26901 : if (T[3] != chino) continue;
6687 4060 : d += T[5];
6688 4060 : if (k1 != 1)
6689 : {
6690 77 : GEN t = leafcopy(T);
6691 77 : t[3] = chinoorig;
6692 77 : t[2] = (t[2]*k1) % ordw;
6693 77 : sp = mkvec4(t, gel(sp,2), gel(sp,3), gel(sp,4));
6694 : }
6695 4060 : gel(V, l++) = sp;
6696 : }
6697 12138 : setlg(V, l); /* dihedral forms of level N and character CHI */
6698 12138 : if (l == 1) return NULL;
6699 :
6700 2555 : SB = mfsturmNk(N,1) + 1;
6701 2555 : M = cgetg(d+1, t_MAT);
6702 2555 : vf = cgetg(d+1, t_VEC);
6703 2555 : NK = mkNK(N, 1, CHI);
6704 2555 : bnf = NULL; Dold = 0;
6705 6615 : for (i = c = 1; i < l; i++)
6706 : { /* T = [N, k0, conreyno, D, degrel] */
6707 4060 : GEN bnr, Vi = gel(V,i), T = gel(Vi,1), id = gel(Vi,2), w = gel(Vi,3);
6708 4060 : long jdeg, k0i = T[2], D = T[4], degrel = T[5];
6709 :
6710 4060 : if (D != Dold) { Dold = D; bnf = dihan_bnf(D); }
6711 4060 : bnr = dihan_bnr(bnf, id);
6712 12054 : for (jdeg = 0; jdeg < degrel; jdeg++,c++)
6713 : {
6714 7994 : GEN k0j = mkvecsmall2(k0i, jdeg), an = dihan(bnr, w, k0j, ordw, SB);
6715 7994 : settyp(an, t_COL); gel(M,c) = an;
6716 7994 : gel(vf,c) = tag3(t_MF_DIHEDRAL, NK, bnr, w, k0j);
6717 : }
6718 : }
6719 2555 : Tinit = gmael3(V,1,3,3); Pm = gel(Tinit,1);
6720 2555 : V = QabM_indexrank(M, degpol(Pm)==1? NULL: Pm, ordw);
6721 2555 : return mkvec2(vf,gel(V,2));
6722 : }
6723 : static long
6724 16149 : mfdihedralnewdim(long N, GEN CHI, GEN SP)
6725 : {
6726 16149 : pari_sp av = avma;
6727 16149 : GEN S = mfdihedralnew_i(N, CHI, SP);
6728 16149 : return gc_long(av, S? lg(gel(S,2))-1: 0);
6729 : }
6730 : static GEN
6731 8820 : mfdihedralnew(long N, GEN CHI, GEN SP)
6732 : {
6733 8820 : pari_sp av = avma;
6734 8820 : GEN S = mfdihedralnew_i(N, CHI, SP);
6735 8820 : if (!S) { set_avma(av); return cgetg(1, t_VEC); }
6736 917 : return vecpermute(gel(S,1), gel(S,2));
6737 : }
6738 :
6739 : static long
6740 7105 : mfdihedralcuspdim(long N, GEN CHI, GEN vSP)
6741 : {
6742 7105 : pari_sp av = avma;
6743 : GEN D, CHIP;
6744 : long F, i, lD, dim;
6745 :
6746 7105 : CHIP = mfchartoprimitive(CHI, &F);
6747 7105 : D = mydivisorsu(N/F); lD = lg(D);
6748 7105 : dim = mfdihedralnewdim(N, CHI, gel(vSP,N)); /* d = 1 */
6749 16149 : for (i = 2; i < lD; i++)
6750 : {
6751 9044 : long d = D[i], a = mfdihedralnewdim(N/d, CHIP, gel(vSP, N/d));
6752 9044 : if (a) dim += a * mynumdivu(d);
6753 : }
6754 7105 : return gc_long(av,dim);
6755 : }
6756 :
6757 : static GEN
6758 7343 : mfbdall(GEN E, long N)
6759 : {
6760 7343 : GEN v, D = mydivisorsu(N);
6761 7343 : long i, j, nD = lg(D) - 1, nE = lg(E) - 1;
6762 7343 : v = cgetg(nD*nE + 1, t_VEC);
6763 10416 : for (j = 1; j <= nE; j++)
6764 : {
6765 3073 : GEN Ej = gel(E, j);
6766 9415 : for (i = 0; i < nD; i++) gel(v, i*nE + j) = mfbd_i(Ej, D[i+1]);
6767 : }
6768 7343 : return v;
6769 : }
6770 : static GEN
6771 3857 : mfdihedralcusp(long N, GEN CHI, GEN vSP)
6772 : {
6773 3857 : pari_sp av = avma;
6774 : GEN D, CHIP, z;
6775 : long F, i, lD;
6776 :
6777 3857 : CHIP = mfchartoprimitive(CHI, &F);
6778 3857 : D = mydivisorsu(N/F); lD = lg(D);
6779 3857 : z = cgetg(lD, t_VEC);
6780 3857 : gel(z,1) = mfdihedralnew(N, CHI, gel(vSP,N));
6781 8596 : for (i = 2; i < lD; i++) /* skip 1 */
6782 : {
6783 4739 : GEN LF = mfdihedralnew(N / D[i], CHIP, gel(vSP, N / D[i]));
6784 4739 : gel(z,i) = mfbdall(LF, D[i]);
6785 : }
6786 3857 : return gerepilecopy(av, shallowconcat1(z));
6787 : }
6788 :
6789 : /* used to decide between ratlift and comatrix for ZM_inv; ratlift is better
6790 : * when N has many divisors */
6791 : static int
6792 2506 : abundant(ulong N) { return mynumdivu(N) >= 8; }
6793 :
6794 : /* CHI an mfchar */
6795 : static int
6796 371 : cmp_ord(void *E, GEN a, GEN b)
6797 : {
6798 371 : GEN chia = MF_get_CHI(a), chib = MF_get_CHI(b);
6799 371 : (void)E; return cmpii(gmfcharorder(chia), gmfcharorder(chib));
6800 : }
6801 : /* mfinit structure.
6802 : -- mf[1] contains [N,k,CHI,space],
6803 : -- mf[2] contains vector of closures of Eisenstein series, empty if not
6804 : full space.
6805 : -- mf[3] contains vector of closures, so #mf[3] = dimension of cusp/new space.
6806 : -- mf[4] contains the corresponding indices: either j for T(j)tf if newspace,
6807 : or [M,j,d] for B(d)T(j)tf_M if cuspspace or oldspace.
6808 : -- mf[5] contains the matrix M of first coefficients of basis, never cleaned.
6809 : * NK is either [N,k] or [N,k,CHI].
6810 : * mfinit does not do the splitting, only the basis generation. */
6811 :
6812 : /* Set flraw to 1 if do not need mf[5]: no mftobasis etc..., only the
6813 : expansions of the basis elements are needed. */
6814 :
6815 : static GEN
6816 4928 : mfinit_Nkchi(long N, long k, GEN CHI, long space, long flraw)
6817 : {
6818 4928 : GEN M = NULL, mf = NULL, mf1 = mkvec4(utoi(N), stoi(k), CHI, utoi(space));
6819 4928 : long sb = mfsturmNk(N, k);
6820 4928 : if (k < 0 || badchar(N, k, CHI)) return mfEMPTY(mf1);
6821 4893 : if (k == 0 || space == mf_EISEN) /*nothing*/;
6822 4732 : else if (k == 1)
6823 : {
6824 364 : switch (space)
6825 : {
6826 350 : case mf_NEW:
6827 : case mf_FULL:
6828 350 : case mf_CUSP: mf = mf1init(N, CHI, NULL, get_vDIH(N,NULL), space, flraw);
6829 350 : break;
6830 7 : case mf_OLD: pari_err_IMPL("mfinit in weight 1 for old space");
6831 7 : default: pari_err_FLAG("mfinit");
6832 : }
6833 : }
6834 : else /* k >= 2 */
6835 : {
6836 4368 : long ord = mfcharorder(CHI);
6837 4368 : GEN z = NULL, P = (ord <= 2)? NULL: mfcharpol(CHI);
6838 : cachenew_t cache;
6839 4368 : switch(space)
6840 : {
6841 1204 : case mf_NEW:
6842 1204 : mf = mfnewinit(N, k, CHI, &cache, 1);
6843 1204 : if (mf && !flraw) { M = MF_get_M(mf); z = MF_get_Mindex(mf); }
6844 1204 : break;
6845 3157 : case mf_OLD:
6846 : case mf_CUSP:
6847 : case mf_FULL:
6848 3157 : if (!(mf = mfinitcusp(N, k, CHI, &cache, space))) break;
6849 2856 : if (!flraw)
6850 : {
6851 2205 : M = bhnmat_extend(M, sb+1, 1, MF_get_S(mf), &cache);
6852 2205 : if (space != mf_FULL) gel(mf,5) = mfcleanCHI(M, CHI, abundant(N));
6853 : }
6854 2856 : dbg_cachenew(&cache); break;
6855 7 : default: pari_err_FLAG("mfinit");
6856 : }
6857 4361 : if (z) gel(mf,5) = mfclean2(M, z, P, ord);
6858 : }
6859 4872 : if (!mf) mf = mfEMPTY(mf1);
6860 : else
6861 : {
6862 3913 : gel(mf,1) = mf1;
6863 3913 : if (flraw) gel(mf,5) = zerovec(3);
6864 : }
6865 4872 : if (!space_is_cusp(space))
6866 : {
6867 819 : GEN E = mfeisensteinbasis(N, k, CHI);
6868 819 : gel(mf,2) = E;
6869 819 : if (!flraw)
6870 : {
6871 497 : if (M)
6872 196 : M = shallowconcat(mfvectomat(E, sb+1, 1), M);
6873 : else
6874 301 : M = mfcoefs_mf(mf, sb+1, 1);
6875 497 : gel(mf,5) = mfcleanCHI(M, CHI, abundant(N));
6876 : }
6877 : }
6878 4872 : return mf;
6879 : }
6880 :
6881 : /* mfinit for k = nk/dk */
6882 : static GEN
6883 2639 : mfinit_Nndkchi(long N, long nk, long dk, GEN CHI, long space, long flraw)
6884 266 : { return (dk == 2)? mf2init_Nkchi(N, nk >> 1, CHI, space, flraw)
6885 2905 : : mfinit_Nkchi(N, nk, CHI, space, flraw); }
6886 : static GEN
6887 3304 : mfinit_i(GEN NK, long space)
6888 : {
6889 : GEN CHI, mf;
6890 : long N, k, dk, joker;
6891 3304 : if (checkmf_i(NK))
6892 : {
6893 147 : N = mf_get_N(NK);
6894 147 : Qtoss(mf_get_gk(NK), &k, &dk);
6895 147 : CHI = mf_get_CHI(NK);
6896 : }
6897 3157 : else if ((mf = checkMF_i(NK)))
6898 : {
6899 21 : long s = MF_get_space(mf);
6900 21 : if (s == space) return mf;
6901 21 : Qtoss(MF_get_gk(mf), &k, &dk);
6902 21 : if (dk == 1 && k > 1 && space == mf_NEW && (s == mf_CUSP || s == mf_FULL))
6903 21 : return mfinittonew(mf);
6904 0 : N = MF_get_N(mf);
6905 0 : CHI = MF_get_CHI(mf);
6906 : }
6907 : else
6908 3136 : checkNK2(NK, &N, &k, &dk, &CHI, 1);
6909 3262 : joker = !CHI || typ(CHI) == t_COL;
6910 3262 : if (joker)
6911 : {
6912 1162 : GEN mf, vCHI = CHI;
6913 : long i, j, l;
6914 1162 : if (CHI && lg(CHI) == 1) return cgetg(1,t_VEC);
6915 1155 : if (k < 0) return mfEMPTYall(N, uutoQ(k,dk), CHI, space);
6916 1141 : if (k == 1 && dk == 1 && space != mf_EISEN)
6917 504 : {
6918 : GEN TMP, vSP, gN, gs;
6919 : pari_timer tt;
6920 1106 : if (space != mf_CUSP && space != mf_NEW)
6921 0 : pari_err_IMPL("mfinit([N,1,wildcard], space != cusp or new space)");
6922 1106 : if (wt1empty(N)) return mfEMPTYall(N, gen_1, CHI, space);
6923 504 : vCHI = mf1chars(N,vCHI);
6924 504 : l = lg(vCHI); mf = cgetg(l, t_VEC); if (l == 1) return mf;
6925 504 : TMP = mf1_pre(N); vSP = get_vDIH(N, NULL);
6926 504 : gN = utoipos(N); gs = utoi(space);
6927 504 : if (DEBUGLEVEL) timer_start(&tt);
6928 4123 : for (i = j = 1; i < l; i++)
6929 : {
6930 3619 : pari_sp av = avma;
6931 3619 : GEN c = gel(vCHI,i), z = mf1init(N, c, TMP, vSP, space, 0);
6932 3619 : if (z) z = gerepilecopy(av, z);
6933 : else
6934 : {
6935 2905 : set_avma(av);
6936 2905 : if (CHI) z = mfEMPTY(mkvec4(gN,gen_1,c,gs));
6937 : }
6938 3619 : if (z) gel(mf, j++) = z;
6939 3619 : if (DEBUGLEVEL)
6940 0 : timer_printf(&tt, "mf1basis: character %ld / %ld (order = %ld)",
6941 : i, l-1, mfcharorder(c));
6942 : }
6943 : }
6944 : else
6945 : {
6946 35 : vCHI = mfchars(N,k,dk,vCHI);
6947 35 : l = lg(vCHI); mf = cgetg(l, t_VEC);
6948 119 : for (i = j = 1; i < l; i++)
6949 : {
6950 84 : pari_sp av = avma;
6951 84 : GEN v = mfinit_Nndkchi(N, k, dk, gel(vCHI,i), space, 0);
6952 84 : if (MF_get_dim(v) || CHI) gel(mf, j++) = v; else set_avma(av);
6953 : }
6954 : }
6955 539 : setlg(mf,j);
6956 539 : if (!CHI) gen_sort_inplace(mf, NULL, &cmp_ord, NULL);
6957 539 : return mf;
6958 : }
6959 2100 : return mfinit_Nndkchi(N, k, dk, CHI, space, 0);
6960 : }
6961 : GEN
6962 2345 : mfinit(GEN NK, long space)
6963 : {
6964 2345 : pari_sp av = avma;
6965 2345 : return gerepilecopy(av, mfinit_i(NK, space));
6966 : }
6967 :
6968 : /* UTILITY FUNCTIONS */
6969 : static void
6970 364 : cusp_canon(GEN cusp, long N, long *pA, long *pC)
6971 : {
6972 364 : pari_sp av = avma;
6973 : long A, C, tc, cg;
6974 364 : if (N <= 0) pari_err_DOMAIN("mfcuspwidth","N","<=",gen_0,stoi(N));
6975 357 : if (!cusp || (tc = typ(cusp)) == t_INFINITY) { *pA = 1; *pC = N; return; }
6976 350 : if (tc != t_INT && tc != t_FRAC) pari_err_TYPE("checkcusp", cusp);
6977 350 : Qtoss(cusp, &A,&C);
6978 350 : if (N % C)
6979 : {
6980 : ulong uC;
6981 14 : long u = Fl_invgen((C-1)%N + 1, N, &uC);
6982 14 : A = Fl_mul(A, u, N);
6983 14 : C = (long)uC;
6984 : }
6985 350 : cg = ugcd(C, N/C);
6986 420 : while (ugcd(A, N) > 1) A += cg;
6987 350 : *pA = A % N; *pC = C; set_avma(av);
6988 : }
6989 : static long
6990 945 : mfcuspcanon_width(long N, long C)
6991 945 : { return (!C || C == N)? 1 : N / ugcd(N, Fl_sqr(umodsu(C,N),N)); }
6992 : /* v = [a,c] a ZC, width of cusp (a:c) */
6993 : static long
6994 8806 : mfZC_width(long N, GEN v)
6995 : {
6996 8806 : ulong C = umodiu(gel(v,2), N);
6997 8806 : return (C == 0)? 1: N / ugcd(N, Fl_sqr(C,N));
6998 : }
6999 : long
7000 161 : mfcuspwidth(GEN gN, GEN cusp)
7001 : {
7002 161 : long N = 0, A, C;
7003 : GEN mf;
7004 161 : if (typ(gN) == t_INT) N = itos(gN);
7005 42 : else if ((mf = checkMF_i(gN))) N = MF_get_N(mf);
7006 0 : else pari_err_TYPE("mfcuspwidth", gN);
7007 161 : cusp_canon(cusp, N, &A, &C);
7008 154 : return mfcuspcanon_width(N, C);
7009 : }
7010 :
7011 : /* Q a t_INT */
7012 : static GEN
7013 14 : findq(GEN al, GEN Q)
7014 : {
7015 : long n;
7016 14 : if (typ(al) == t_FRAC && cmpii(gel(al,2), Q) <= 0)
7017 0 : return mkvec(mkvec2(gel(al,1), gel(al,2)));
7018 14 : n = 1 + (long)ceil(2.0781*gtodouble(glog(Q, LOWDEFAULTPREC)));
7019 14 : return contfracpnqn(gboundcf(al,n), n);
7020 : }
7021 : static GEN
7022 91 : findqga(long N, GEN z)
7023 : {
7024 91 : GEN Q, LDC, CK = NULL, DK = NULL, ma, x, y = imag_i(z);
7025 : long j, l;
7026 91 : if (gcmpgs(gmulsg(2*N, y), 1) >= 0) return NULL;
7027 14 : x = real_i(z);
7028 14 : Q = ground(ginv(gsqrt(gmulsg(N, y), LOWDEFAULTPREC)));
7029 14 : LDC = findq(gmulsg(-N,x), Q);
7030 14 : ma = gen_1; l = lg(LDC);
7031 35 : for (j = 1; j < l; j++)
7032 : {
7033 21 : GEN D, DC = gel(LDC,j), C1 = gel(DC,2);
7034 21 : if (cmpii(C1,Q) > 0) break;
7035 21 : D = gel(DC,1);
7036 21 : if (ugcdiu(D,N) == 1)
7037 : {
7038 7 : GEN C = mului(N, C1), den;
7039 7 : den = gadd(gsqr(gmul(C,y)), gsqr(gadd(D, gmul(C,x))));
7040 7 : if (gcmp(den, ma) < 0) { ma = den; CK = C; DK = D; }
7041 : }
7042 : }
7043 14 : return DK? mkvec2(CK, DK): NULL;
7044 : }
7045 :
7046 : static long
7047 168 : valNC2(GEN P, GEN E, long e)
7048 : {
7049 168 : long i, d = 1, l = lg(P);
7050 504 : for (i = 1; i < l; i++)
7051 : {
7052 336 : long v = u_lval(e, P[i]) << 1;
7053 336 : if (v == E[i] + 1) v--;
7054 336 : d *= upowuu(P[i], v);
7055 : }
7056 168 : return d;
7057 : }
7058 :
7059 : static GEN
7060 49 : findqganew(long N, GEN z)
7061 : {
7062 49 : GEN MI, DI, x = real_i(z), y = imag_i(z), Ck = gen_0, Dk = gen_1, fa, P, E;
7063 : long i;
7064 49 : MI = uutoQ(1,N);
7065 49 : DI = mydivisorsu(mysqrtu(N));
7066 49 : fa = myfactoru(N); P = gel(fa,1); E = gel(fa,2);
7067 217 : for (i = 1; i < lg(DI); i++)
7068 : {
7069 168 : long e = DI[i], g;
7070 : GEN U, C, D, m;
7071 168 : (void)cxredsl2(gmulsg(e, z), &U);
7072 168 : C = gcoeff(U,2,1); if (!signe(C)) continue;
7073 168 : D = gcoeff(U,2,2);
7074 168 : g = ugcdiu(D,e);
7075 168 : if (g > 1) { C = muliu(C,e/g); D = diviuexact(D,g); } else C = muliu(C,e);
7076 168 : m = gadd(gsqr(gadd(gmul(C, x), D)), gsqr(gmul(C, y)));
7077 168 : m = gdivgu(m, valNC2(P, E, e));
7078 168 : if (gcmp(m, MI) < 0) { MI = m; Ck = C; Dk = D; }
7079 : }
7080 49 : return signe(Ck)? mkvec2(Ck, Dk): NULL;
7081 : }
7082 :
7083 : /* Return z' and U = [a,b;c,d] \in SL_2(Z), z' = U*z,
7084 : * Im(z')/width(U.oo) > sqrt(3)/(2N). Set *pczd = c*z+d */
7085 : static GEN
7086 175 : cxredga0N(long N, GEN z, GEN *pU, GEN *pczd, long flag)
7087 : {
7088 175 : GEN v = NULL, A, B, C, D;
7089 : long e;
7090 175 : if (N == 1) return cxredsl2_i(z, pU, pczd);
7091 140 : e = gexpo(gel(z,2));
7092 140 : if (e < 0) z = gprec_wensure(z, precision(z) + nbits2extraprec(-e));
7093 140 : v = flag? findqganew(N,z): findqga(N,z);
7094 140 : if (!v) { *pU = matid(2); *pczd = gen_1; return z; }
7095 56 : C = gel(v,1);
7096 56 : D = gel(v,2);
7097 56 : if (!is_pm1(bezout(C,D, &B,&A))) pari_err_BUG("cxredga0N [gcd > 1]");
7098 56 : B = negi(B);
7099 56 : *pU = mkmat2(mkcol2(A,C), mkcol2(B,D));
7100 56 : *pczd = gadd(gmul(C,z), D);
7101 56 : return gdiv(gadd(gmul(A,z), B), *pczd);
7102 : }
7103 :
7104 : static GEN
7105 154 : lfunthetaall(GEN b, GEN vL, GEN t, long bitprec)
7106 : {
7107 154 : long i, l = lg(vL);
7108 154 : GEN v = cgetg(l, t_VEC);
7109 336 : for (i = 1; i < l; i++)
7110 : {
7111 182 : GEN T, L = gel(vL,i), a0 = gel(L,1), ldata = gel(L,2);
7112 182 : GEN van = gel(ldata_get_an(ldata),2);
7113 182 : if (lg(van) == 1)
7114 : {
7115 0 : T = gmul(b, a0);
7116 0 : if (isexactzero(T)) { GEN z = real_0_bit(-bitprec); T = mkcomplex(z,z); }
7117 : }
7118 : else
7119 : {
7120 182 : T = gmul2n(lfuntheta(ldata, t, 0, bitprec), -1);
7121 182 : T = gmul(b, gadd(a0, T));
7122 : }
7123 182 : gel(v,i) = T;
7124 : }
7125 154 : return l == 2? gel(v,1): v;
7126 : }
7127 :
7128 : /* P in ZX, irreducible */
7129 : static GEN
7130 182 : ZX_roots(GEN P, long prec)
7131 : {
7132 182 : long d = degpol(P);
7133 182 : if (d == 1) return mkvec(gen_0);
7134 182 : if (d == 2 && isint1(gel(P,2)) && isintzero(gel(P,3)) && isint1(gel(P,4)))
7135 7 : return mkvec2(powIs(3), gen_I()); /* order as polroots */
7136 294 : return (ZX_sturm_irred(P) == d)? ZX_realroots_irred(P, prec)
7137 294 : : QX_complex_roots(P, prec);
7138 : }
7139 : /* initializations for RgX_RgV_eval / RgC_embed */
7140 : static GEN
7141 217 : rootspowers(GEN v)
7142 : {
7143 217 : long i, l = lg(v);
7144 217 : GEN w = cgetg(l, t_VEC);
7145 868 : for (i = 1; i < l; i++) gel(w,i) = gpowers(gel(v,i), l-2);
7146 217 : return w;
7147 : }
7148 : /* mf embeddings attached to Q(chi)/(T), chi attached to cyclotomic P */
7149 : static GEN
7150 889 : getembed(GEN P, GEN T, GEN zcyclo, long prec)
7151 : {
7152 : long i, l;
7153 : GEN v;
7154 889 : if (degpol(P) == 1) P = NULL; /* mfcharpol for quadratic char */
7155 889 : if (degpol(T) == 1) T = NULL; /* dim 1 orbit */
7156 889 : if (T && P)
7157 35 : { /* K(y) / (T(y)), K = Q(t)/(P) cyclotomic */
7158 35 : GEN vr = RgX_is_ZX(T)? ZX_roots(T,prec): roots(RgX_embed1(T,zcyclo), prec);
7159 35 : v = rootspowers(vr); l = lg(v);
7160 105 : for (i = 1; i < l; i++) gel(v,i) = mkcol3(P,zcyclo,gel(v,i));
7161 : }
7162 854 : else if (T)
7163 : { /* Q(y) / (T(y)), T noncyclotomic */
7164 182 : GEN vr = ZX_roots(T, prec);
7165 182 : v = rootspowers(vr); l = lg(v);
7166 763 : for (i = 1; i < l; i++) gel(v,i) = mkcol2(T, gel(v,i));
7167 : }
7168 : else /* cyclotomic or rational */
7169 672 : v = mkvec(P? mkvec2(P, zcyclo): cgetg(1,t_VEC));
7170 889 : return v;
7171 : }
7172 : static GEN
7173 742 : grootsof1_CHI(GEN CHI, long prec)
7174 742 : { return grootsof1(mfcharorder(CHI), prec); }
7175 : /* return the [Q(F):Q(chi)] embeddings of F */
7176 : static GEN
7177 581 : mfgetembed(GEN F, long prec)
7178 : {
7179 581 : GEN T = mf_get_field(F), CHI = mf_get_CHI(F), P = mfcharpol(CHI);
7180 581 : return getembed(P, T, grootsof1_CHI(CHI, prec), prec);
7181 : }
7182 : static GEN
7183 7 : mfchiembed(GEN mf, long prec)
7184 : {
7185 7 : GEN CHI = MF_get_CHI(mf), P = mfcharpol(CHI);
7186 7 : return getembed(P, pol_x(0), grootsof1_CHI(CHI, prec), prec);
7187 : }
7188 : /* mfgetembed for the successive eigenforms in MF_get_newforms */
7189 : static GEN
7190 154 : mfeigenembed(GEN mf, long prec)
7191 : {
7192 154 : GEN vP = MF_get_fields(mf), vF = MF_get_newforms(mf);
7193 154 : GEN zcyclo, vE, CHI = MF_get_CHI(mf), P = mfcharpol(CHI);
7194 154 : long i, l = lg(vP);
7195 154 : vF = Q_remove_denom(liftpol_shallow(vF), NULL);
7196 154 : prec += nbits2extraprec(gexpo(vF));
7197 154 : zcyclo = grootsof1_CHI(CHI, prec);
7198 154 : vE = cgetg(l, t_VEC);
7199 455 : for (i = 1; i < l; i++) gel(vE,i) = getembed(P, gel(vP,i), zcyclo, prec);
7200 154 : return vE;
7201 : }
7202 :
7203 : static int
7204 28 : checkPv(GEN P, GEN v)
7205 28 : { return typ(P) == t_POL && is_vec_t(typ(v)) && lg(v)-1 >= degpol(P); }
7206 : static int
7207 28 : checkemb_i(GEN E)
7208 : {
7209 28 : long t = typ(E), l = lg(E);
7210 28 : if (t == t_VEC) return l == 1 || (l == 3 && checkPv(gel(E,1), gel(E,2)));
7211 21 : if (t != t_COL) return 0;
7212 21 : if (l == 3) return checkPv(gel(E,1), gel(E,2));
7213 21 : return l == 4 && is_vec_t(typ(gel(E,2))) && checkPv(gel(E,1), gel(E,3));
7214 : }
7215 : static GEN
7216 28 : anyembed(GEN v, GEN E)
7217 : {
7218 28 : switch(typ(v))
7219 : {
7220 21 : case t_VEC: case t_COL: return mfvecembed(E, v);
7221 7 : case t_MAT: return mfmatembed(E, v);
7222 : }
7223 0 : return mfembed(E, v);
7224 : }
7225 : GEN
7226 49 : mfembed0(GEN E, GEN v, long prec)
7227 : {
7228 49 : pari_sp av = avma;
7229 49 : GEN mf, vE = NULL;
7230 49 : if (checkmf_i(E)) vE = mfgetembed(E, prec);
7231 35 : else if ((mf = checkMF_i(E))) vE = mfchiembed(mf, prec);
7232 49 : if (vE)
7233 : {
7234 21 : long i, l = lg(vE);
7235 : GEN w;
7236 21 : if (!v) return gerepilecopy(av, l == 2? gel(vE,1): vE);
7237 0 : w = cgetg(l, t_VEC);
7238 0 : for (i = 1; i < l; i++) gel(w,i) = anyembed(v, gel(vE,i));
7239 0 : return gerepilecopy(av, l == 2? gel(w,1): w);
7240 : }
7241 28 : if (!checkemb_i(E) || !v) pari_err_TYPE("mfembed", E);
7242 28 : return gerepilecopy(av, anyembed(v,E));
7243 : }
7244 :
7245 : /* dummy lfun create for theta evaluation */
7246 : static GEN
7247 924 : mfthetaancreate(GEN van, GEN N, GEN k)
7248 : {
7249 924 : GEN L = zerovec(6);
7250 924 : gel(L,1) = lfuntag(t_LFUN_GENERIC, van);
7251 924 : gel(L,3) = mkvec2(gen_0, gen_1);
7252 924 : gel(L,4) = k;
7253 924 : gel(L,5) = N; return L;
7254 : }
7255 : /* destroy van and prepare to evaluate theta(sigma(van)), for all sigma in
7256 : * embeddings vector vE */
7257 : static GEN
7258 329 : van_embedall(GEN van, GEN vE, GEN gN, GEN gk)
7259 : {
7260 329 : GEN a0 = gel(van,1), vL;
7261 329 : long i, lE = lg(vE), l = lg(van);
7262 329 : van++; van[0] = evaltyp(t_VEC) | evallg(l-1); /* remove a0 */
7263 329 : vL = cgetg(lE, t_VEC);
7264 889 : for (i = 1; i < lE; i++)
7265 : {
7266 560 : GEN E = gel(vE,i), v = mfvecembed(E, van);
7267 560 : gel(vL,i) = mkvec2(mfembed(E,a0), mfthetaancreate(v, gN, gk));
7268 : }
7269 329 : return vL;
7270 : }
7271 :
7272 : static int
7273 1064 : cusp_AC(GEN cusp, long *A, long *C)
7274 : {
7275 1064 : switch(typ(cusp))
7276 : {
7277 119 : case t_INFINITY: *A = 1; *C = 0; break;
7278 273 : case t_INT: *A = itos(cusp); *C = 1; break;
7279 448 : case t_FRAC: *A = itos(gel(cusp, 1)); *C = itos(gel(cusp, 2)); break;
7280 224 : case t_REAL: case t_COMPLEX:
7281 224 : *A = 0; *C = 0;
7282 224 : if (gsigne(imag_i(cusp)) <= 0)
7283 7 : pari_err_DOMAIN("mfeval","imag(tau)","<=",gen_0,cusp);
7284 217 : return 0;
7285 0 : default: pari_err_TYPE("cusp_AC", cusp);
7286 : }
7287 840 : return 1;
7288 : }
7289 : static GEN
7290 518 : cusp2mat(long A, long C)
7291 : { long B, D;
7292 518 : cbezout(A, C, &D, &B);
7293 518 : return mkmat22s(A, -B, C, D);
7294 : }
7295 : static GEN
7296 21 : mkS(void) { return mkmat22s(0,-1,1,0); }
7297 :
7298 : /* if t is a cusp, return F(t), else NULL */
7299 : static GEN
7300 350 : evalcusp(GEN mf, GEN F, GEN t, long prec)
7301 : {
7302 : long A, C;
7303 : GEN R;
7304 350 : if (!cusp_AC(t, &A,&C)) return NULL;
7305 189 : if (C % mf_get_N(F) == 0) return gel(mfcoefs_i(F, 0, 1), 1);
7306 175 : R = mfgaexpansion(mf, F, cusp2mat(A,C), 0, prec);
7307 175 : return gequal0(gel(R,1))? gmael(R,3,1): gen_0;
7308 : }
7309 : /* Evaluate an mf closure numerically, i.e., in the usual sense, either for a
7310 : * single tau or a vector of tau; for each, return a vector of results
7311 : * corresponding to all complex embeddings of F. If flag is nonzero, allow
7312 : * replacing F by F | gamma to increase imag(gamma^(-1).tau) [ expensive if
7313 : * MF_EISENSPACE not present ] */
7314 : static GEN
7315 161 : mfeval_i(GEN mf, GEN F, GEN vtau, long flag, long bitprec)
7316 : {
7317 : GEN L0, vL, vb, sqN, vczd, vTAU, vs, van, vE;
7318 161 : long N = MF_get_N(mf), N0, ta, lv, i, prec = nbits2prec(bitprec);
7319 161 : GEN gN = utoipos(N), gk = mf_get_gk(F), gk1 = gsubgs(gk,1), vgk;
7320 161 : long flscal = 0;
7321 :
7322 : /* gen_0 is ignored, second component assumes Ramanujan-Petersson in
7323 : * 1/2-integer weight */
7324 161 : vgk = mkvec2(gen_0, mfiscuspidal(mf,F)? gmul2n(gk1,-1): gk1);
7325 161 : ta = typ(vtau);
7326 161 : if (!is_vec_t(ta)) { flscal = 1; vtau = mkvec(vtau); ta = t_VEC; }
7327 161 : lv = lg(vtau);
7328 161 : sqN = sqrtr_abs(utor(N, prec));
7329 161 : vs = const_vec(lv-1, NULL);
7330 161 : vb = const_vec(lv-1, NULL);
7331 161 : vL = cgetg(lv, t_VEC);
7332 161 : vTAU = cgetg(lv, t_VEC);
7333 161 : vczd = cgetg(lv, t_VEC);
7334 161 : L0 = mfthetaancreate(NULL, gN, vgk); /* only for thetacost */
7335 161 : vE = mfgetembed(F, prec);
7336 161 : N0 = 0;
7337 343 : for (i = 1; i < lv; i++)
7338 : {
7339 189 : GEN z = gel(vtau,i), tau, U;
7340 : long w, n;
7341 :
7342 189 : gel(vs,i) = evalcusp(mf, F, z, prec);
7343 182 : if (gel(vs,i)) continue;
7344 154 : tau = cxredga0N(N, z, &U, &gel(vczd,i), flag);
7345 154 : if (!flag) w = 0; else { w = mfZC_width(N, gel(U,1)); tau = gdivgu(tau,w); }
7346 154 : gel(vTAU,i) = mulcxmI(gmul(tau, sqN));
7347 154 : n = lfunthetacost(L0, real_i(gel(vTAU,i)), 0, bitprec);
7348 154 : if (N0 < n) N0 = n;
7349 154 : if (flag)
7350 : {
7351 42 : GEN A, al, v = mfslashexpansion(mf, F, ZM_inv(U,NULL), n, 0, &A, prec);
7352 42 : gel(vL,i) = van_embedall(v, vE, gN, vgk);
7353 42 : al = gel(A,1);
7354 42 : if (!gequal0(al))
7355 7 : gel(vb,i) = gexp(gmul(gmul(gmulsg(w,al),PiI2(prec)), tau), prec);
7356 : }
7357 : }
7358 154 : if (!flag)
7359 : {
7360 112 : van = mfcoefs_i(F, N0, 1);
7361 112 : vL = const_vec(lv-1, van_embedall(van, vE, gN, vgk));
7362 : }
7363 336 : for (i = 1; i < lv; i++)
7364 : {
7365 : GEN T;
7366 182 : if (gel(vs,i)) continue;
7367 154 : T = gpow(gel(vczd,i), gneg(gk), prec);
7368 154 : if (flag && gel(vb,i)) T = gmul(T, gel(vb,i));
7369 154 : gel(vs,i) = lfunthetaall(T, gel(vL,i), gel(vTAU,i), bitprec);
7370 : }
7371 154 : return flscal? gel(vs,1): vs;
7372 : }
7373 :
7374 : static long
7375 1141 : mfistrivial(GEN F)
7376 : {
7377 1141 : switch(mf_get_type(F))
7378 : {
7379 7 : case t_MF_CONST: return lg(gel(F,2)) == 1;
7380 259 : case t_MF_LINEAR: case t_MF_LINEAR_BHN: return gequal0(gel(F,3));
7381 875 : default: return 0;
7382 : }
7383 : }
7384 :
7385 : static long
7386 959 : mf_same_k(GEN mf, GEN f) { return gequal(MF_get_gk(mf), mf_get_gk(f)); }
7387 : static long
7388 917 : mf_same_CHI(GEN mf, GEN f)
7389 : {
7390 917 : GEN F1, F2, chi1, chi2, CHI1 = MF_get_CHI(mf), CHI2 = mf_get_CHI(f);
7391 : /* are the primitive chars attached to CHI1 and CHI2 equal ? */
7392 917 : F1 = znconreyconductor(gel(CHI1,1), gel(CHI1,2), &chi1);
7393 917 : if (typ(F1) == t_VEC) F1 = gel(F1,1);
7394 917 : F2 = znconreyconductor(gel(CHI2,1), gel(CHI2,2), &chi2);
7395 917 : if (typ(F2) == t_VEC) F2 = gel(F2,1);
7396 917 : return equalii(F1,F2) && ZV_equal(chi1,chi2);
7397 : }
7398 : /* check k and CHI rigorously, but not coefficients nor N */
7399 : static long
7400 238 : mfisinspace_i(GEN mf, GEN F)
7401 : {
7402 238 : return mfistrivial(F) || (mf_same_k(mf,F) && mf_same_CHI(mf,F));
7403 : }
7404 : static void
7405 7 : err_space(GEN F)
7406 7 : { pari_err_DOMAIN("mftobasis", "form", "does not belong to",
7407 0 : strtoGENstr("space"), F); }
7408 :
7409 : static long
7410 147 : mfcheapeisen(GEN mf)
7411 : {
7412 147 : long k, L, N = MF_get_N(mf);
7413 : GEN P;
7414 147 : if (N <= 70) return 1;
7415 84 : k = itos(gceil(MF_get_gk(mf)));
7416 84 : if (odd(k)) k--;
7417 84 : switch (k)
7418 : {
7419 0 : case 2: L = 190; break;
7420 14 : case 4: L = 162; break;
7421 70 : case 6:
7422 70 : case 8: L = 88; break;
7423 0 : case 10: L = 78; break;
7424 0 : default: L = 66; break;
7425 : }
7426 84 : P = gel(myfactoru(N), 1);
7427 84 : return P[lg(P)-1] <= L;
7428 : }
7429 :
7430 : static GEN
7431 182 : myimag_i(GEN tau)
7432 : {
7433 182 : long tc = typ(tau);
7434 182 : if (tc == t_INFINITY || tc == t_INT || tc == t_FRAC)
7435 28 : return gen_1;
7436 154 : if (tc == t_VEC)
7437 : {
7438 : long ltau, i;
7439 7 : GEN z = cgetg_copy(tau, <au);
7440 42 : for (i=1; i<ltau; i++) gel(z,i) = myimag_i(gel(tau,i));
7441 7 : return z;
7442 : }
7443 147 : return imag_i(tau);
7444 : }
7445 :
7446 : static GEN
7447 147 : mintau(GEN vtau)
7448 : {
7449 147 : if (!is_vec_t(typ(vtau))) return myimag_i(vtau);
7450 7 : return (lg(vtau) == 1)? gen_1: vecmin(myimag_i(vtau));
7451 : }
7452 :
7453 : /* initialization for mfgaexpansion: what does not depend on cusp */
7454 : static GEN
7455 987 : mf_eisendec(GEN mf, GEN F, long prec)
7456 : {
7457 987 : GEN B = liftpol_shallow(mfeisensteindec(mf, F)), v = variables_vecsmall(B);
7458 987 : GEN Mvecj = obj_check(mf, MF_EISENSPACE);
7459 987 : long l = lg(v), i, ord;
7460 987 : if (lg(Mvecj) < 5) Mvecj = gel(Mvecj,1);
7461 987 : ord = itou(gel(Mvecj,4));
7462 1043 : for (i = 1; i < l; i++)
7463 714 : if (v[i] != 1)
7464 : {
7465 : GEN d;
7466 : long e;
7467 658 : B = Q_remove_denom(B, &d);
7468 658 : e = gexpo(B);
7469 658 : if (e > 0) prec += nbits2prec(e);
7470 658 : B = gsubst(B, v[i], rootsof1u_cx(ord, prec));
7471 658 : if (d) B = gdiv(B, d);
7472 658 : break;
7473 : }
7474 987 : return B;
7475 : }
7476 :
7477 : GEN
7478 161 : mfeval(GEN mf0, GEN F, GEN vtau, long bitprec)
7479 : {
7480 161 : pari_sp av = avma;
7481 161 : long flnew = 1;
7482 161 : GEN mf = checkMF_i(mf0);
7483 161 : if (!mf) pari_err_TYPE("mfeval", mf0);
7484 161 : if (!checkmf_i(F)) pari_err_TYPE("mfeval", F);
7485 161 : if (!mfisinspace_i(mf, F)) err_space(F);
7486 161 : if (!obj_check(mf, MF_EISENSPACE)) flnew = mfcheapeisen(mf);
7487 161 : if (flnew && gcmpgs(gmulsg(2*MF_get_N(mf), mintau(vtau)), 1) >= 0) flnew = 0;
7488 161 : return gerepilecopy(av, mfeval_i(mf, F, vtau, flnew, bitprec));
7489 : }
7490 :
7491 : static long
7492 189 : val(GEN v, long bit)
7493 : {
7494 189 : long c, l = lg(v);
7495 392 : for (c = 1; c < l; c++)
7496 378 : if (gexpo(gel(v,c)) > -bit) return c-1;
7497 14 : return -1;
7498 : }
7499 : GEN
7500 203 : mfcuspval(GEN mf, GEN F, GEN cusp, long bitprec)
7501 : {
7502 203 : pari_sp av = avma;
7503 203 : long lvE, w, N, sb, n, A, C, prec = nbits2prec(bitprec);
7504 : GEN ga, gk, vE;
7505 203 : mf = checkMF(mf);
7506 203 : if (!checkmf_i(F)) pari_err_TYPE("mfcuspval",F);
7507 203 : N = MF_get_N(mf);
7508 203 : cusp_canon(cusp, N, &A, &C);
7509 203 : gk = mf_get_gk(F);
7510 203 : if (typ(gk) != t_INT)
7511 : {
7512 42 : GEN FT = mfmultheta(F), mf2 = obj_checkbuild(mf, MF_MF2INIT, &mf2init);
7513 42 : GEN r = mfcuspval(mf2, FT, cusp, bitprec);
7514 42 : if ((C & 3L) == 2)
7515 : {
7516 14 : GEN z = uutoQ(1,4);
7517 14 : r = gsub(r, typ(r) == t_VEC? const_vec(lg(r)-1, z): z);
7518 : }
7519 42 : return gerepileupto(av, r);
7520 : }
7521 161 : vE = mfgetembed(F, prec);
7522 161 : lvE = lg(vE);
7523 161 : w = mfcuspcanon_width(N, C);
7524 161 : sb = w * mfsturmNk(N, itos(gk));
7525 161 : ga = cusp2mat(A,C);
7526 168 : for (n = 8;; n = minss(sb, n << 1))
7527 7 : {
7528 168 : GEN R = mfgaexpansion(mf, F, ga, n, prec), res = liftpol_shallow(gel(R,3));
7529 168 : GEN v = cgetg(lvE-1, t_VECSMALL);
7530 168 : long j, ok = 1;
7531 168 : res = RgC_embedall(res, vE);
7532 357 : for (j = 1; j < lvE; j++)
7533 : {
7534 189 : v[j] = val(gel(res,j), bitprec/2);
7535 189 : if (v[j] < 0) ok = 0;
7536 : }
7537 168 : if (ok)
7538 : {
7539 154 : res = cgetg(lvE, t_VEC);
7540 329 : for (j = 1; j < lvE; j++) gel(res,j) = gadd(gel(R,1), uutoQ(v[j], w));
7541 154 : return gerepilecopy(av, lvE==2? gel(res,1): res);
7542 : }
7543 14 : if (n == sb) return lvE==2? mkoo(): const_vec(lvE-1, mkoo()); /* 0 */
7544 : }
7545 : }
7546 :
7547 : long
7548 224 : mfiscuspidal(GEN mf, GEN F)
7549 : {
7550 224 : pari_sp av = avma;
7551 : GEN mf2;
7552 224 : if (space_is_cusp(MF_get_space(mf))) return 1;
7553 98 : if (typ(mf_get_gk(F)) == t_INT)
7554 : {
7555 56 : GEN v = mftobasis(mf,F,0), vE = vecslice(v, 1, lg(MF_get_E(mf))-1);
7556 56 : return gc_long(av, gequal0(vE));
7557 : }
7558 42 : if (!gequal0(mfak_i(F, 0))) return 0;
7559 21 : mf2 = obj_checkbuild(mf, MF_MF2INIT, &mf2init);
7560 21 : return mfiscuspidal(mf2, mfmultheta(F));
7561 : }
7562 :
7563 : /* F = vector of newforms in mftobasis format */
7564 : static GEN
7565 98 : mffrickeeigen_i(GEN mf, GEN F, GEN vE, long prec)
7566 : {
7567 98 : GEN M, Z, L0, gN = MF_get_gN(mf), gk = MF_get_gk(mf);
7568 98 : long N0, i, lM, bit = prec2nbits(prec), k = itou(gk);
7569 98 : long LIM = 5; /* Sturm bound is enough */
7570 :
7571 98 : L0 = mfthetaancreate(NULL, gN, gk); /* only for thetacost */
7572 98 : START:
7573 98 : N0 = lfunthetacost(L0, gen_1, LIM, bit);
7574 98 : M = mfcoefs_mf(mf, N0, 1);
7575 98 : lM = lg(F);
7576 98 : Z = cgetg(lM, t_VEC);
7577 273 : for (i = 1; i < lM; i++)
7578 : { /* expansion of D * F[i] */
7579 175 : GEN D, z, van = RgM_RgC_mul(M, Q_remove_denom(gel(F,i), &D));
7580 175 : GEN L = van_embedall(van, gel(vE,i), gN, gk);
7581 175 : long l = lg(L), j, bit_add = D? expi(D): 0;
7582 175 : gel(Z,i) = z = cgetg(l, t_VEC);
7583 553 : for (j = 1; j < l; j++)
7584 : {
7585 : GEN v, C, C0;
7586 : long m, e;
7587 511 : for (m = 0; m <= LIM; m++)
7588 : {
7589 511 : v = lfuntheta(gmael(L,j,2), gen_1, m, bit);
7590 511 : if (gexpo(v) > bit_add - bit/2) break;
7591 : }
7592 378 : if (m > LIM) { LIM <<= 1; goto START; }
7593 378 : C = mulcxpowIs(gdiv(v,conj_i(v)), 2*m - k);
7594 378 : C0 = grndtoi(C, &e); if (e < 5-bit_accuracy(precision(C))) C = C0;
7595 378 : gel(z,j) = C;
7596 : }
7597 : }
7598 98 : return Z;
7599 : }
7600 : static GEN
7601 77 : mffrickeeigen(GEN mf, GEN vE, long prec)
7602 : {
7603 77 : GEN D = obj_check(mf, MF_FRICKE);
7604 77 : if (D) { long p = gprecision(D); if (!p || p >= prec) return D; }
7605 70 : D = mffrickeeigen_i(mf, MF_get_newforms(mf), vE, prec);
7606 70 : return obj_insert(mf, MF_FRICKE, D);
7607 : }
7608 :
7609 : /* integral weight, new space for primitive quadratic character CHIP;
7610 : * MF = vector of embedded eigenforms coefs on mfbasis, by orbit.
7611 : * Assume N > Q > 1 and (Q,f(CHIP)) = 1 */
7612 : static GEN
7613 56 : mfatkineigenquad(GEN mf, GEN CHIP, long Q, GEN MF, long bitprec)
7614 : {
7615 : GEN L0, la2, S, F, vP, tau, wtau, Z, va, vb, den, coe, sqrtQ, sqrtN;
7616 56 : GEN M, gN, gk = MF_get_gk(mf);
7617 56 : long N0, x, yq, i, j, lF, dim, muQ, prec = nbits2prec(bitprec);
7618 56 : long N = MF_get_N(mf), k = itos(gk), NQ = N / Q;
7619 :
7620 : /* Q coprime to FC */
7621 56 : F = MF_get_newforms(mf);
7622 56 : vP = MF_get_fields(mf);
7623 56 : lF = lg(F);
7624 56 : Z = cgetg(lF, t_VEC);
7625 56 : S = MF_get_S(mf); dim = lg(S) - 1;
7626 56 : muQ = mymoebiusu(Q);
7627 56 : if (muQ)
7628 : {
7629 42 : GEN SQ = cgetg(dim+1,t_VEC), Qk = gpow(stoi(Q), sstoQ(k-2, 2), prec);
7630 42 : long i, bit2 = bitprec >> 1;
7631 154 : for (j = 1; j <= dim; j++) gel(SQ,j) = mfak_i(gel(S,j), Q);
7632 84 : for (i = 1; i < lF; i++)
7633 : {
7634 42 : GEN S = RgV_dotproduct(gel(F,i), SQ), T = gel(vP,i);
7635 : long e;
7636 42 : if (degpol(T) > 1 && typ(S) != t_POLMOD) S = gmodulo(S, T);
7637 42 : S = grndtoi(gdiv(conjvec(S, prec), Qk), &e);
7638 42 : if (e > -bit2) pari_err_PREC("mfatkineigenquad");
7639 42 : if (muQ == -1) S = gneg(S);
7640 42 : gel(Z,i) = S;
7641 : }
7642 42 : return Z;
7643 : }
7644 14 : la2 = mfchareval(CHIP, Q); /* 1 or -1 */
7645 14 : (void)cbezout(Q, NQ, &x, &yq);
7646 14 : sqrtQ = sqrtr_abs(utor(Q,prec));
7647 14 : tau = mkcomplex(gadd(sstoQ(-1, NQ), uutoQ(1, 1000)),
7648 : divru(sqrtQ, N));
7649 14 : den = gaddgs(gmulsg(NQ, tau), 1);
7650 14 : wtau = gdiv(gsub(gmulsg(x, tau), sstoQ(yq, Q)), den);
7651 14 : coe = gpowgs(gmul(sqrtQ, den), k);
7652 :
7653 14 : sqrtN = sqrtr_abs(utor(N,prec));
7654 14 : tau = mulcxmI(gmul(tau, sqrtN));
7655 14 : wtau = mulcxmI(gmul(wtau, sqrtN));
7656 14 : gN = utoipos(N);
7657 14 : L0 = mfthetaancreate(NULL, gN, gk); /* only for thetacost */
7658 14 : N0 = maxss(lfunthetacost(L0,real_i(tau), 0,bitprec),
7659 : lfunthetacost(L0,real_i(wtau),0,bitprec));
7660 14 : M = mfcoefs_mf(mf, N0, 1);
7661 14 : va = cgetg(dim+1, t_VEC);
7662 14 : vb = cgetg(dim+1, t_VEC);
7663 105 : for (j = 1; j <= dim; j++)
7664 : {
7665 91 : GEN L, v = vecslice(gel(M,j), 2, N0+1); /* remove a0 */
7666 91 : settyp(v, t_VEC); L = mfthetaancreate(v, gN, gk);
7667 91 : gel(va,j) = lfuntheta(L, tau,0,bitprec);
7668 91 : gel(vb,j) = lfuntheta(L,wtau,0,bitprec);
7669 : }
7670 84 : for (i = 1; i < lF; i++)
7671 : {
7672 70 : GEN z, FE = gel(MF,i);
7673 70 : long l = lg(FE);
7674 70 : z = cgetg(l, t_VEC);
7675 70 : for (j = 1; j < l; j++)
7676 : {
7677 70 : GEN f = gel(FE,j), a = RgV_dotproduct(va,f), b = RgV_dotproduct(vb,f);
7678 70 : GEN la = ground( gdiv(b, gmul(a,coe)) );
7679 70 : if (!gequal(gsqr(la), la2)) pari_err_PREC("mfatkineigenquad");
7680 70 : if (typ(la) == t_INT)
7681 : {
7682 70 : if (j != 1) pari_err_BUG("mfatkineigenquad");
7683 70 : z = const_vec(l-1, la); break;
7684 : }
7685 0 : gel(z,j) = la;
7686 : }
7687 70 : gel(Z,i) = z;
7688 : }
7689 14 : return Z;
7690 : }
7691 :
7692 : static GEN
7693 84 : myusqrt(ulong a, long prec)
7694 : {
7695 84 : if (a == 1UL) return gen_1;
7696 70 : if (uissquareall(a, &a)) return utoipos(a);
7697 49 : return sqrtr_abs(utor(a, prec));
7698 : }
7699 : /* Assume mf is a nontrivial new space, rational primitive character CHIP
7700 : * and (Q,FC) = 1 */
7701 : static GEN
7702 105 : mfatkinmatnewquad(GEN mf, GEN CHIP, long Q, long flag, long PREC)
7703 : {
7704 105 : GEN cM, M, D, MF, den, vE, F = MF_get_newforms(mf);
7705 105 : long i, c, e, prec, bitprec, lF = lg(F), N = MF_get_N(mf), k = MF_get_k(mf);
7706 :
7707 105 : if (Q == 1) return mkvec4(gen_0, matid(MF_get_dim(mf)), gen_1, mf);
7708 105 : den = gel(MF_get_Minv(mf), 2);
7709 105 : bitprec = expi(den) + 64;
7710 105 : if (!flag) bitprec = maxss(bitprec, prec2nbits(PREC));
7711 :
7712 35 : START:
7713 105 : prec = nbits2prec(bitprec);
7714 105 : vE = mfeigenembed(mf, prec);
7715 105 : M = cgetg(lF, t_VEC);
7716 280 : for (i = 1; i < lF; i++) gel(M,i) = RgC_embedall(gel(F,i), gel(vE,i));
7717 105 : if (Q != N)
7718 : {
7719 56 : D = mfatkineigenquad(mf, CHIP, Q, M, bitprec);
7720 56 : c = odd(k)? Q: 1;
7721 : }
7722 : else
7723 : {
7724 49 : D = mffrickeeigen(mf, vE, prec);
7725 49 : c = mfcharmodulus(CHIP); if (odd(k)) c = -Q/c;
7726 : }
7727 105 : D = shallowconcat1(D);
7728 105 : if (vec_isconst(D)) { MF = diagonal_shallow(D); flag = 0; }
7729 : else
7730 : {
7731 63 : M = shallowconcat1(M);
7732 63 : MF = RgM_mul(matmuldiagonal(M,D), ginv(M));
7733 : }
7734 105 : if (!flag) return mkvec4(gen_0, MF, gen_1, mf);
7735 :
7736 21 : if (c > 0)
7737 21 : cM = myusqrt(c, PREC);
7738 : else
7739 : {
7740 0 : MF = imag_i(MF); c = -c;
7741 0 : cM = mkcomplex(gen_0, myusqrt(c,PREC));
7742 : }
7743 21 : if (c != 1) MF = RgM_Rg_mul(MF, myusqrt(c,prec));
7744 21 : MF = grndtoi(RgM_Rg_mul(MF,den), &e);
7745 21 : if (e > -32) { bitprec <<= 1; goto START; }
7746 21 : MF = RgM_Rg_div(MF, den);
7747 21 : if (is_rational_t(typ(cM)) && !isint1(cM))
7748 0 : { MF = RgM_Rg_div(MF, cM); cM = gen_1; }
7749 21 : return mkvec4(gen_0, MF, cM, mf);
7750 : }
7751 :
7752 : /* let CHI mod N, Q || N, return \bar{CHI_Q} * CHI_{N/Q} */
7753 : static GEN
7754 105 : mfcharAL(GEN CHI, long Q)
7755 : {
7756 105 : GEN G = gel(CHI,1), c = gel(CHI,2), cycc, d, P, E, F;
7757 105 : long l = lg(c), N = mfcharmodulus(CHI), i;
7758 105 : if (N == Q) return mfcharconj(CHI);
7759 49 : if (N == 1) return CHI;
7760 42 : CHI = leafcopy(CHI);
7761 42 : gel(CHI,2) = d = leafcopy(c);
7762 42 : F = znstar_get_faN(G);
7763 42 : P = gel(F,1);
7764 42 : E = gel(F,2);
7765 42 : cycc = znstar_get_conreycyc(G);
7766 42 : if (!odd(Q) && equaliu(gel(P,1), 2) && E[1] >= 3)
7767 14 : gel(d,2) = Fp_neg(gel(d,2), gel(cycc,2));
7768 56 : else for (i = 1; i < l; i++)
7769 28 : if (!umodui(Q, gel(P,i))) gel(d,i) = Fp_neg(gel(d,i), gel(cycc,i));
7770 42 : return CHI;
7771 : }
7772 : static long
7773 231 : atkin_get_NQ(long N, long Q, const char *f)
7774 : {
7775 231 : long NQ = N / Q;
7776 231 : if (N % Q) pari_err_DOMAIN(f,"N % Q","!=",gen_0,utoi(Q));
7777 231 : if (ugcd(NQ, Q) > 1) pari_err_DOMAIN(f,"gcd(Q,N/Q)","!=",gen_1,utoi(Q));
7778 231 : return NQ;
7779 : }
7780 :
7781 : /* transform mf to new_NEW if possible */
7782 : static GEN
7783 1330 : MF_set_new(GEN mf)
7784 : {
7785 1330 : GEN vMjd, vj, gk = MF_get_gk(mf);
7786 : long l, j;
7787 1330 : if (MF_get_space(mf) != mf_CUSP
7788 1330 : || typ(gk) != t_INT || itou(gk) == 1) return mf;
7789 175 : vMjd = MFcusp_get_vMjd(mf); l = lg(vMjd);
7790 175 : if (l > 1 && gel(vMjd,1)[1] != MF_get_N(mf)) return mf; /* oldspace != 0 */
7791 168 : mf = shallowcopy(mf);
7792 168 : gel(mf,1) = shallowcopy(gel(mf,1));
7793 168 : MF_set_space(mf, mf_NEW);
7794 168 : vj = cgetg(l, t_VECSMALL);
7795 917 : for (j = 1; j < l; j++) vj[j] = gel(vMjd, j)[2];
7796 168 : gel(mf,4) = vj; return mf;
7797 : }
7798 :
7799 : /* if flag = 1, rationalize, else don't */
7800 : static GEN
7801 210 : mfatkininit_i(GEN mf, long Q, long flag, long prec)
7802 : {
7803 : GEN M, B, C, CHI, CHIAL, G, chi, P, z, g, mfB, s, Mindex, Minv;
7804 210 : long j, l, lim, ord, FC, NQ, cQ, nk, dk, N = MF_get_N(mf);
7805 :
7806 210 : B = MF_get_basis(mf); l = lg(B);
7807 210 : M = cgetg(l, t_MAT); if (l == 1) return mkvec4(gen_0,M,gen_1,mf);
7808 210 : Qtoss(MF_get_gk(mf), &nk,&dk);
7809 210 : Q = labs(Q);
7810 210 : NQ = atkin_get_NQ(N, Q, "mfatkininit");
7811 210 : CHI = MF_get_CHI(mf);
7812 210 : CHI = mfchartoprimitive(CHI, &FC);
7813 210 : ord = mfcharorder(CHI);
7814 210 : mf = MF_set_new(mf);
7815 210 : if (MF_get_space(mf) == mf_NEW && ord <= 2 && NQ % FC == 0 && dk == 1)
7816 105 : return mfatkinmatnewquad(mf, CHI, Q, flag, prec);
7817 : /* now flag != 0 */
7818 105 : G = gel(CHI,1);
7819 105 : chi = gel(CHI,2);
7820 105 : if (Q == N) { g = mkmat22s(0, -1, N, 0); cQ = NQ; } /* Fricke */
7821 : else
7822 : {
7823 28 : GEN F, gQP = utoi(ugcd(Q, FC));
7824 : long t, v;
7825 28 : chi = znchardecompose(G, chi, gQP);
7826 28 : F = znconreyconductor(G, chi, &chi);
7827 28 : G = znstar0(F,1);
7828 28 : (void)cbezout(Q, NQ, &t, &v);
7829 28 : g = mkmat22s(Q*t, 1, -N*v, Q);
7830 28 : cQ = -NQ*v;
7831 : }
7832 105 : C = s = gen_1;
7833 : /* N.B. G,chi are G_Q,chi_Q [primitive] at this point */
7834 105 : if (lg(chi) != 1) C = ginv( znchargauss(G, chi, gen_1, prec2nbits(prec)) );
7835 105 : if (dk == 1)
7836 84 : { if (odd(nk)) s = myusqrt(Q,prec); }
7837 : else
7838 : {
7839 21 : long r = nk >> 1; /* k-1/2 */
7840 21 : s = gpow(utoipos(Q), mkfracss(odd(r)? 1: 3, 4), prec);
7841 21 : if (odd(cQ))
7842 : {
7843 21 : long t = r + ((cQ-1) >> 1);
7844 21 : s = mkcomplex(s, odd(t)? gneg(s): s);
7845 : }
7846 : }
7847 105 : if (!isint1(s)) C = gmul(C, s);
7848 105 : CHIAL = mfcharAL(CHI, Q);
7849 105 : if (dk == 2)
7850 : {
7851 21 : ulong q = odd(Q)? Q << 2: Q, Nq = ulcm(q, mfcharmodulus(CHIAL));
7852 21 : CHIAL = induceN(Nq, CHIAL);
7853 21 : CHIAL = mfcharmul(CHIAL, induce(gel(CHIAL,1), utoipos(q)));
7854 : }
7855 105 : CHIAL = mfchartoprimitive(CHIAL,NULL);
7856 105 : mfB = gequal(CHIAL,CHI)? mf: mfinit_Nndkchi(N,nk,dk,CHIAL,MF_get_space(mf),0);
7857 105 : Mindex = MF_get_Mindex(mfB);
7858 105 : Minv = MF_get_Minv(mfB);
7859 105 : P = z = NULL;
7860 105 : if (ord > 2) { P = mfcharpol(CHI); z = rootsof1u_cx(ord, prec); }
7861 105 : lim = maxss(mfsturm(mfB), mfsturm(mf)) + 1;
7862 343 : for (j = 1; j < l; j++)
7863 : {
7864 238 : GEN v = mfslashexpansion(mf, gel(B,j), g, lim, 0, NULL, prec+EXTRAPREC64);
7865 : long junk;
7866 238 : if (!isint1(C)) v = RgV_Rg_mul(v, C);
7867 238 : v = bestapprnf(v, P, z, prec);
7868 238 : v = vecpermute_partial(v, Mindex, &junk);
7869 238 : v = Minv_RgC_mul(Minv, v); /* cf mftobasis_i */
7870 238 : gel(M, j) = v;
7871 : }
7872 105 : if (is_rational_t(typ(C)) && !gequal1(C)) { M = gdiv(M, C); C = gen_1; }
7873 105 : if (mfB == mf) mfB = gen_0;
7874 105 : return mkvec4(mfB, M, C, mf);
7875 : }
7876 : GEN
7877 91 : mfatkininit(GEN mf, long Q, long prec)
7878 : {
7879 91 : pari_sp av = avma;
7880 91 : mf = checkMF(mf); return gerepilecopy(av, mfatkininit_i(mf, Q, 1, prec));
7881 : }
7882 : static void
7883 56 : checkmfa(GEN z)
7884 : {
7885 56 : if (typ(z) != t_VEC || lg(z) != 5 || typ(gel(z,2)) != t_MAT
7886 56 : || !checkMF_i(gel(z,4))
7887 56 : || (!isintzero(gel(z,1)) && !checkMF_i(gel(z,1))))
7888 0 : pari_err_TYPE("mfatkin [please apply mfatkininit()]",z);
7889 56 : }
7890 :
7891 : /* Apply atkin Q to closure F */
7892 : GEN
7893 56 : mfatkin(GEN mfa, GEN F)
7894 : {
7895 56 : pari_sp av = avma;
7896 : GEN z, mfB, MQ, mf;
7897 56 : checkmfa(mfa);
7898 56 : mfB= gel(mfa,1);
7899 56 : MQ = gel(mfa,2);
7900 56 : mf = gel(mfa,4);
7901 56 : if (typ(mfB) == t_INT) mfB = mf;
7902 56 : z = RgM_RgC_mul(MQ, mftobasis_i(mf,F));
7903 56 : return gerepileupto(av, mflinear(mfB, z));
7904 : }
7905 :
7906 : GEN
7907 49 : mfatkineigenvalues(GEN mf, long Q, long prec)
7908 : {
7909 49 : pari_sp av = avma;
7910 : GEN vF, L, CHI, M, mfatk, C, MQ, vE, mfB;
7911 : long N, NQ, l, i;
7912 :
7913 49 : mf = checkMF(mf); N = MF_get_N(mf);
7914 49 : vF = MF_get_newforms(mf); l = lg(vF);
7915 : /* N.B. k is integral */
7916 49 : if (l == 1) { set_avma(av); return cgetg(1, t_VEC); }
7917 49 : L = cgetg(l, t_VEC);
7918 49 : if (Q == 1)
7919 : {
7920 7 : GEN vP = MF_get_fields(mf);
7921 21 : for (i = 1; i < l; i++) gel(L,i) = const_vec(degpol(gel(vP,i)), gen_1);
7922 7 : return L;
7923 : }
7924 42 : vE = mfeigenembed(mf,prec);
7925 42 : if (Q == N) return gerepileupto(av, mffrickeeigen(mf, vE, prec));
7926 21 : Q = labs(Q);
7927 21 : NQ = atkin_get_NQ(N, Q, "mfatkineigenvalues"); /* != 1 */
7928 21 : mfatk = mfatkininit(mf, Q, prec);
7929 21 : mfB= gel(mfatk,1); if (typ(mfB) != t_VEC) mfB = mf;
7930 21 : MQ = gel(mfatk,2);
7931 21 : C = gel(mfatk,3);
7932 21 : M = row(mfcoefs_mf(mfB,1,1), 2); /* vec of a_1(b_i) for mfbasis functions */
7933 56 : for (i = 1; i < l; i++)
7934 : {
7935 35 : GEN c = RgV_dotproduct(RgM_RgC_mul(MQ,gel(vF,i)), M); /* C * eigen_i */
7936 35 : gel(L,i) = Rg_embedall_i(c, gel(vE,i));
7937 : }
7938 21 : if (!gequal1(C)) L = gdiv(L, C);
7939 21 : CHI = MF_get_CHI(mf);
7940 21 : if (mfcharorder(CHI) <= 2 && NQ % mfcharconductor(CHI) == 0) L = ground(L);
7941 21 : return gerepilecopy(av, L);
7942 : }
7943 :
7944 : /* expand B_d V, keeping same length */
7945 : static GEN
7946 6083 : bdexpand(GEN V, long d)
7947 : {
7948 : GEN W;
7949 : long N, n;
7950 6083 : if (d == 1) return V;
7951 2226 : N = lg(V)-1; W = zerovec(N);
7952 43043 : for (n = 0; n <= (N-1)/d; n++) gel(W, n*d+1) = gel(V, n+1);
7953 2226 : return W;
7954 : }
7955 : /* expand B_d V, increasing length up to lim */
7956 : static GEN
7957 287 : bdexpandall(GEN V, long d, long lim)
7958 : {
7959 : GEN W;
7960 : long N, n;
7961 287 : if (d == 1) return V;
7962 35 : N = lg(V)-1; W = zerovec(lim);
7963 259 : for (n = 0; n <= N-1 && n*d <= lim; n++) gel(W, n*d+1) = gel(V, n+1);
7964 35 : return W;
7965 : }
7966 :
7967 : static void
7968 9086 : parse_vecj(GEN T, GEN *E1, GEN *E2)
7969 : {
7970 9086 : if (lg(T)==3) { *E1 = gel(T,1); *E2 = gel(T,2); }
7971 4963 : else { *E1 = T; *E2 = NULL; }
7972 9086 : }
7973 :
7974 : /* g in M_2(Z) ? */
7975 : static int
7976 2877 : check_M2Z(GEN g)
7977 2877 : { return typ(g) == t_MAT && lg(g) == 3 && lgcols(g) == 3 && RgM_is_ZM(g); }
7978 : /* g in SL_2(Z) ? */
7979 : static int
7980 1757 : check_SL2Z(GEN g) { return check_M2Z(g) && equali1(ZM_det(g)); }
7981 :
7982 : static GEN
7983 9065 : mfcharcxeval(GEN CHI, long n, long prec)
7984 : {
7985 9065 : ulong ord, N = mfcharmodulus(CHI);
7986 : GEN ordg;
7987 9065 : if (N == 1) return gen_1;
7988 3696 : if (ugcd(N, labs(n)) > 1) return gen_0;
7989 3696 : ordg = gmfcharorder(CHI);
7990 3696 : ord = itou(ordg);
7991 3696 : return rootsof1q_cx(znchareval_i(CHI,n,ordg), ord, prec);
7992 : }
7993 :
7994 : static GEN
7995 4963 : RgV_shift(GEN V, GEN gn)
7996 : {
7997 : long i, n, l;
7998 : GEN W;
7999 4963 : if (typ(gn) != t_INT) pari_err_BUG("RgV_shift [n not integral]");
8000 4963 : n = itos(gn);
8001 4963 : if (n < 0) pari_err_BUG("RgV_shift [n negative]");
8002 4963 : if (!n) return V;
8003 112 : W = cgetg_copy(V, &l); if (n > l-1) n = l-1;
8004 308 : for (i=1; i <= n; i++) gel(W,i) = gen_0;
8005 4900 : for ( ; i < l; i++) gel(W,i) = gel(V, i-n);
8006 112 : return W;
8007 : }
8008 : static GEN
8009 7630 : hash_eisengacx(hashtable *H, void *E, long w, GEN ga, long n, long prec)
8010 : {
8011 7630 : ulong h = H->hash(E);
8012 7630 : hashentry *e = hash_search2(H, E, h);
8013 : GEN v;
8014 7630 : if (e) v = (GEN)e->val;
8015 : else
8016 : {
8017 5159 : v = mfeisensteingacx((GEN)E, w, ga, n, prec);
8018 5159 : hash_insert2(H, E, (void*)v, h);
8019 : }
8020 7630 : return v;
8021 : }
8022 : static GEN
8023 4963 : vecj_expand(GEN B, hashtable *H, long w, GEN ga, long n, long prec)
8024 : {
8025 : GEN E1, E2, v;
8026 4963 : parse_vecj(B, &E1, &E2);
8027 4963 : v = hash_eisengacx(H, (void*)E1, w, ga, n, prec);
8028 4963 : if (E2)
8029 : {
8030 2611 : GEN u = hash_eisengacx(H, (void*)E2, w, ga, n, prec);
8031 2611 : GEN a = gadd(gel(v,1), gel(u,1));
8032 2611 : GEN b = RgV_mul_RgXn(gel(v,2), gel(u,2));
8033 2611 : v = mkvec2(a,b);
8034 : }
8035 4963 : return v;
8036 : }
8037 : static GEN
8038 1050 : shift_M(GEN M, GEN Valpha, long w)
8039 : {
8040 1050 : long i, l = lg(Valpha);
8041 1050 : GEN almin = vecmin(Valpha);
8042 6013 : for (i = 1; i < l; i++)
8043 : {
8044 4963 : GEN alpha = gel(Valpha, i), gsh = gmulsg(w, gsub(alpha,almin));
8045 4963 : gel(M,i) = RgV_shift(gel(M,i), gsh);
8046 : }
8047 1050 : return almin;
8048 : }
8049 : static GEN mfeisensteinspaceinit(GEN NK);
8050 : #if 0
8051 : /* ga in M_2^+(Z)), n >= 0 */
8052 : static GEN
8053 : mfgaexpansion_init(GEN mf, GEN ga, long n, long prec)
8054 : {
8055 : GEN M, Mvecj, vecj, almin, Valpha;
8056 : long i, w, l, N = MF_get_N(mf), c = itos(gcoeff(ga,2,1));
8057 : hashtable *H;
8058 :
8059 : if (c % N == 0)
8060 : { /* ga in G_0(N), trivial case; w = 1 */
8061 : GEN chid = mfcharcxeval(MF_get_CHI(mf), itos(gcoeff(ga,2,2)), prec);
8062 : return mkvec2(chid, utoi(n));
8063 : }
8064 :
8065 : Mvecj = obj_checkbuild(mf, MF_EISENSPACE, &mfeisensteinspaceinit);
8066 : if (lg(Mvecj) < 5) pari_err_IMPL("mfgaexpansion_init in this case");
8067 : w = mfcuspcanon_width(N, c);
8068 : vecj = gel(Mvecj, 3);
8069 : l = lg(vecj);
8070 : M = cgetg(l, t_VEC);
8071 : Valpha = cgetg(l, t_VEC);
8072 : H = hash_create(l, (ulong(*)(void*))&hash_GEN,
8073 : (int(*)(void*,void*))&gidentical, 1);
8074 : for (i = 1; i < l; i++)
8075 : {
8076 : GEN v = vecj_expand(gel(vecj,i), H, w, ga, n, prec);
8077 : gel(Valpha,i) = gel(v,1);
8078 : gel(M,i) = gel(v,2);
8079 : }
8080 : almin = shift_M(M, Valpha, w);
8081 : return mkvec3(almin, utoi(w), M);
8082 : }
8083 : /* half-integer weight not supported; vF = [F,eisendec(F)].
8084 : * Minit = mfgaexpansion_init(mf, ga, n, prec) */
8085 : static GEN
8086 : mfgaexpansion_with_init(GEN Minit, GEN vF)
8087 : {
8088 : GEN v;
8089 : if (lg(Minit) == 3)
8090 : { /* ga in G_0(N) */
8091 : GEN chid = gel(Minit,1), gn = gel(Minit,2);
8092 : v = mfcoefs_i(gel(vF,1), itou(gn), 1);
8093 : v = mkvec3(gen_0, gen_1, RgV_Rg_mul(v,chid));
8094 : }
8095 : else
8096 : {
8097 : GEN V = RgM_RgC_mul(gel(Minit,3), gel(vF,2));
8098 : v = mkvec3(gel(Minit,1), gel(Minit,2), V);
8099 : }
8100 : return v;
8101 : }
8102 : #endif
8103 :
8104 : /* B = mfeisensteindec(F) already embedded, ga in M_2^+(Z)), n >= 0 */
8105 : static GEN
8106 1050 : mfgaexpansion_i(GEN mf, GEN B0, GEN ga, long n, long prec)
8107 : {
8108 1050 : GEN M, Mvecj, vecj, almin, Valpha, B, E = NULL;
8109 1050 : long i, j, w, nw, l, N = MF_get_N(mf), bit = prec2nbits(prec) / 2;
8110 : hashtable *H;
8111 :
8112 1050 : Mvecj = obj_check(mf, MF_EISENSPACE);
8113 1050 : if (lg(Mvecj) < 5) { E = gel(Mvecj, 2); Mvecj = gel(Mvecj, 1); }
8114 1050 : vecj = gel(Mvecj, 3);
8115 1050 : l = lg(vecj);
8116 1050 : B = cgetg(l, t_COL);
8117 1050 : M = cgetg(l, t_VEC);
8118 1050 : Valpha = cgetg(l, t_VEC);
8119 1050 : w = mfZC_width(N, gel(ga,1));
8120 1050 : nw = E ? n + w : n;
8121 1050 : H = hash_create(l, (ulong(*)(void*))&hash_GEN,
8122 : (int(*)(void*,void*))&gidentical, 1);
8123 8932 : for (i = j = 1; i < l; i++)
8124 : {
8125 : GEN v;
8126 7882 : if (gequal0(gel(B0,i))) continue;
8127 4963 : v = vecj_expand(gel(vecj,i), H, w, ga, nw, prec);
8128 4963 : gel(B,j) = gel(B0,i);
8129 4963 : gel(Valpha,j) = gel(v,1);
8130 4963 : gel(M,j) = gel(v,2); j++;
8131 : }
8132 1050 : setlg(Valpha, j);
8133 1050 : setlg(B, j);
8134 1050 : setlg(M, j); l = j;
8135 1050 : if (l == 1) return mkvec3(gen_0, utoi(w), zerovec(n+1));
8136 1050 : almin = shift_M(M, Valpha, w);
8137 1050 : B = RgM_RgC_mul(M, B); l = lg(B);
8138 147812 : for (i = 1; i < l; i++)
8139 146762 : if (gexpo(gel(B,i)) < -bit) gel(B,i) = gen_0;
8140 1050 : settyp(B, t_VEC);
8141 1050 : if (E)
8142 : {
8143 : GEN v, e;
8144 56 : long ell = 0, vB, ve;
8145 126 : for (i = 1; i < l; i++)
8146 126 : if (!gequal0(gel(B,i))) break;
8147 56 : vB = i-1;
8148 56 : v = hash_eisengacx(H, (void*)E, w, ga, n + vB, prec);
8149 56 : e = gel(v,2); l = lg(e);
8150 56 : for (i = 1; i < l; i++)
8151 56 : if (!gequal0(gel(e,i))) break;
8152 56 : ve = i-1;
8153 56 : almin = gsub(almin, gel(v,1));
8154 56 : if (gsigne(almin) < 0)
8155 : {
8156 0 : GEN gell = gceil(gmulsg(-w, almin));
8157 0 : ell = itos(gell);
8158 0 : almin = gadd(almin, gdivgu(gell, w));
8159 0 : if (nw < ell) pari_err_IMPL("alpha < 0 in mfgaexpansion");
8160 : }
8161 56 : if (ve) { ell += ve; e = vecslice(e, ve+1, l-1); }
8162 56 : B = vecslice(B, ell + 1, minss(n + ell + 1, lg(B)-1));
8163 56 : B = RgV_div_RgXn(B, e);
8164 : }
8165 1050 : return mkvec3(almin, utoi(w), B);
8166 : }
8167 :
8168 : /* Theta multiplier: assume 4 | C, (C,D)=1 */
8169 : static GEN
8170 343 : mfthetamultiplier(GEN C, GEN D)
8171 : {
8172 343 : long s = kronecker(C, D);
8173 343 : if (Mod4(D) == 1) return s > 0 ? gen_1: gen_m1;
8174 84 : return s > 0? powIs(3): gen_I();
8175 : }
8176 : /* theta | [*,*;C,D] defined over Q(i) [else over Q] */
8177 : static int
8178 56 : mfthetaI(long C, long D) { return odd(C) || (D & 3) == 3; }
8179 : /* (theta | M) [0..n], assume (C,D) = 1 */
8180 : static GEN
8181 343 : mfthetaexpansion(GEN M, long n)
8182 : {
8183 343 : GEN w, s, al, sla, E, V = zerovec(n+1), C = gcoeff(M,2,1), D = gcoeff(M,2,2);
8184 343 : long lim, la, f, C4 = Mod4(C);
8185 343 : switch (C4)
8186 : {
8187 70 : case 0: al = gen_0; w = gen_1;
8188 70 : s = mfthetamultiplier(C,D);
8189 70 : lim = usqrt(n); gel(V, 1) = s;
8190 70 : s = gmul2n(s, 1);
8191 756 : for (f = 1; f <= lim; f++) gel(V, f*f + 1) = s;
8192 70 : break;
8193 105 : case 2: al = uutoQ(1,4); w = gen_1;
8194 105 : E = subii(C, shifti(D,1)); /* (E, D) = 1 */
8195 105 : s = gmul2n(mfthetamultiplier(E, D), 1);
8196 105 : if ((!signe(E) && equalim1(D)) || (signe(E) > 0 && signe(C) < 0))
8197 14 : s = gneg(s);
8198 105 : lim = (usqrt(n << 2) - 1) >> 1;
8199 966 : for (f = 0; f <= lim; f++) gel(V, f*(f+1) + 1) = s;
8200 105 : break;
8201 168 : default: al = gen_0; w = utoipos(4);
8202 168 : la = (-Mod4(D)*C4) & 3L;
8203 168 : E = negi(addii(D, mului(la, C)));
8204 168 : s = mfthetamultiplier(E, C); /* (E,C) = 1 */
8205 168 : if (signe(C) < 0 && signe(E) >= 0) s = gneg(s);
8206 168 : s = gsub(s, mulcxI(s));
8207 168 : sla = gmul(s, powIs(-la));
8208 168 : lim = usqrt(n); gel(V, 1) = gmul2n(s, -1);
8209 1708 : for (f = 1; f <= lim; f++) gel(V, f*f + 1) = odd(f) ? sla : s;
8210 168 : break;
8211 : }
8212 343 : return mkvec3(al, w, V);
8213 : }
8214 :
8215 : /* F 1/2 integral weight */
8216 : static GEN
8217 343 : mf2gaexpansion(GEN mf2, GEN F, GEN ga, long n, long prec)
8218 : {
8219 343 : GEN FT = mfmultheta(F), mf = obj_checkbuild(mf2, MF_MF2INIT, &mf2init);
8220 343 : GEN res, V1, Tres, V2, al, V, gsh, C = gcoeff(ga,2,1);
8221 343 : long w2, N = MF_get_N(mf), w = mfcuspcanon_width(N, umodiu(C,N));
8222 343 : long ext = (Mod4(C) != 2)? 0: (w+3) >> 2;
8223 343 : long prec2 = prec + nbits2extraprec((long)M_PI/(2*M_LN2)*sqrt(n + ext));
8224 343 : res = mfgaexpansion(mf, FT, ga, n + ext, prec2);
8225 343 : Tres = mfthetaexpansion(ga, n + ext);
8226 343 : V1 = gel(res,3);
8227 343 : V2 = gel(Tres,3);
8228 343 : al = gsub(gel(res,1), gel(Tres,1));
8229 343 : w2 = itos(gel(Tres,2));
8230 343 : if (w != itos(gel(res,2)) || w % w2)
8231 0 : pari_err_BUG("mf2gaexpansion [incorrect w2 or w]");
8232 343 : if (w2 != w) V2 = bdexpand(V2, w/w2);
8233 343 : V = RgV_div_RgXn(V1, V2);
8234 343 : gsh = gfloor(gmulsg(w, al));
8235 343 : if (!gequal0(gsh))
8236 : {
8237 35 : al = gsub(al, gdivgu(gsh, w));
8238 35 : if (gsigne(gsh) > 0)
8239 : {
8240 0 : V = RgV_shift(V, gsh);
8241 0 : V = vecslice(V, 1, n + 1);
8242 : }
8243 : else
8244 : {
8245 35 : long sh = -itos(gsh), i;
8246 35 : if (sh > ext) pari_err_BUG("mf2gaexpansion [incorrect sh]");
8247 154 : for (i = 1; i <= sh; i++)
8248 119 : if (!gequal0(gel(V,i))) pari_err_BUG("mf2gaexpansion [sh too large]");
8249 35 : V = vecslice(V, sh+1, n + sh+1);
8250 : }
8251 : }
8252 343 : obj_free(mf); return mkvec3(al, stoi(w), gprec_wtrunc(V, prec));
8253 : }
8254 :
8255 : static GEN
8256 70 : mfgaexpansionatkin(GEN mf, GEN F, GEN C, GEN D, long Q, long n, long prec)
8257 : {
8258 70 : GEN mfa = mfatkininit_i(mf, Q, 0, prec), MQ = gel(mfa,2);
8259 70 : long i, FC, k = MF_get_k(mf);
8260 70 : GEN x, v, V, z, s, CHI = mfchartoprimitive(MF_get_CHI(mf), &FC);
8261 :
8262 : /* V = mfcoefs(F | w_Q, n), can't use mfatkin because MQ nonrational */
8263 70 : V = RgM_RgC_mul(mfcoefs_mf(mf,n,1), RgM_RgC_mul(MQ, mftobasis_i(mf,F)));
8264 70 : (void)bezout(utoipos(Q), C, &x, &v);
8265 70 : s = mfchareval(CHI, (umodiu(x, FC) * umodiu(D, FC)) % FC);
8266 70 : s = gdiv(s, gpow(utoipos(Q), uutoQ(k,2), prec));
8267 70 : V = RgV_Rg_mul(V, s);
8268 70 : z = rootsof1powinit(umodiu(D,Q)*umodiu(v,Q) % Q, Q, prec);
8269 8253 : for (i = 1; i <= n+1; i++) gel(V,i) = gmul(gel(V,i), rootsof1pow(z, i-1));
8270 70 : return mkvec3(gen_0, utoipos(Q), V);
8271 : }
8272 :
8273 : static long
8274 70 : inveis_extraprec(long N, GEN ga, GEN Mvecj, long n)
8275 : {
8276 70 : long e, w = mfZC_width(N, gel(ga,1));
8277 70 : GEN f, E = gel(Mvecj,2), v = mfeisensteingacx(E, w, ga, n, DEFAULTPREC);
8278 70 : v = gel(v,2);
8279 70 : f = RgV_to_RgX(v,0); n -= RgX_valrem(f, &f);
8280 70 : e = gexpo(RgXn_inv(f, n+1));
8281 70 : return (e > 0)? nbits2extraprec(e): 0;
8282 : }
8283 : /* allow F of the form [F, mf_eisendec(F)]~ */
8284 : static GEN
8285 1750 : mfgaexpansion(GEN mf, GEN F, GEN ga, long n, long prec)
8286 : {
8287 1750 : GEN v, EF = NULL, res, Mvecj, c, d;
8288 : long precnew, N;
8289 :
8290 1750 : if (n < 0) pari_err_DOMAIN("mfgaexpansion", "n", "<", gen_0, stoi(n));
8291 1750 : if (typ(F) == t_COL && lg(F) == 3) { EF = gel(F,2); F = gel(F,1); }
8292 1750 : if (!checkmf_i(F)) pari_err_TYPE("mfgaexpansion", F);
8293 1750 : if (!check_SL2Z(ga)) pari_err_TYPE("mfgaexpansion",ga);
8294 1750 : if (typ(mf_get_gk(F)) != t_INT) return mf2gaexpansion(mf, F, ga, n, prec);
8295 1407 : c = gcoeff(ga,2,1);
8296 1407 : d = gcoeff(ga,2,2);
8297 1407 : N = MF_get_N(mf);
8298 1407 : if (!umodiu(c, mf_get_N(F)))
8299 : { /* trivial case: ga in Gamma_0(N) */
8300 287 : long w = mfcuspcanon_width(N, umodiu(c,N));
8301 287 : GEN CHI = mf_get_CHI(F);
8302 287 : GEN chid = mfcharcxeval(CHI, umodiu(d,mfcharmodulus(CHI)), prec);
8303 287 : v = mfcoefs_i(F, n/w, 1); if (!isint1(chid)) v = RgV_Rg_mul(v,chid);
8304 287 : return mkvec3(gen_0, stoi(w), bdexpandall(v,w,n+1));
8305 : }
8306 1120 : mf = MF_set_new(mf);
8307 1120 : if (MF_get_space(mf) == mf_NEW)
8308 : {
8309 441 : long cN = umodiu(c,N), g = ugcd(cN,N), Q = N/g;
8310 441 : GEN CHI = MF_get_CHI(mf);
8311 441 : if (ugcd(cN, Q)==1 && mfcharorder(CHI) <= 2
8312 217 : && g % mfcharconductor(CHI) == 0
8313 112 : && degpol(mf_get_field(F)) == 1)
8314 70 : return mfgaexpansionatkin(mf, F, c, d, Q, n, prec);
8315 : }
8316 1050 : Mvecj = obj_checkbuild(mf, MF_EISENSPACE, &mfeisensteinspaceinit);
8317 1050 : precnew = prec;
8318 1050 : if (lg(Mvecj) < 5) precnew += inveis_extraprec(N, ga, Mvecj, n);
8319 1050 : if (!EF) EF = mf_eisendec(mf, F, precnew);
8320 1050 : res = mfgaexpansion_i(mf, EF, ga, n, precnew);
8321 1050 : return precnew == prec ? res : gprec_wtrunc(res, prec);
8322 : }
8323 :
8324 : /* parity = -1 or +1 */
8325 : static GEN
8326 217 : findd(long N, long parity)
8327 : {
8328 217 : GEN L, D = mydivisorsu(N);
8329 217 : long i, j, l = lg(D);
8330 217 : L = cgetg(l, t_VEC);
8331 1218 : for (i = j = 1; i < l; i++)
8332 : {
8333 1001 : long d = D[i];
8334 1001 : if (parity == -1) d = -d;
8335 1001 : if (sisfundamental(d)) gel(L,j++) = stoi(d);
8336 : }
8337 217 : setlg(L,j); return L;
8338 : }
8339 : /* does ND contain a divisor of N ? */
8340 : static int
8341 413 : seenD(long N, GEN ND)
8342 : {
8343 413 : long j, l = lg(ND);
8344 427 : for (j = 1; j < l; j++)
8345 14 : if (N % ND[j] == 0) return 1;
8346 413 : return 0;
8347 : }
8348 : static GEN
8349 56 : search_levels(GEN vN, const char *f)
8350 : {
8351 56 : switch(typ(vN))
8352 : {
8353 21 : case t_INT: vN = mkvecsmall(itos(vN)); break;
8354 35 : case t_VEC: case t_COL: vN = ZV_to_zv(vN); break;
8355 0 : case t_VECSMALL: vN = leafcopy(vN); break;
8356 0 : default: pari_err_TYPE(f, vN);
8357 : }
8358 56 : vecsmall_sort(vN); return vN;
8359 : }
8360 : GEN
8361 28 : mfsearch(GEN NK, GEN V, long space)
8362 : {
8363 28 : pari_sp av = avma;
8364 : GEN F, gk, NbyD, vN;
8365 : long n, nk, dk, parity, nV, i, lvN;
8366 :
8367 28 : if (typ(NK) != t_VEC || lg(NK) != 3) pari_err_TYPE("mfsearch", NK);
8368 28 : gk = gel(NK,2);
8369 28 : if (typ(gmul2n(gk, 1)) != t_INT) pari_err_TYPE("mfsearch [k]", gk);
8370 28 : switch(typ(V))
8371 : {
8372 28 : case t_VEC: V = shallowtrans(V);
8373 28 : case t_COL: break;
8374 0 : default: pari_err_TYPE("mfsearch [V]", V);
8375 : }
8376 28 : vN = search_levels(gel(NK,1), "mfsearch [N]");
8377 28 : if (gequal0(V)) { set_avma(av); retmkvec(mftrivial()); }
8378 14 : lvN = lg(vN);
8379 :
8380 14 : Qtoss(gk, &nk,&dk);
8381 14 : parity = (dk == 1 && odd(nk)) ? -1 : 1;
8382 14 : nV = lg(V)-2;
8383 14 : F = cgetg(1, t_VEC);
8384 14 : NbyD = const_vec(vN[lvN-1], cgetg(1,t_VECSMALL));
8385 231 : for (n = 1; n < lvN; n++)
8386 : {
8387 217 : long N = vN[n];
8388 : GEN L;
8389 217 : if (N <= 0 || (dk == 2 && (N & 3))) continue;
8390 217 : L = findd(N, parity);
8391 630 : for (i = 1; i < lg(L); i++)
8392 : {
8393 413 : GEN mf, M, CO, gD = gel(L,i);
8394 413 : GEN *ND = (GEN*)NbyD + itou(gD); /* points to NbyD[|D|] */
8395 :
8396 413 : if (seenD(N, *ND)) continue;
8397 413 : mf = mfinit_Nndkchi(N, nk, dk, get_mfchar(gD), space, 1);
8398 413 : M = mfcoefs_mf(mf, nV, 1);
8399 413 : CO = inverseimage(M, V); if (lg(CO) == 1) continue;
8400 :
8401 42 : F = vec_append(F, mflinear(mf,CO));
8402 42 : *ND = vecsmall_append(*ND, N); /* add to NbyD[|D|] */
8403 : }
8404 : }
8405 14 : return gerepilecopy(av, F);
8406 : }
8407 :
8408 : static GEN
8409 882 : search_from_split(GEN mf, GEN vap, GEN vlp)
8410 : {
8411 882 : pari_sp av = avma;
8412 882 : long lvlp = lg(vlp), j, jv, l1;
8413 882 : GEN v, NK, S1, S, M = NULL;
8414 :
8415 882 : S1 = gel(split_i(mf, 1, 0), 1); /* rational newforms */
8416 882 : l1 = lg(S1);
8417 882 : if (l1 == 1) return gc_NULL(av);
8418 448 : v = cgetg(l1, t_VEC);
8419 448 : S = MF_get_S(mf);
8420 448 : NK = mf_get_NK(gel(S,1));
8421 448 : if (lvlp > 1) M = rowpermute(mfcoefs_mf(mf, vlp[lvlp-1], 1), vlp);
8422 966 : for (j = jv = 1; j < l1; j++)
8423 : {
8424 518 : GEN vF = gel(S1,j);
8425 : long t;
8426 651 : for (t = lvlp-1; t > 0; t--)
8427 : { /* lhs = vlp[j]-th coefficient of eigenform */
8428 595 : GEN rhs = gel(vap,t), lhs = RgMrow_RgC_mul(M, vF, t);
8429 595 : if (!gequal(lhs, rhs)) break;
8430 : }
8431 518 : if (!t) gel(v,jv++) = mflinear_i(NK,S,vF);
8432 : }
8433 448 : if (jv == 1) return gc_NULL(av);
8434 56 : setlg(v,jv); return v;
8435 : }
8436 : GEN
8437 28 : mfeigensearch(GEN NK, GEN AP)
8438 : {
8439 28 : pari_sp av = avma;
8440 28 : GEN k, vN, vap, vlp, vres = cgetg(1, t_VEC), D;
8441 : long n, lvN, i, l, even;
8442 :
8443 28 : if (!AP) l = 1;
8444 : else
8445 : {
8446 28 : l = lg(AP);
8447 28 : if (typ(AP) != t_VEC) pari_err_TYPE("mfeigensearch",AP);
8448 : }
8449 28 : vap = cgetg(l, t_VEC);
8450 28 : vlp = cgetg(l, t_VECSMALL);
8451 28 : if (l > 1)
8452 : {
8453 28 : GEN perm = indexvecsort(AP, mkvecsmall(1));
8454 77 : for (i = 1; i < l; i++)
8455 : {
8456 49 : GEN v = gel(AP,perm[i]), gp, ap;
8457 49 : if (typ(v) != t_VEC || lg(v) != 3) pari_err_TYPE("mfeigensearch", AP);
8458 49 : gp = gel(v,1);
8459 49 : ap = gel(v,2);
8460 49 : if (typ(gp) != t_INT || (typ(ap) != t_INT && typ(ap) != t_INTMOD))
8461 0 : pari_err_TYPE("mfeigensearch", AP);
8462 49 : gel(vap,i) = ap;
8463 49 : vlp[i] = itos(gp)+1; if (vlp[i] < 0) pari_err_TYPE("mfeigensearch", AP);
8464 : }
8465 : }
8466 28 : l = lg(NK);
8467 28 : if (typ(NK) != t_VEC || l != 3) pari_err_TYPE("mfeigensearch",NK);
8468 28 : k = gel(NK,2);
8469 28 : vN = search_levels(gel(NK,1), "mfeigensearch [N]");
8470 28 : lvN = lg(vN);
8471 28 : vecsmall_sort(vlp);
8472 28 : even = !mpodd(k);
8473 966 : for (n = 1; n < lvN; n++)
8474 : {
8475 938 : pari_sp av2 = avma;
8476 : GEN mf, L;
8477 938 : long N = vN[n];
8478 938 : if (even) D = gen_1;
8479 : else
8480 : {
8481 112 : long r = (N&3L);
8482 112 : if (r == 1 || r == 2) continue;
8483 56 : D = stoi( corediscs(-N, NULL) ); /* < 0 */
8484 : }
8485 882 : mf = mfinit_i(mkvec3(utoipos(N), k, D), mf_NEW);
8486 882 : L = search_from_split(mf, vap, vlp);
8487 882 : if (L) vres = shallowconcat(vres, L); else set_avma(av2);
8488 : }
8489 28 : return gerepilecopy(av, vres);
8490 : }
8491 :
8492 : /* tf_{N,k}(n) */
8493 : static GEN
8494 4479496 : mfnewtracecache(long N, long k, long n, cachenew_t *cache)
8495 : {
8496 4479496 : GEN C = NULL, S;
8497 : long lcache;
8498 4479496 : if (!n) return gen_0;
8499 4342807 : S = gel(cache->vnew,N);
8500 4342807 : lcache = lg(S);
8501 4342807 : if (n < lcache) C = gel(S, n);
8502 4342807 : if (C) cache->newHIT++;
8503 2580436 : else C = mfnewtrace_i(N,k,n,cache);
8504 4342807 : cache->newTOTAL++;
8505 4342807 : if (n < lcache) gel(S,n) = C;
8506 4342807 : return C;
8507 : }
8508 :
8509 : static long
8510 1393 : mfdim_Nkchi(long N, long k, GEN CHI, long space)
8511 : {
8512 1393 : if (k < 0 || badchar(N,k,CHI)) return 0;
8513 1092 : if (k == 0)
8514 35 : return mfcharistrivial(CHI) && !space_is_cusp(space)? 1: 0;
8515 1057 : switch(space)
8516 : {
8517 245 : case mf_NEW: return mfnewdim(N,k,CHI);
8518 196 : case mf_CUSP:return mfcuspdim(N,k,CHI);
8519 168 : case mf_OLD: return mfolddim(N,k,CHI);
8520 217 : case mf_FULL:return mffulldim(N,k,CHI);
8521 231 : case mf_EISEN: return mfeisensteindim(N,k,CHI);
8522 0 : default: pari_err_FLAG("mfdim");
8523 : }
8524 : return 0;/*LCOV_EXCL_LINE*/
8525 : }
8526 : static long
8527 2114 : mf1dimsum(long N, long space)
8528 : {
8529 2114 : switch(space)
8530 : {
8531 1050 : case mf_NEW: return mf1newdimsum(N);
8532 1057 : case mf_CUSP: return mf1cuspdimsum(N);
8533 7 : case mf_OLD: return mf1olddimsum(N);
8534 : }
8535 0 : pari_err_FLAG("mfdim");
8536 : return 0; /*LCOV_EXCL_LINE*/
8537 : }
8538 : /* mfdim for k = nk/dk */
8539 : static long
8540 44744 : mfdim_Nndkchi(long N, long nk, long dk, GEN CHI, long space)
8541 43463 : { return (dk == 2)? mf2dim_Nkchi(N, nk >> 1, CHI, space)
8542 88186 : : mfdim_Nkchi(N, nk, CHI, space); }
8543 : /* FIXME: use direct dim Gamma1(N) formula, don't compute individual spaces */
8544 : static long
8545 252 : mfkdimsum(long N, long k, long dk, long space)
8546 : {
8547 252 : GEN w = mfchars(N, k, dk, NULL);
8548 252 : long i, j, D = 0, l = lg(w);
8549 1239 : for (i = j = 1; i < l; i++)
8550 : {
8551 987 : GEN CHI = gel(w,i);
8552 987 : long d = mfdim_Nndkchi(N,k,dk,CHI,space);
8553 987 : if (d) D += d * myeulerphiu(mfcharorder(CHI));
8554 : }
8555 252 : return D;
8556 : }
8557 : static GEN
8558 105 : mf1dims(long N, GEN vCHI, long space)
8559 : {
8560 105 : GEN D = NULL;
8561 105 : switch(space)
8562 : {
8563 56 : case mf_NEW: D = mf1newdimall(N, vCHI); break;
8564 21 : case mf_CUSP:D = mf1cuspdimall(N, vCHI); break;
8565 28 : case mf_OLD: D = mf1olddimall(N, vCHI); break;
8566 0 : default: pari_err_FLAG("mfdim");
8567 : }
8568 105 : return D;
8569 : }
8570 : static GEN
8571 2961 : mfkdims(long N, long k, long dk, GEN vCHI, long space)
8572 : {
8573 2961 : GEN D, w = mfchars(N, k, dk, vCHI);
8574 2961 : long i, j, l = lg(w);
8575 2961 : D = cgetg(l, t_VEC);
8576 46592 : for (i = j = 1; i < l; i++)
8577 : {
8578 43631 : GEN CHI = gel(w,i);
8579 43631 : long d = mfdim_Nndkchi(N,k,dk,CHI,space);
8580 43631 : if (vCHI)
8581 574 : gel(D, j++) = mkvec2s(d, 0);
8582 43057 : else if (d)
8583 2520 : gel(D, j++) = fmt_dim(CHI, d, 0);
8584 : }
8585 2961 : setlg(D,j); return D;
8586 : }
8587 : GEN
8588 5719 : mfdim(GEN NK, long space)
8589 : {
8590 5719 : pari_sp av = avma;
8591 : long N, k, dk, joker;
8592 : GEN CHI, mf;
8593 5719 : if ((mf = checkMF_i(NK))) return utoi(MF_get_dim(mf));
8594 5586 : checkNK2(NK, &N, &k, &dk, &CHI, 2);
8595 5586 : if (!CHI) joker = 1;
8596 : else
8597 2611 : switch(typ(CHI))
8598 : {
8599 2373 : case t_INT: joker = 2; break;
8600 112 : case t_COL: joker = 3; break;
8601 126 : default: joker = 0; break;
8602 : }
8603 5586 : if (joker)
8604 : {
8605 : long d;
8606 : GEN D;
8607 5460 : if (k < 0) switch(joker)
8608 : {
8609 0 : case 1: return cgetg(1,t_VEC);
8610 7 : case 2: return gen_0;
8611 0 : case 3: return mfdim0all(CHI);
8612 : }
8613 5453 : if (k == 0)
8614 : {
8615 28 : if (space_is_cusp(space)) switch(joker)
8616 : {
8617 7 : case 1: return cgetg(1,t_VEC);
8618 0 : case 2: return gen_0;
8619 7 : case 3: return mfdim0all(CHI);
8620 : }
8621 14 : switch(joker)
8622 : {
8623 : long i, l;
8624 7 : case 1: retmkvec(fmt_dim(mfchartrivial(),0,0));
8625 0 : case 2: return gen_1;
8626 7 : case 3: l = lg(CHI); D = cgetg(l,t_VEC);
8627 35 : for (i = 1; i < l; i++)
8628 : {
8629 28 : long t = mfcharistrivial(gel(CHI,i));
8630 28 : gel(D,i) = mkvec2(t? gen_1: gen_0, gen_0);
8631 : }
8632 7 : return D;
8633 : }
8634 : }
8635 5425 : if (dk == 1 && k == 1 && space != mf_EISEN)
8636 105 : {
8637 2219 : long fix = 0, space0 = space;
8638 2219 : if (space == mf_FULL) space = mf_CUSP; /* remove Eisenstein part */
8639 2219 : if (joker == 2)
8640 : {
8641 2114 : d = mf1dimsum(N, space);
8642 2114 : if (space0 == mf_FULL) d += mfkdimsum(N,k,dk,mf_EISEN);/*add it back*/
8643 2114 : return gc_utoi(av, d);
8644 : }
8645 : /* must initialize explicitly: trivial spaces for E_k/S_k differ */
8646 105 : if (space0 == mf_FULL)
8647 : {
8648 7 : if (!CHI) fix = 1; /* must remove 0 spaces */
8649 7 : CHI = mfchars(N, k, dk, CHI);
8650 : }
8651 105 : D = mf1dims(N, CHI, space);
8652 105 : if (space0 == mf_FULL)
8653 : {
8654 7 : GEN D2 = mfkdims(N, k, dk, CHI, mf_EISEN);
8655 7 : D = merge_dims(D, D2, fix? CHI: NULL);
8656 : }
8657 : }
8658 : else
8659 : {
8660 3206 : if (joker==2) { d = mfkdimsum(N,k,dk,space); return gc_utoi(av,d); }
8661 2954 : D = mfkdims(N, k, dk, CHI, space);
8662 : }
8663 3059 : if (!CHI) return gerepileupto(av, vecsort(D, mkvecsmall(1)));
8664 105 : return gerepilecopy(av, D);
8665 : }
8666 126 : return utoi( mfdim_Nndkchi(N, k, dk, CHI, space) );
8667 : }
8668 :
8669 : GEN
8670 315 : mfbasis(GEN NK, long space)
8671 : {
8672 315 : pari_sp av = avma;
8673 : long N, k, dk;
8674 : GEN mf, CHI;
8675 315 : if ((mf = checkMF_i(NK))) return gconcat(gel(mf,2), gel(mf,3));
8676 7 : checkNK2(NK, &N, &k, &dk, &CHI, 0);
8677 7 : if (dk == 2) return gerepilecopy(av, mf2basis(N, k>>1, CHI, NULL, space));
8678 7 : mf = mfinit_Nkchi(N, k, CHI, space, 1);
8679 7 : return gerepilecopy(av, MF_get_basis(mf));
8680 : }
8681 :
8682 : static GEN
8683 49 : deg1ser_shallow(GEN a1, GEN a0, long v, long e)
8684 49 : { return RgX_to_ser(deg1pol_shallow(a1, a0, v), e+2); }
8685 : /* r / x + O(1) */
8686 : static GEN
8687 49 : simple_pole(GEN r)
8688 : {
8689 49 : GEN S = deg1ser_shallow(gen_0, r, 0, 1);
8690 49 : setvalser(S, -1); return S;
8691 : }
8692 :
8693 : /* F form, E embedding; mfa = mfatkininit or root number (eigenform case) */
8694 : static GEN
8695 161 : mflfuncreate(GEN mfa, GEN F, GEN E, GEN N, GEN gk)
8696 : {
8697 161 : GEN LF = cgetg(8,t_VEC), polar = cgetg(1,t_COL), eps;
8698 161 : long k = itou(gk);
8699 161 : gel(LF,1) = lfuntag(t_LFUN_MFCLOS, mkvec3(F,E,gen_1));
8700 161 : if (typ(mfa) != t_VEC)
8701 98 : eps = mfa; /* cuspidal eigenform: root number; no poles */
8702 : else
8703 : { /* mfatkininit */
8704 63 : GEN a0, b0, vF, vG, G = NULL;
8705 63 : GEN M = gel(mfa,2), C = gel(mfa,3), mf = gel(mfa,4);
8706 63 : M = gdiv(mfmatembed(E, M), C);
8707 63 : vF = mfvecembed(E, mftobasis_i(mf, F));
8708 63 : vG = RgM_RgC_mul(M, vF);
8709 63 : if (gequal(vF,vG)) eps = gen_1;
8710 49 : else if (gequal(vF,gneg(vG))) eps = gen_m1;
8711 : else
8712 : { /* not self-dual */
8713 42 : eps = NULL;
8714 42 : G = mfatkin(mfa, F);
8715 42 : gel(LF,2) = lfuntag(t_LFUN_MFCLOS, mkvec3(G,E,ginv(C)));
8716 42 : gel(LF,6) = powIs(k);
8717 : }
8718 : /* polar part */
8719 63 : a0 = mfembed(E, mfcoef(F,0));
8720 63 : b0 = eps? gmul(eps,a0): gdiv(mfembed(E, mfcoef(G,0)), C);
8721 63 : if (!gequal0(b0))
8722 : {
8723 28 : b0 = mulcxpowIs(gmul2n(b0,1), k);
8724 28 : polar = vec_append(polar, mkvec2(gk, simple_pole(b0)));
8725 : }
8726 63 : if (!gequal0(a0))
8727 : {
8728 21 : a0 = gneg(gmul2n(a0,1));
8729 21 : polar = vec_append(polar, mkvec2(gen_0, simple_pole(a0)));
8730 : }
8731 : }
8732 161 : if (eps) /* self-dual */
8733 : {
8734 119 : gel(LF,2) = mfcharorder(mf_get_CHI(F)) <= 2? gen_0: gen_1;
8735 119 : gel(LF,6) = mulcxpowIs(eps,k);
8736 : }
8737 161 : gel(LF,3) = mkvec2(gen_0, gen_1);
8738 161 : gel(LF,4) = gk;
8739 161 : gel(LF,5) = N;
8740 161 : if (lg(polar) == 1) setlg(LF,7); else gel(LF,7) = polar;
8741 161 : return LF;
8742 : }
8743 : static GEN
8744 133 : mflfuncreateall(long sd, GEN mfa, GEN F, GEN vE, GEN gN, GEN gk)
8745 : {
8746 133 : long i, l = lg(vE);
8747 133 : GEN L = cgetg(l, t_VEC);
8748 294 : for (i = 1; i < l; i++)
8749 161 : gel(L,i) = mflfuncreate(sd? gel(mfa,i): mfa, F, gel(vE,i), gN, gk);
8750 133 : return L;
8751 : }
8752 : GEN
8753 84 : lfunmf(GEN mf, GEN F, long bitprec)
8754 : {
8755 84 : pari_sp av = avma;
8756 84 : long i, l, prec = nbits2prec(bitprec);
8757 : GEN L, gk, gN;
8758 84 : mf = checkMF(mf);
8759 84 : gk = MF_get_gk(mf);
8760 84 : gN = MF_get_gN(mf);
8761 84 : if (typ(gk)!=t_INT) pari_err_IMPL("half-integral weight");
8762 84 : if (F)
8763 : {
8764 : GEN v;
8765 77 : long s = MF_get_space(mf);
8766 77 : if (!checkmf_i(F)) pari_err_TYPE("lfunmf", F);
8767 77 : if (!mfisinspace_i(mf, F)) err_space(F);
8768 77 : L = NULL;
8769 77 : if ((s == mf_NEW || s == mf_CUSP || s == mf_FULL)
8770 63 : && gequal(mfcoefs_i(F,1,1), mkvec2(gen_0,gen_1)))
8771 : { /* check if eigenform */
8772 35 : GEN vP, vF, b = mftobasis_i(mf, F);
8773 35 : long lF, d = degpol(mf_get_field(F));
8774 35 : v = mfsplit(mf, d, 0);
8775 35 : vF = gel(v,1);
8776 35 : vP = gel(v,2); lF = lg(vF);
8777 35 : for (i = 1; i < lF; i++)
8778 28 : if (degpol(gel(vP,i)) == d && gequal(gel(vF,i), b))
8779 : {
8780 28 : GEN vE = mfgetembed(F, prec);
8781 28 : GEN Z = mffrickeeigen_i(mf, mkvec(b), mkvec(vE), prec);
8782 28 : L = mflfuncreateall(1, gel(Z,1), F, vE, gN, gk);
8783 28 : break;
8784 : }
8785 : }
8786 77 : if (!L)
8787 : { /* not an eigenform: costly general case */
8788 49 : GEN mfa = mfatkininit_i(mf, itou(gN), 1, prec);
8789 49 : L = mflfuncreateall(0,mfa, F, mfgetembed(F,prec), gN, gk);
8790 : }
8791 77 : if (lg(L) == 2) L = gel(L,1);
8792 : }
8793 : else
8794 : {
8795 7 : GEN M = mfeigenbasis(mf), vE = mfeigenembed(mf, prec);
8796 7 : GEN v = mffrickeeigen(mf, vE, prec);
8797 7 : l = lg(vE); L = cgetg(l, t_VEC);
8798 63 : for (i = 1; i < l; i++)
8799 56 : gel(L,i) = mflfuncreateall(1,gel(v,i), gel(M,i), gel(vE,i), gN, gk);
8800 : }
8801 84 : return gerepilecopy(av, L);
8802 : }
8803 :
8804 : GEN
8805 28 : mffromell(GEN E)
8806 : {
8807 28 : pari_sp av = avma;
8808 : GEN mf, F, z, v, S;
8809 : long N, i, l;
8810 :
8811 28 : checkell(E);
8812 28 : if (ell_get_type(E) != t_ELL_Q) pari_err_TYPE("mfffromell [E not over Q]", E);
8813 28 : N = itos(ellQ_get_N(E));
8814 28 : mf = mfinit_i(mkvec2(utoi(N), gen_2), mf_NEW);
8815 28 : v = split_i(mf, 1, 0);
8816 28 : S = gel(v,1); l = lg(S); /* rational newforms */
8817 28 : F = tag(t_MF_ELL, mkNK(N,2,mfchartrivial()), E);
8818 28 : z = mftobasis_i(mf, F);
8819 28 : for(i = 1; i < l; i++)
8820 28 : if (gequal(z, gel(S,i))) break;
8821 28 : if (i == l) pari_err_BUG("mffromell [E is not modular]");
8822 28 : return gerepilecopy(av, mkvec3(mf, F, z));
8823 : }
8824 :
8825 : /* returns -1 if not, degree otherwise */
8826 : long
8827 140 : polishomogeneous(GEN P)
8828 : {
8829 : long i, D, l;
8830 140 : if (typ(P) != t_POL) return 0;
8831 77 : D = -1; l = lg(P);
8832 322 : for (i = 2; i < l; i++)
8833 : {
8834 245 : GEN c = gel(P,i);
8835 : long d;
8836 245 : if (gequal0(c)) continue;
8837 112 : d = polishomogeneous(c);
8838 112 : if (d < 0) return -1;
8839 112 : if (D < 0) D = d + i-2; else if (D != d + i-2) return -1;
8840 : }
8841 77 : return D;
8842 : }
8843 :
8844 : /* M a pp((Gram q)^(-1)) ZM; P a homogeneous t_POL, is P spherical ? */
8845 : static int
8846 28 : RgX_isspherical(GEN M, GEN P)
8847 : {
8848 28 : pari_sp av = avma;
8849 28 : GEN S, v = variables_vecsmall(P);
8850 28 : long i, j, l = lg(v);
8851 28 : if (l > lg(M)) pari_err(e_MISC, "too many variables in mffromqf");
8852 21 : S = gen_0;
8853 63 : for (j = 1; j < l; j++)
8854 : {
8855 42 : GEN Mj = gel(M, j), Pj = deriv(P, v[j]);
8856 105 : for (i = 1; i <= j; i++)
8857 : {
8858 63 : GEN c = gel(Mj, i);
8859 63 : if (!signe(c)) continue;
8860 42 : if (i != j) c = shifti(c, 1);
8861 42 : S = gadd(S, gmul(c, deriv(Pj, v[i])));
8862 : }
8863 : }
8864 21 : return gc_bool(av, gequal0(S));
8865 : }
8866 :
8867 : static GEN
8868 49 : c_QFsimple_i(long n, GEN Q, GEN P)
8869 : {
8870 49 : GEN V, v = qfrep0(Q, utoi(n), 1);
8871 49 : long i, l = lg(v);
8872 49 : V = cgetg(l+1, t_VEC);
8873 49 : if (!P || equali1(P))
8874 : {
8875 42 : gel(V,1) = gen_1;
8876 420 : for (i = 2; i <= l; i++) gel(V,i) = utoi(v[i-1] << 1);
8877 : }
8878 : else
8879 : {
8880 7 : gel(V,1) = gcopy(P);
8881 7 : for (i = 2; i <= l; i++) gel(V,i) = gmulgu(P, v[i-1] << 1);
8882 : }
8883 49 : return V;
8884 : }
8885 :
8886 : /* v a t_VECSMALL of variable numbers, lg(r) >= lg(v), r is a vector of
8887 : * scalars [not involving any variable in v] */
8888 : static GEN
8889 14 : gsubstvec_i(GEN e, GEN v, GEN r)
8890 : {
8891 14 : long i, l = lg(v);
8892 42 : for(i = 1; i < l; i++) e = gsubst(e, v[i], gel(r,i));
8893 14 : return e;
8894 : }
8895 : static GEN
8896 56 : c_QF_i(long n, GEN Q, GEN P)
8897 : {
8898 56 : pari_sp av = avma;
8899 : GEN V, v, va;
8900 : long i, l;
8901 56 : if (!P || typ(P) != t_POL) return gerepileupto(av, c_QFsimple_i(n, Q, P));
8902 7 : v = gel(minim(Q, utoi(2*n), NULL), 3);
8903 7 : va = variables_vecsmall(P);
8904 7 : V = zerovec(n + 1); l = lg(v);
8905 21 : for (i = 1; i < l; i++)
8906 : {
8907 14 : pari_sp av = avma;
8908 14 : GEN X = gel(v,i);
8909 14 : long c = (itos(qfeval(Q, X)) >> 1) + 1;
8910 14 : gel(V, c) = gerepileupto(av, gadd(gel(V, c), gsubstvec_i(P, va, X)));
8911 : }
8912 7 : return gmul2n(V, 1);
8913 : }
8914 :
8915 : GEN
8916 77 : mffromqf(GEN Q, GEN P)
8917 : {
8918 77 : pari_sp av = avma;
8919 : GEN G, Qi, F, D, N, mf, v, gk, chi;
8920 : long m, d, space;
8921 77 : if (typ(Q) != t_MAT) pari_err_TYPE("mffromqf", Q);
8922 77 : if (!RgM_is_ZM(Q) || !qfiseven(Q))
8923 0 : pari_err_TYPE("mffromqf [not integral or even]", Q);
8924 77 : m = lg(Q)-1;
8925 77 : Qi = ZM_inv(Q, &N);
8926 77 : if (!qfiseven(Qi)) N = shifti(N, 1);
8927 77 : d = 0;
8928 77 : if (!P || gequal1(P)) P = NULL;
8929 : else
8930 : {
8931 35 : P = simplify_shallow(P);
8932 35 : if (typ(P) == t_POL)
8933 : {
8934 28 : d = polishomogeneous(P);
8935 28 : if (d < 0) pari_err_TYPE("mffromqf [not homogeneous t_POL]", P);
8936 28 : if (!RgX_isspherical(Qi, P))
8937 7 : pari_err_TYPE("mffromqf [not a spherical t_POL]", P);
8938 : }
8939 : }
8940 63 : gk = uutoQ(m + 2*d, 2);
8941 63 : D = ZM_det(Q);
8942 63 : if (!odd(m)) { if ((m & 3) == 2) D = negi(D); } else D = shifti(D, 1);
8943 63 : space = d > 0 ? mf_CUSP : mf_FULL;
8944 63 : G = znstar0(N,1);
8945 63 : chi = mkvec2(G, znchar_quad(G,D));
8946 63 : mf = mfinit(mkvec3(N, gk, chi), space);
8947 63 : if (odd(d))
8948 : {
8949 7 : F = mftrivial();
8950 7 : v = zerocol(MF_get_dim(mf));
8951 : }
8952 : else
8953 : {
8954 56 : F = c_QF_i(mfsturm(mf), Q, P);
8955 56 : v = mftobasis_i(mf, F);
8956 56 : F = mflinear(mf, v);
8957 : }
8958 63 : return gerepilecopy(av, mkvec3(mf, F, v));
8959 : }
8960 :
8961 : /***********************************************************************/
8962 : /* Eisenstein Series */
8963 : /***********************************************************************/
8964 : /* \sigma_{k-1}(\chi,n) */
8965 : static GEN
8966 24192 : sigchi(long k, GEN CHI, long n)
8967 : {
8968 24192 : pari_sp av = avma;
8969 24192 : GEN S = gen_1, D = mydivisorsu(u_ppo(n,mfcharmodulus(CHI)));
8970 24192 : long i, l = lg(D), ord = mfcharorder(CHI), vt = varn(mfcharpol(CHI));
8971 83671 : for (i = 2; i < l; i++) /* skip D[1] = 1 */
8972 : {
8973 59479 : long d = D[i], a = mfcharevalord(CHI, d, ord);
8974 |
