1 // -*- mode:C++ ; compile-command: "g++ -I. -I.. -I../include -g -c vecteur.cc -fno-strict-aliasing -DGIAC_GENERIC_CONSTANTS -DHAVE_CONFIG_H -DIN_GIAC" -*-
2 #include "giacPCH.h"
3 /*
4  *  Copyright (C) 2000,14 B. Parisse, Institut Fourier, 38402 St Martin d'Heres
5  *
6  *  This program is free software; you can redistribute it and/or modify
7  *  it under the terms of the GNU General Public License as published by
8  *  the Free Software Foundation; either version 3 of the License, or
9  *  (at your option) any later version.
10  *
11  *  This program is distributed in the hope that it will be useful,
12  *  but WITHOUT ANY WARRANTY; without even the implied warranty of
13  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14  *  GNU General Public License for more details.
15  *
16  *  You should have received a copy of the GNU General Public License
17  *  along with this program. If not, see <http://www.gnu.org/licenses/>.
18  */
19 using namespace std;
20 #include <cmath>
21 #include <stdexcept>
22 #include <map>
23 #include <iostream>
24 #if defined HAVE_SSTREAM || defined FXCG
25 #include <sstream>
26 #else
27 #include <strstream>
28 #endif
29 #if !defined GIAC_HAS_STO_38 && !defined NSPIRE && !defined FXCG && !defined POCKETCAS
30 #include <fstream>
31 #endif
32 #include "gen.h"
33 #include "vecteur.h"
34 #include "modpoly.h"
35 #include "unary.h"
36 #include "symbolic.h"
37 #include "usual.h"
38 #include "sym2poly.h"
39 #include "solve.h"
40 #include "prog.h"
41 #include "subst.h"
42 #include "permu.h"
43 #include "plot.h"
44 #include "misc.h"
45 #include "ti89.h"
46 #include "csturm.h"
47 #include "sparse.h"
48 #include "modfactor.h"
49 #include "quater.h"
50 #include "giacintl.h"
51 #ifdef HAVE_LIBGSL
52 #include <gsl/gsl_linalg.h>
53 #include <gsl/gsl_eigen.h>
54 #include <gsl/gsl_poly.h>
55 #endif
56 
57 // Apple has the Accelerate framework for lapack if you did not install Atlas/lapack
58 // (link with -framewrok Accelerate)
59 // it is not used by default because the Accelerate version is slower
60 // than the current Atlas, at least on OSX.6, and is also slower than giac built-in
61 
62 #if !defined(APPLE_SMART) && !defined(DONT_USE_LIBLAPLACK)
63 #if defined __APPLE__ && !defined(HAVE_LIBLAPACK) && !defined(USE_GMP_REPLACEMENTS)
64 #define HAVE_LIBLAPACK
65 #endif
66 // for pocketcas compat.
67 #if defined(HAVE_LIBCLAPACK) && !defined(HAVE_LIBLAPACK)
68 #define HAVE_LIBLAPACK
69 #endif
70 #endif // APPLE_SMART
71 
72 // Note that Atlas is slower than built-in for real matrices diago for n < about 1000
73 // and complex matrices diago for n<300
74 // the global variable CALL_LAPACK is set to 1111 by default
75 // can be modified from icas/xcas using lapack_limit() or shell variable GIAC_LAPACK
76 // #undef HAVE_LIBLAPACK
77 
78 #ifdef HAVE_LIBLAPACK
79 #include <f2c.h>
80 #include <clapack.h>
81 #ifdef POCKETCAS
82 #if defined(__LP64__) && defined(__ARMv8__)
83 #undef __x86_64__
84 #endif
85 #include <Accelerate/Accelerate.h>
86 #if defined(__LP64__) && defined(__ARMv8__)
87 #define __x86_64__
88 #endif
89 #endif // POCKETCAS
90 #undef abs
91 #undef min
92 #endif
93 
94 #if defined __i386__ && !defined PIC && !defined __APPLE__ && !defined _I386_
95 //#define _I386_
96 // commented because it will fail with -O2 optimizations under gcc >= 4.3
97 // on Ubuntu 11.04 in Mac VirtualBox
98 #endif
99 
100 #ifdef USTL
101 namespace ustl {
operator >(const giac::index_t & a,const giac::index_t & b)102   inline bool operator > (const giac::index_t & a,const giac::index_t & b){
103     if (a.size()!=b.size())
104       return a.size()>b.size();
105     return !giac::all_inf_equal(a,b);
106   }
operator <(const giac::index_t & a,const giac::index_t & b)107   inline bool operator < (const giac::index_t & a,const giac::index_t & b){
108     if (a.size()!=b.size())
109       return a.size()<b.size();
110     return !giac::all_sup_equal(a,b);
111   }
112 }
113 #endif
114 
115 #ifndef NO_NAMESPACE_GIAC
116 namespace giac {
117 #endif // ndef NO_NAMESPACE_GIAC
nbits(const gen & g)118   unsigned nbits(const gen & g){
119     if (g.type==_INT_)
120       return sizeinbase2(g.val>0?g.val:-g.val);
121     else
122       return mpz_sizeinbase(*g._ZINTptr,2);
123   }
124 
125 #if defined(GIAC_HAS_STO_38) && defined(VISUALC)
126   static const int rand_max=2147483647;
127 #else
128   static const int rand_max=RAND_MAX;
129 #endif
130 
131 #ifdef _I386_
132   // a->a+b*c mod m
mod(int & a,int b,int c,int m)133   inline void mod(int & a,int b,int c,int m){
134     if (c){
135       asm volatile("testl %%ebx,%%ebx\n\t" /* sign bit=1 if negative */
136 		   "jns .Lok%=\n\t"
137 		   "addl %%edi,%%ebx\n" /* a+=m*/
138 		   ".Lok%=:\t"
139 		   "imull %%ecx; \n\t" /* b*c in edx:eax */
140 		   "addl %%ebx,%%eax; \n\t" /* b*c+a */
141 		   "adcl $0x0,%%edx; \n\t" /* b*c+a carry */
142 		   "idivl %%edi; \n\t"
143 		   :"=d"(a)
144 		   :"a"(b),"b"(a),"c"(c),"D"(m)
145 		   );
146     }
147   }
148 
149   // a->a+b*c mod m
smod(int a,int b,int c,int m)150   inline int smod(int a,int b,int c,int m){
151     if (c){
152       if (a<0) a+=m;
153       asm volatile("imull %%ecx; \n\t" /* b*c in edx:eax */
154 		   "addl %%ebx,%%eax; \n\t" /* b*c+a */
155 		   "adcl $0x0,%%edx; \n\t" /* b*c+a carry */
156 		   "idivl %%edi; \n\t"
157 		   :"=d"(a)
158 		   :"a"(b),"b"(a),"c"(c),"D"(m)
159 		   );
160     }
161     return a;
162   }
163 #else
164   // a->a+b*c mod m
mod(int & a,int b,int c,int m)165   inline void mod(int & a,int b,int c,int m){
166     a = (a + longlong(b)*c)%m;
167   }
168 
169   // a->a+b*c mod m
smod(int a,int b,int c,int m)170   inline int smod(int a,int b,int c,int m){
171     return (a + longlong(b)*c)%m;
172   }
173 
174 #endif
175 
makevecteur(const gen & a,const gen & b)176   vecteur makevecteur(const gen & a,const gen & b){
177     vecteur v(2);
178     v[0]=a;
179     v[1]=b;
180     return v;
181   }
182 
makevecteur(const gen & a,const gen & b,const gen & c)183   vecteur makevecteur(const gen & a,const gen & b,const gen & c){
184     vecteur v(3);
185     v[0]=a;
186     v[1]=b;
187     v[2]=c;
188     return v;
189   }
190 
makevecteur(const gen & a)191   vecteur makevecteur(const gen & a){
192     return vecteur(1,a);
193   }
194 
makevecteur(const gen & a,const gen & b,const gen & c,const gen & d)195   vecteur makevecteur(const gen & a,const gen & b,const gen & c,const gen & d){
196     vecteur v(4);
197     v[0]=a;
198     v[1]=b;
199     v[2]=c;
200     v[3]=d;
201     return v;
202   }
203 
makevecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e)204   vecteur makevecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e){
205     vecteur v(5);
206     v[0]=a;
207     v[1]=b;
208     v[2]=c;
209     v[3]=d;
210     v[4]=e;
211     return v;
212   }
213 
makevecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f)214   vecteur makevecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f){
215     vecteur v(6);
216     v[0]=a;
217     v[1]=b;
218     v[2]=c;
219     v[3]=d;
220     v[4]=e;
221     v[5]=f;
222     return v;
223   }
224 
makevecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f,const gen & g)225   vecteur makevecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f,const gen & g){
226     vecteur v(7);
227     v[0]=a;
228     v[1]=b;
229     v[2]=c;
230     v[3]=d;
231     v[4]=e;
232     v[5]=f;
233     v[6]=g;
234     return v;
235   }
236 
makevecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f,const gen & g,const gen & h)237   vecteur makevecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f,const gen & g,const gen & h){
238     vecteur v(8);
239     v[0]=a;
240     v[1]=b;
241     v[2]=c;
242     v[3]=d;
243     v[4]=e;
244     v[5]=f;
245     v[6]=g;
246     v[7]=h;
247     return v;
248   }
249 
makevecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f,const gen & g,const gen & h,const gen & i)250   vecteur makevecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f,const gen & g,const gen & h,const gen & i){
251     vecteur v(9);
252     v[0]=a;
253     v[1]=b;
254     v[2]=c;
255     v[3]=d;
256     v[4]=e;
257     v[5]=f;
258     v[6]=g;
259     v[7]=h;
260     v[8]=i;
261     return v;
262   }
263 
makevecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f,const gen & g,const gen & h,const gen & i,const gen & j)264   vecteur makevecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f,const gen & g,const gen & h,const gen & i,const gen &j){
265     vecteur v(10);
266     v[0]=a;
267     v[1]=b;
268     v[2]=c;
269     v[3]=d;
270     v[4]=e;
271     v[5]=f;
272     v[6]=g;
273     v[7]=h;
274     v[8]=i;
275     v[9]=j;
276     return v;
277   }
278 
makevecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f,const gen & g,const gen & h,const gen & i,const gen & j,const gen & k)279   vecteur makevecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f,const gen & g,const gen & h,const gen & i,const gen &j,const gen & k){
280     vecteur v(11);
281     v[0]=a;
282     v[1]=b;
283     v[2]=c;
284     v[3]=d;
285     v[4]=e;
286     v[5]=f;
287     v[6]=g;
288     v[7]=h;
289     v[8]=i;
290     v[9]=j;
291     v[10]=k;
292     return v;
293   }
294 
makevecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f,const gen & g,const gen & h,const gen & i,const gen & j,const gen & k,const gen & l)295   vecteur makevecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f,const gen & g,const gen & h,const gen & i,const gen &j,const gen & k,const gen & l){
296     vecteur v(12);
297     v[0]=a;
298     v[1]=b;
299     v[2]=c;
300     v[3]=d;
301     v[4]=e;
302     v[5]=f;
303     v[6]=g;
304     v[7]=h;
305     v[8]=i;
306     v[9]=j;
307     v[10]=k;
308     v[11]=l;
309     return v;
310   }
311 
makevecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f,const gen & g,const gen & h,const gen & i,const gen & j,const gen & k,const gen & l,const gen & m)312   vecteur makevecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f,const gen & g,const gen & h,const gen & i,const gen &j,const gen & k,const gen & l,const gen & m){
313     vecteur v(13);
314     v[0]=a;
315     v[1]=b;
316     v[2]=c;
317     v[3]=d;
318     v[4]=e;
319     v[5]=f;
320     v[6]=g;
321     v[7]=h;
322     v[8]=i;
323     v[9]=j;
324     v[10]=k;
325     v[11]=l;
326     v[12]=m;
327     return v;
328   }
329 
makevecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f,const gen & g,const gen & h,const gen & i,const gen & j,const gen & k,const gen & l,const gen & m,const gen & n)330   vecteur makevecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f,const gen & g,const gen & h,const gen & i,const gen &j,const gen & k,const gen & l,const gen & m,const gen& n){
331     vecteur v(14);
332     v[0]=a;
333     v[1]=b;
334     v[2]=c;
335     v[3]=d;
336     v[4]=e;
337     v[5]=f;
338     v[6]=g;
339     v[7]=h;
340     v[8]=i;
341     v[9]=j;
342     v[10]=k;
343     v[11]=l;
344     v[12]=m;
345     v[13]=n;
346     return v;
347   }
348 
makesequence(const gen & a)349   gen makesequence(const gen & a){
350     return gen(vecteur(1,a),_SEQ__VECT);
351   }
352 
makesequence(const gen & a,const gen & b)353   gen makesequence(const gen & a,const gen & b){
354     vecteur v(2);
355     v[0]=a;
356     v[1]=b;
357     return gen(v,_SEQ__VECT);
358   }
359 
makesequence(const gen & a,const gen & b,const gen & c)360   gen makesequence(const gen & a,const gen & b,const gen & c){
361     vecteur v(3);
362     v[0]=a;
363     v[1]=b;
364     v[2]=c;
365     return gen(v,_SEQ__VECT);
366   }
367 
makesequence(const gen & a,const gen & b,const gen & c,const gen & d)368   gen makesequence(const gen & a,const gen & b,const gen & c,const gen & d){
369     vecteur v(4);
370     v[0]=a;
371     v[1]=b;
372     v[2]=c;
373     v[3]=d;
374     return gen(v,_SEQ__VECT);
375   }
376 
makesequence(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e)377   gen makesequence(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e){
378     vecteur v(5);
379     v[0]=a;
380     v[1]=b;
381     v[2]=c;
382     v[3]=d;
383     v[4]=e;
384     return gen(v,_SEQ__VECT);
385   }
386 
makesequence(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f)387   gen makesequence(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f){
388     vecteur v(6);
389     v[0]=a;
390     v[1]=b;
391     v[2]=c;
392     v[3]=d;
393     v[4]=e;
394     v[5]=f;
395     return gen(v,_SEQ__VECT);
396   }
397 
makesequence(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f,const gen & g)398   gen makesequence(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f,const gen & g){
399     vecteur v(7);
400     v[0]=a;
401     v[1]=b;
402     v[2]=c;
403     v[3]=d;
404     v[4]=e;
405     v[5]=f;
406     v[6]=g;
407     return gen(v,_SEQ__VECT);
408   }
409 
makesequence(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f,const gen & g,const gen & h)410   gen makesequence(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f,const gen & g,const gen & h){
411     vecteur v(8);
412     v[0]=a;
413     v[1]=b;
414     v[2]=c;
415     v[3]=d;
416     v[4]=e;
417     v[5]=f;
418     v[6]=g;
419     v[7]=h;
420     return gen(v,_SEQ__VECT);
421   }
422 
makesequence(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f,const gen & g,const gen & h,const gen & i)423   gen makesequence(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f,const gen & g,const gen & h,const gen & i){
424     vecteur v(9);
425     v[0]=a;
426     v[1]=b;
427     v[2]=c;
428     v[3]=d;
429     v[4]=e;
430     v[5]=f;
431     v[6]=g;
432     v[7]=h;
433     v[8]=i;
434     return gen(v,_SEQ__VECT);
435   }
436 
makenewvecteur(const gen & a)437   ref_vecteur * makenewvecteur(const gen & a){
438     return new_ref_vecteur(vecteur(1,a));
439   }
440 
makenewvecteur(const gen & a,const gen & b)441   ref_vecteur * makenewvecteur(const gen & a,const gen & b){
442     ref_vecteur *vptr=new_ref_vecteur(0);
443     vptr->v.reserve(2);
444     vptr->v.push_back(a);
445     vptr->v.push_back(b);
446     return vptr;
447   }
448 
makenewvecteur(const gen & a,const gen & b,const gen & c)449   ref_vecteur * makenewvecteur(const gen & a,const gen & b,const gen & c){
450     ref_vecteur * vptr=new_ref_vecteur(0);
451     vptr->v.reserve(3);
452     vptr->v.push_back(a);
453     vptr->v.push_back(b);
454     vptr->v.push_back(c);
455     return vptr;
456   }
457 
makenewvecteur(const gen & a,const gen & b,const gen & c,const gen & d)458   ref_vecteur * makenewvecteur(const gen & a,const gen & b,const gen & c,const gen & d){
459     ref_vecteur * vptr=new_ref_vecteur(0);
460     vptr->v.reserve(4);
461     vptr->v.push_back(a);
462     vptr->v.push_back(b);
463     vptr->v.push_back(c);
464     vptr->v.push_back(d);
465     return vptr;
466   }
467 
makenewvecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e)468   ref_vecteur * makenewvecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e){
469     ref_vecteur * vptr=new_ref_vecteur(0);
470     vptr->v.reserve(5);
471     vptr->v.push_back(a);
472     vptr->v.push_back(b);
473     vptr->v.push_back(c);
474     vptr->v.push_back(d);
475     vptr->v.push_back(e);
476     return vptr;
477   }
478 
makenewvecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f)479   ref_vecteur * makenewvecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f){
480     ref_vecteur * vptr=new_ref_vecteur(0);
481     vptr->v.reserve(6);
482     vptr->v.push_back(a);
483     vptr->v.push_back(b);
484     vptr->v.push_back(c);
485     vptr->v.push_back(d);
486     vptr->v.push_back(e);
487     vptr->v.push_back(f);
488     return vptr;
489   }
490 
makenewvecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f,const gen & g)491   ref_vecteur * makenewvecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f,const gen & g){
492     ref_vecteur * vptr=new_ref_vecteur(0);
493     vptr->v.reserve(7);
494     vptr->v.push_back(a);
495     vptr->v.push_back(b);
496     vptr->v.push_back(c);
497     vptr->v.push_back(d);
498     vptr->v.push_back(e);
499     vptr->v.push_back(f);
500     vptr->v.push_back(g);
501     return vptr;
502   }
503 
makenewvecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f,const gen & g,const gen & h)504   ref_vecteur * makenewvecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f,const gen & g,const gen & h){
505     ref_vecteur * vptr=new_ref_vecteur(0);
506     vptr->v.reserve(8);
507     vptr->v.push_back(a);
508     vptr->v.push_back(b);
509     vptr->v.push_back(c);
510     vptr->v.push_back(d);
511     vptr->v.push_back(e);
512     vptr->v.push_back(f);
513     vptr->v.push_back(g);
514     vptr->v.push_back(h);
515     return vptr;
516   }
517 
makenewvecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f,const gen & g,const gen & h,const gen & i)518   ref_vecteur * makenewvecteur(const gen & a,const gen & b,const gen & c,const gen & d,const gen & e,const gen & f,const gen & g,const gen & h,const gen & i){
519     ref_vecteur * vptr=new_ref_vecteur(0);
520     vptr->v.reserve(9);
521     vptr->v.push_back(a);
522     vptr->v.push_back(b);
523     vptr->v.push_back(c);
524     vptr->v.push_back(d);
525     vptr->v.push_back(e);
526     vptr->v.push_back(f);
527     vptr->v.push_back(g);
528     vptr->v.push_back(h);
529     vptr->v.push_back(i);
530     return vptr;
531   }
532 
533   // make a matrix with free rows
534   // (i.e. it is possible to modify the answer in place)
makefreematrice(const matrice & m)535   matrice makefreematrice(const matrice & m){
536     matrice res(m);
537     int s=int(m.size());
538     for (int i=0;i<s;++i){
539       if (m[i].type==_VECT){
540 	res[i]=makefreematrice(*m[i]._VECTptr);
541       }
542     }
543     return res;
544   }
545 
transpose_double(const matrix_double & a,int r0,int r1,int c0,int c1,matrix_double & at)546   void transpose_double(const matrix_double & a,int r0,int r1,int c0,int c1,matrix_double & at){
547     int L=int(a.size()),C=int(a.front().size());
548     if (r0<0) r0=0;
549     if (r1<=r0)
550       r1=L;
551     if (c1<0) c1=0;
552     if (c1<=c0)
553       c1=C;
554     if (r1>L) r1=L;
555     if (c1>C) c1=C;
556     L=r1-r0; C=c1-c0;
557     at.resize(C);
558     for (int i=0;i<C;++i)
559       at[i].resize(L);
560     for (int i=0;i<L;++i){
561       const vector<giac_double> & ai=a[r0+i];
562       for (int j=0;j<C;++j){
563 	at[j][i]=ai[c0+j];
564       }
565     }
566   }
567 
568   // square matrix inplace transpose
transpose_double(matrix_double & P)569   void transpose_double(matrix_double &P){
570     int Ps=int(P.size());
571     for (int i=0;i<Ps;++i){
572       for (int j=0;j<i;++j){
573 	giac_double t=P[i][j];
574 	P[i][j]=P[j][i];
575 	P[j][i]=t;
576       }
577     }
578   }
alphaposcell(const string & s,int & r)579   int alphaposcell(const string & s,int & r){
580     int ss=int(s.size());
581     r=0;
582     int i=0;
583     for (;i<ss;++i){
584       if ( (s[i]>='A') && (s[i]<='Z') )
585 	r=r*26+(s[i]-'A')+1;
586       else {
587 	if ( (s[i]>='a') && (s[i]<='q') )
588 	  r=r*26+(s[i]-'a')+1;
589 	else
590 	  break;
591       }
592     }
593     --r;
594     return i;
595   }
596 
iscell(const gen & g,int & r,int & c,GIAC_CONTEXT)597   bool iscell(const gen & g,int & r,int & c,GIAC_CONTEXT){
598     if (g.type!=_IDNT)
599       return false;
600     const string & s=g._IDNTptr->name();
601     int ss=int(s.size());
602     if (ss<2)
603       return false;
604     int i=alphaposcell(s,r);
605     if (!i || (i==ss) )
606       return false;
607     c=0;
608     for (;i<ss;++i){
609       if ( (s[i]>='0') && (s[i]<='9') )
610 	c=c*10+(s[i]-'0');
611       else
612 	break;
613     }
614     if (array_start(contextptr))
615       --c;
616     return (i==ss);
617   }
618 
619   // find all identifiers in g, check if they are of the form
620   // Alpha_number, replace them by spread(i,j) if this is the case
spread_convert(const gen & g,int g_row,int g_col,GIAC_CONTEXT)621   gen spread_convert(const gen & g,int g_row,int g_col,GIAC_CONTEXT){
622     // relative cell
623     vecteur l(gen2vecteur(_lname(g,contextptr)));
624     const_iterateur it=l.begin(),itend=l.end();
625     vecteur sub_in,sub_out;
626     int r,c;
627     for (;it!=itend;++it){
628       if (iscell(*it,c,r,contextptr)){
629 	sub_in.push_back(*it);
630 	sub_out.push_back(symbolic(at_cell,makevecteur(makevecteur(r-g_row),makevecteur(c-g_col))));
631       }
632     }
633     // absolute cell
634     l=lop(g,at_dollar);
635     itend=l.end();
636     for (it=l.begin();it!=itend;++it){
637       gen & f=it->_SYMBptr->feuille;
638       // CERR << "absolute cell "<< f << '\n';
639       if ( (f.type!=_VECT) ){
640 	if (iscell(f,c,r,contextptr)){
641 	  sub_in.push_back(*it);
642 	  sub_out.push_back(symbolic(at_cell,makevecteur(makevecteur(r-g_row),c)));
643 	}
644 	continue;
645       }
646       vecteur & v=*f._VECTptr;
647       if (v.size()==2){
648 	gen & a=v.front();
649 	gen & b=v.back();
650 	// CERR << "absolute cell "<< a << " " << b <<'\n';
651 	if (b.type!=_INT_)
652 	  continue;
653 	if (array_start(contextptr))
654 	  r=b.val-1;
655 	else
656 	  r=b.val;
657 	if (a.type==_IDNT){
658 	  const string & chaine=a._IDNTptr->name();
659 	  int i=alphaposcell(chaine,c);
660 	  if (i==signed(chaine.size())){
661 	    sub_in.push_back(*it);
662 	    sub_out.push_back(symbolic(at_cell,makevecteur(r,makevecteur(c-g_col))));
663 	  }
664 	  continue;
665 	}
666 	if ( (a.type==_SYMB) && (a._SYMBptr->sommet==at_dollar) && (a._SYMBptr->feuille.type==_IDNT) ){
667 	  const string & chaine = a._SYMBptr->feuille._IDNTptr->name();
668 	  int i=alphaposcell(chaine,c);
669 	  if (i==signed(chaine.size())){
670 	    sub_in.push_back(*it);
671 	    sub_out.push_back(symbolic(at_cell,makevecteur(r,c)));
672 	  }
673 	}
674       }
675     }
676     if (sub_in.empty())
677       return g;
678     gen tmp(quotesubst(g,sub_in,sub_out,contextptr));
679     tmp.subtype=_SPREAD__SYMB;
680     return tmp;
681   }
682 
683 
printcell(const vecteur & v,GIAC_CONTEXT)684   string printcell(const vecteur & v,GIAC_CONTEXT){
685     // CERR << "printcell" << printcell_current_row << " " << printcell_current_col << " " << v << '\n';
686     string debut,tmp,fin;
687     int i;
688     // Note: in popular spreadsheet, the column index comes before the row
689     // Therefore we translate v.back before v.front
690     if (v.back().type==_INT_){
691       i=v.back().val;
692       debut="$";
693     }
694     else
695       i=v.back()._VECTptr->front().val+printcell_current_col(contextptr);
696     if (i<0)
697       return print_INT_(i);
698     for(int j=0;;++j){
699       tmp=char('A'+i%26-(j!=0))+tmp;
700       i=i/26;
701       if (!i)
702 	break;
703     }
704     debut=debut+tmp;
705     if (v.front().type==_INT_){
706       i=v.front().val;
707       debut=debut+"$";
708     }
709     else
710       i=v.front()._VECTptr->front().val+printcell_current_row(contextptr);
711     if (array_start(contextptr))
712       ++i;
713     if (i<0)
714       return debut+print_INT_(i);
715     for (;;){
716       fin=char('0'+i%10)+fin;
717       i=i/10;
718       if (!i)
719 	break;
720     }
721     return debut+fin;
722   }
723 
printascell(const gen & feuille,const char * sommetstr,GIAC_CONTEXT)724   string printascell(const gen & feuille,const char * sommetstr,GIAC_CONTEXT){
725     if ( (feuille.type!=_VECT) || (feuille._VECTptr->size()!=2) )
726       return sommetstr+("("+feuille.print(contextptr)+")");
727     return printcell(*feuille._VECTptr,contextptr);
728   }
_cell(const gen & args,GIAC_CONTEXT)729   gen _cell(const gen & args,GIAC_CONTEXT){
730     if ( args.type==_STRNG && args.subtype==-1) return  args;
731     if ( (args.type!=_VECT) || (args._VECTptr->size()!=2) )
732       return gensizeerr(contextptr);
733     return symbolic(at_cell,args);
734   }
735   static const char _cell_s []="cell";
736   static define_unary_function_eval2 (__cell,&_cell,_cell_s,&printascell);
737   define_unary_function_ptr5( at_cell ,alias_at_cell,&__cell,0,true);
738 
lcell(const gen & g,vecteur & res)739   static void lcell(const gen & g,vecteur & res){
740     if (g.type==_VECT){
741       if (g.subtype==_CELL__VECT){
742 	if (res.empty())
743 	  res=*g._VECTptr;
744 	else { // assumes g._VECTptr has much more elements than res
745 	  vecteur tmp=res;
746 	  res=*g._VECTptr;
747 	  const_iterateur it=tmp.begin(),itend=tmp.end();
748 	  for (;it!=itend;++it){
749 	    if (!equalposcomp(res,*it))
750 	      res.push_back(*it);
751 	  }
752 	}
753       }
754       else {
755 	const_iterateur it=g._VECTptr->begin(),itend=g._VECTptr->end();
756 	for (;it!=itend;++it)
757 	  lcell(*it,res);
758       }
759     }
760     if (g.type==_SYMB){
761       if (g._SYMBptr->sommet==at_cell || g._SYMBptr->sommet==at_deuxpoints){
762 	if (!equalposcomp(res,g))
763 	  res.push_back(g);
764       }
765       else
766 	lcell(g._SYMBptr->feuille,res);
767     }
768   }
769 
lcell(const gen & g)770   vecteur lcell(const gen & g){
771     vecteur res;
772     lcell(g,res);
773     return res;
774   }
775 
776   // given g=cell() or its argument at row i, column j
777   // return 0 if not a cell, 1 if a cell, then compute r and c s.t. g refers to (r,c),
778   // return 2 if g is e.g. A1:B4 compute ref of A1 and B4
cell2pos(const gen & g,int i,int j,int & r,int & c,int & r2,int & c2)779   int cell2pos(const gen & g,int i,int j,int & r,int & c,int & r2,int & c2){
780     if (g.is_symb_of_sommet(at_deuxpoints) && g._SYMBptr->feuille.type==_VECT ){
781       vecteur & gf=*g._SYMBptr->feuille._VECTptr;
782       if (gf.size()!=2)
783 	return 0;
784       int r1,c1;
785       if (cell2pos(gf[0],i,j,r,c,r1,c1)==1 && cell2pos(gf[1],i,j,r2,c2,r1,c1)==1)
786 	return 2;
787       return 0;
788     }
789     vecteur v;
790     if ( (g.type==_SYMB) && (g._SYMBptr->sommet==at_cell))
791       v=*g._SYMBptr->feuille._VECTptr;
792     else {
793       if ( (g.type!=_VECT) || (g._VECTptr->size()!=2) )
794 	return 0;
795       v=*g._VECTptr;
796     }
797     if (v.front().type==_INT_)
798       r=v.front().val;
799     else
800       r=i+v.front()._VECTptr->front().val;
801     if (v.back().type==_INT_)
802       c=v.back().val;
803     else
804       c=j+v.back()._VECTptr->front().val;
805     return 1;
806   }
807 
808   // return cell(r,c) argument at (i,j) with same absolute/relative addressing
809   // as g
pos2cell(const gen & g,int i,int j,int r,int c,int r2,int c2)810   gen pos2cell(const gen & g,int i,int j,int r,int c,int r2,int c2){
811     if (g.is_symb_of_sommet(at_deuxpoints) && g._SYMBptr->feuille.type==_VECT){
812       vecteur & gf=*g._SYMBptr->feuille._VECTptr;
813       if (gf.size()!=2)
814 	return gensizeerr(gettext("pos2cell"));
815       return symbolic(at_deuxpoints,makevecteur(pos2cell(gf[0],i,j,r,c,r,c),pos2cell(gf[1],i,j,r2,c2,r2,c2)));
816     }
817     vecteur v;
818     if ( (g.type==_SYMB) && (g._SYMBptr->sommet==at_cell))
819       v=*g._SYMBptr->feuille._VECTptr;
820     else {
821       if ( (g.type!=_VECT) || (g._VECTptr->size()!=2) )
822 	return gensizeerr(gettext("pos2cell"));
823       v=*g._VECTptr;
824     }
825     vecteur w(2);
826     if (v.front().type==_INT_)
827       w.front()=r;
828     else
829       w.front()=vecteur(1,r-i);
830     if (v.back().type==_INT_)
831       w.back()=c;
832     else
833       w.back()=vecteur(1,c-j);
834     return _cell(w,context0);
835   }
836 
freecopy(const gen & g)837   gen freecopy(const gen & g){
838     if (g.type!=_VECT)
839       return g;
840     else
841       return *g._VECTptr;
842   }
843 
844   // insert nrows/ncols of fill in m, e.g. fill= [0,0,2] for a spreadsheet
845   // or ["","",2] or 0 for a matrix
matrice_insert(const matrice & m,int insert_row,int insert_col,int nrows,int ncols,const gen & fill_,GIAC_CONTEXT)846   matrice matrice_insert(const matrice & m,int insert_row,int insert_col,int nrows,int ncols,const gen & fill_,GIAC_CONTEXT){
847     int r,c,cell_r,cell_c;
848     int decal_i=0,decal_j;
849     mdims(m,r,c);
850     gen fill(fill_);
851     if (is_undef(fill)){
852       if (m[0][0].type==_VECT)
853 	fill=makevecteur(string2gen("",false),string2gen("",false),2);
854       else
855 	fill=0;
856     }
857     matrice res;
858     res.reserve(r+nrows);
859     // i,j position in the old matrix; i+decal_i,i+decal_j in the new
860     for (int i=0;i<r;++i){
861       vecteur tmp;
862       tmp.reserve(c+ncols);
863       if (i==insert_row){ // insert nrows of fill
864 	for (int j=0;j<nrows;++j){
865 	  // we must recreate the line each time to have a free line
866 	  for (int k=0;k<c+ncols;++k)
867 	    tmp.push_back(freecopy(fill));
868 	  res.push_back(tmp);
869 	  tmp.clear();
870 	}
871 	decal_i=nrows;
872       }
873       decal_j=0;
874       for (int j=0;j<c;++j){
875 	if (j==insert_col){
876 	  for (int k=0;k<ncols;k++)
877 	    tmp.push_back(freecopy(fill));
878 	  decal_j=ncols;
879 	}
880 	gen g=m[i][j];
881 	// find all cells in g
882 	vecteur sub_in(lcell(g[0])),sub_out;
883 	if (sub_in.empty()){
884 	  tmp.push_back(g);
885 	  continue;
886 	}
887 	const_iterateur it=sub_in.begin(),itend=sub_in.end();
888 	for (;it!=itend;++it){
889 	  int cell_r2,cell_c2,type=cell2pos(*it,i,j,cell_r,cell_c,cell_r2,cell_c2);
890 	  if (type){
891 	    if (cell_r>=insert_row)
892 	      cell_r += nrows;
893 	    if (cell_c>=insert_col)
894 	      cell_c += ncols;
895 	    if (cell_r2>=insert_row)
896 	      cell_r2 += nrows;
897 	    if (cell_c2>=insert_col)
898 	      cell_c2 += ncols;
899 	    sub_out.push_back(pos2cell(*it,i+decal_i,j+decal_j,cell_r,cell_c,cell_r2,cell_c2));
900 	  }
901 	  else
902 	    sub_out.push_back(*it);
903 	}
904 	g=quotesubst(g,sub_in,sub_out,contextptr);
905 	if (g.type==_VECT && !g._VECTptr->empty())
906 	  g._VECTptr->front().subtype=m[i][j][0].subtype;
907 	tmp.push_back(g);
908       } // end for j
909       res.push_back(tmp);
910     } // end for i
911     return res;
912   }
913 
914   // erase nrows/ncols
matrice_erase(const matrice & m,int insert_row,int insert_col,int nrows,int ncols,GIAC_CONTEXT)915   matrice matrice_erase(const matrice & m,int insert_row,int insert_col,int nrows,int ncols,GIAC_CONTEXT){
916     int r,c,cell_r,cell_c;
917     int decal_i=0,decal_j;
918     mdims(m,r,c);
919     matrice res;
920     if ( (r<=nrows) || (c<=ncols) )
921       return res;
922     res.reserve(r-nrows);
923     for (int i=0;i<r;++i){
924       if (i==insert_row){
925 	i+=nrows;
926 	if (i>=r)
927 	  break;
928 	decal_i=nrows;
929       }
930       vecteur tmp;
931       tmp.reserve(c-ncols);
932       decal_j=0;
933       for (int j=0;j<c;++j){
934 	if (j==insert_col){
935 	  j+=ncols;
936 	  if (j>=c)
937 	    break;
938 	  decal_j=ncols;
939 	}
940 	gen g=m[i][j];
941 	// find all cells in g
942 	vecteur sub_in(lcell(g)),sub_out;
943 	if (sub_in.empty()){
944 	  tmp.push_back(g);
945 	  continue;
946 	}
947 	const_iterateur it=sub_in.begin(),itend=sub_in.end();
948 	for (;it!=itend;++it){
949 	  int cell_r2,cell_c2,type=cell2pos(*it,i,j,cell_r,cell_c,cell_r2,cell_c2);
950 	  if (type){
951 	    if (cell_r>=insert_row)
952 	      cell_r -= nrows;
953 	    if (cell_c>=insert_col)
954 	      cell_c -= ncols;
955 	    if (cell_r2>=insert_row)
956 	      cell_r2 -= nrows;
957 	    if (cell_c2>=insert_col)
958 	      cell_c2 -= ncols;
959 	    sub_out.push_back(pos2cell(*it,i-decal_i,j-decal_j,cell_r,cell_c,cell_r2,cell_c2));
960 	  }
961 	  else
962 	    sub_out.push_back(*it);
963 	}
964 	tmp.push_back(quotesubst(g,sub_in,sub_out,contextptr));
965       } // end for j
966       res.push_back(tmp);
967     } // end for i
968     return res;
969   }
970 
971   // extract submatrix
matrice_extract(const matrice & m,int insert_row,int insert_col,int nrows,int ncols)972   matrice matrice_extract(const matrice & m,int insert_row,int insert_col,int nrows,int ncols){
973     if ( (!nrows) || (!ncols))
974       return vecteur(1,vecteur(1,gensizeerr(gettext("matrice_extract"))));
975     int mr,mc;
976     mdims(m,mr,mc);
977     if (mr>insert_row+nrows)
978       mr=insert_row+nrows;
979     if (mc>insert_col+ncols)
980       mc=insert_col+ncols;
981     matrice res;
982     res.reserve(nrows);
983     for (int i=insert_row;i<mr;++i){
984       const_iterateur it=m[i]._VECTptr->begin();
985       res.push_back(vecteur(it+insert_col,it+mc));
986     }
987     return res;
988   }
989 
990   // convert m to a spreadsheet matrix if necessary
991   // each cell must be a vector of length 3: v[0] is the formula
992   // v[1] is the value and v[2] is 0 (not evaluated), 1 (in eval), 2 (evaled)
makespreadsheetmatrice(matrice & m,GIAC_CONTEXT)993   void makespreadsheetmatrice(matrice & m,GIAC_CONTEXT){
994     int nr=int(m.size());
995     if (!nr)
996       return ;
997     int nc=int(m.front()._VECTptr->size());
998     // prepare each cell
999     for (int i=0;i<nr;++i){
1000       gen & g=m[i];
1001       if (g.type!=_VECT)
1002 	g=vecteur(nc,g);
1003       vecteur & v=*g._VECTptr;
1004       for (int j=0;j<nc;++j){
1005 	vecteur w;
1006 	if ((v[j].type==_VECT) && (v[j].subtype==0))
1007 	  w=*v[j]._VECTptr;
1008 	else
1009 	  w=vecteur(2,v[j]);
1010 	int s=int(w.size());
1011 	if (s>3)
1012 	  w=vecteur(w.begin(),w.begin()+3);
1013 	if (s<1)
1014 	  w.push_back(zero);
1015 	if (s<3)
1016 	  w.push_back(zero);
1017 	if (s<2)
1018 	  w.push_back(w.front());
1019 	/* if (w[2].type!=_INT_)
1020 	   w[2]=0; */
1021 	w[0]=spread_convert(w[0],i,j,contextptr);
1022 	v[j]=w;
1023       }
1024     }
1025     return ;
1026   }
1027 
extractmatricefromsheet(const matrice & m,bool value)1028   matrice extractmatricefromsheet(const matrice & m,bool value){
1029     int I=int(m.size());
1030     if (!I)
1031       return m;
1032     int J=int(m.front()._VECTptr->size());
1033     matrice res(I);
1034     for (int i=0;i<I;++i){
1035       vecteur & v=*m[i]._VECTptr;
1036       vecteur tmp(J);
1037       for (int j=0;j<J;++j){
1038 	if ( (v[j].type==_VECT) && (v[j]._VECTptr->size()==3) )
1039 	  tmp[j]=(*v[j]._VECTptr)[value?1:0];
1040 	else
1041 	  tmp[j]=v[j];
1042       }
1043       res[i]=tmp;
1044     }
1045     return res;
1046   }
1047 
evaldeuxpoints(const gen & args,const matrice * mptr,int cr,int cc,int & x,int & y,int & X,int & Y,GIAC_CONTEXT)1048   static gen evaldeuxpoints(const gen & args,const matrice *mptr,int cr,int cc,int & x,int & y,int & X,int & Y,GIAC_CONTEXT){
1049     if (args.is_symb_of_sommet(at_deuxpoints))
1050       return evaldeuxpoints(args._SYMBptr->feuille,mptr,cr,cc,x,y,X,Y,contextptr);
1051     if (args.type==_VECT && args._VECTptr->size()==2){
1052       vecteur & w=*args._VECTptr;
1053       if (!mptr){
1054 	if (w[0].is_symb_of_sommet(at_cell) && w[1].is_symb_of_sommet(at_cell)){
1055 	  if (w[0]._SYMBptr->feuille.type!=_VECT || w[0]._SYMBptr->feuille._VECTptr->size()!=2 || w[1]._SYMBptr->feuille.type!=_VECT || w[1]._SYMBptr->feuille._VECTptr->size()!=2 )
1056 	    return gensizeerr(gettext("Bad cell"));
1057 	  vecteur & w0=*w[0]._SYMBptr->feuille._VECTptr;
1058 	  vecteur & w1=*w[1]._SYMBptr->feuille._VECTptr;
1059 	  // Take absolute types for the returned list
1060 	  int xm,xM,ym,yM;
1061 	  if (w0[0].type==_VECT)
1062 	    xm=w0[0]._VECTptr->front().val+cr;
1063 	  else
1064 	    xm=w0[0].val;
1065 	  if (w0[1].type==_VECT)
1066 	    ym=w0[1]._VECTptr->front().val+cc;
1067 	  else
1068 	    ym=w0[1].val;
1069 	  // BUG
1070 	  if (w1[0].type==_VECT)
1071 	    xM=w1[0]._VECTptr->front().val+cr;
1072 	  else
1073 	    xM=w1[0].val;
1074 	  if (w1[1].type==_VECT)
1075 	    yM=w1[1]._VECTptr->front().val+cc;
1076 	  else
1077 	    yM=w1[1].val;
1078 	  x=giacmin(xm,xM); X=giacmax(xm,xM); y=giacmin(ym,yM); Y=giacmax(ym,yM);
1079 	  return 1;
1080 	}
1081 	return 0;
1082       } // end if (!mptr)
1083       int nrows=int(mptr->size());
1084       if (X>=nrows)
1085 	X=nrows-1;
1086       int ncols=nrows?int(mptr->front()._VECTptr->size()):0;
1087       if (Y>=ncols)
1088 	Y=ncols-1;
1089       ref_vecteur * resptr=new_ref_vecteur(0);
1090       resptr->v.reserve((X-x+1)*(Y-y+1));
1091       ref_vecteur * vptr=0;
1092       for (int x0=x;x0<=X;++x0){
1093 #ifdef SMARTPTR64
1094 	vptr=((ref_vecteur*)(* (ulonglong *) &(*mptr)[x0] >> 16));
1095 #else
1096 	vptr=(*mptr)[x0].__VECTptr;
1097 #endif
1098 	for (int y0=y;y0<=Y;++y0){
1099 	  const gen & tmp=(vptr->v)[y0][1];
1100 	  if (tmp.type!=_STRNG || !tmp._STRNGptr->empty())
1101 	    resptr->v.push_back(tmp);
1102 	}
1103       }
1104       return resptr;
1105     }
1106     return mptr?symbolic(at_deuxpoints,args):zero;
1107   }
1108 
1109   // find all spread(i,j) that are in m[m_row][m_col], eval them recursively
spread_eval(matrice & m,int m_row,int m_col,GIAC_CONTEXT)1110   static gen spread_eval(matrice & m,int m_row,int m_col,GIAC_CONTEXT){
1111     control_c();
1112     if (interrupted){
1113       *logptr(contextptr) << gettext("Interrupted ") << m_row << " " << m_col << '\n';
1114       return undef;
1115     }
1116     const gen & g=m[m_row][m_col][0];
1117     if (g.type!=_SYMB && g.type!=_VECT)
1118       return protecteval(g,eval_level(contextptr),contextptr);
1119     int & mr =spread_Row(contextptr);
1120     mr=m_row;
1121     int & mc=spread_Col(contextptr);
1122     mc=m_col;
1123     // printcell_current_row(contextptr)=m_row; printcell_current_col(contextptr)=m_col;
1124     vecteur v;
1125     lcell(g,v);
1126     if (v.empty()){
1127       gen temp=g;
1128       if (temp.type==_SYMB && temp.subtype==_SPREAD__SYMB)
1129 	temp.subtype=0;
1130       return protecteval(temp,eval_level(contextptr),contextptr);
1131     }
1132     vecteur sub_in,sub_out;
1133     const_iterateur it=v.begin(),itend=v.end();
1134     int i,j,ms=int(m.size()),ws,x,y,X,Y;
1135     for (;it!=itend;++it){
1136       if (it->_SYMBptr->sommet==at_deuxpoints){
1137 	if (is_one(evaldeuxpoints(*it,0,m_row,m_col,x,y,X,Y,contextptr))){
1138 	  for (i=x;i<ms && i<=X;++i){
1139 	    vecteur & w=*m[i]._VECTptr;
1140 	    ws=int(w.size());
1141 	    for (j=y;j<ws && j<=Y;++j){
1142 	      vecteur & wj=*w[j]._VECTptr;
1143 	      if (wj.back().val==1)
1144 		return string2gen("Recursive eval",false);
1145 	      if (wj.back().val==0){
1146 		wj.back().val=1;
1147 		wj[1]=spread_eval(m,i,j,contextptr);
1148 		if (interrupted)
1149 		  return undef;
1150 		wj.back().val=2;
1151 	      }
1152 	    }
1153 	  }
1154 	  sub_in.push_back(*it);
1155 	  sub_out.push_back(evaldeuxpoints(*it,&m,m_row,m_col,x,y,X,Y,contextptr));
1156 	}
1157       } // end at_deuxpoints
1158       else {
1159 	gen & gi=it->_SYMBptr->feuille._VECTptr->front();
1160 	gen & gj=it->_SYMBptr->feuille._VECTptr->back();
1161 	if (gi.type==_INT_)
1162 	  i=gi.val;
1163 	else
1164 	  i=m_row+gi._VECTptr->front().val;
1165 	if (gj.type==_INT_)
1166 	  j=gj.val;
1167 	else
1168 	  j=m_col+gj._VECTptr->front().val;
1169 	if ( i>=0 && i<ms ){
1170 	  vecteur & w=*m[i]._VECTptr;
1171 	  if ( j>=0 && j<signed(w.size()) ){
1172 	    vecteur & wj=*w[j]._VECTptr;
1173 	    if (wj.back().val==1)
1174 	      return string2gen("Recursive eval",false);
1175 	    if (wj.back().val==0){
1176 	      wj.back().val=1;
1177 	      wj[1]=spread_eval(m,i,j,contextptr);
1178 	      if (interrupted)
1179 		return undef;
1180 	      wj.back().val=2;
1181 	    }
1182 	    sub_in.push_back(*it);
1183 	    sub_out.push_back(wj[1]);
1184 	  }
1185 	}
1186       } // end at_cell
1187     }
1188     // replace evaled cell in g
1189     // if (sub_in.size()>=1000)
1190     //  CERR << '\n';
1191     gen temp(quotesubst(g,sub_in,sub_out,contextptr));
1192     if (temp.type==_SYMB && temp.subtype==_SPREAD__SYMB)
1193       temp.subtype=0;
1194     // Avoid answers that are too complex
1195     if (temp.type==_SYMB && taille(temp,4000)>4000){
1196       CERR << gettext("Spreadsheet matrix argument max size 4000 exceeded") <<'\n';
1197       temp=undeferr(gettext("Spreadsheet matrix argument max size 4000 exceeded"));
1198     }
1199     mr=m_row;
1200     mc=m_col;
1201     const gen & res=protecteval(temp,eval_level(contextptr),contextptr);
1202     return res;
1203   }
1204 
1205   // evaluate a matrix representing a spreadsheet
1206   // m must be a spreadsheet matrix (see above)
1207   // lc will contain the list of cell dependances of m
spread_eval(matrice & m,GIAC_CONTEXT)1208   void spread_eval(matrice & m,GIAC_CONTEXT){
1209     interrupted=false;
1210     int nr=int(m.size());
1211     if (!nr)
1212       return;
1213     int nc=int(m.front()._VECTptr->size());
1214     // prepare for evaluation, compute list of cell and set eval flag to 0
1215     for (int i=0;i<nr;++i){
1216       vecteur & v=*m[i]._VECTptr;
1217       for (int j=0;j<nc;++j){
1218 	vecteur & w=*v[j]._VECTptr;
1219 	if (w.front().type<=_POLY){
1220 	  w[1]=w[0];
1221 	  w[2].val=2;
1222 	}
1223 	else {
1224 	  w[2].val=0;
1225 	}
1226       }
1227     }
1228     // eval
1229     for (int i=0;!interrupted && i<nr;++i){
1230       vecteur & v=*m[i]._VECTptr;
1231       for (int j=0;!interrupted && j<nc;++j){
1232 	vecteur & w=*v[j]._VECTptr;
1233 	if (w[2].val==2)
1234 	  continue;
1235 	w[2].val=1;
1236 #ifndef NO_STDEXCEPT
1237 	try {
1238 #endif
1239 	  w[1]=spread_eval(m,i,j,contextptr);
1240 #ifndef NO_STDEXCEPT
1241 	}
1242 	catch (std::runtime_error & e){
1243 	  last_evaled_argptr(contextptr)=NULL;
1244 	  w[1]=string2gen(e.what(),false);
1245 	}
1246 #endif
1247 	w[2].val=2;
1248       }
1249     }
1250     spread_Row(-1,contextptr);
1251     spread_Col(-1,contextptr);
1252     if (interrupted)
1253       *logptr(contextptr) << gettext("Spreadsheet evaluation interrupted") << '\n';
1254   }
1255 
mergevecteur(const vecteur & a,const vecteur & b)1256   vecteur mergevecteur(const vecteur & a,const vecteur & b){
1257     if (is_undef(a)) return a;
1258     if (is_undef(b)) return b;
1259     int as=int(a.size());
1260     int bs=int(b.size());
1261     vecteur v;
1262     v.reserve(as+bs);
1263     vecteur::const_iterator it=a.begin(),itend=a.end();
1264     for (;it!=itend;++it)
1265       v.push_back(*it);
1266     it=b.begin();itend=b.end();
1267     for (;it!=itend;++it)
1268       v.push_back(*it);
1269     return v;
1270   }
1271 
mergeset(const vecteur & a,const vecteur & b)1272   vecteur mergeset(const vecteur & a,const vecteur & b){
1273     if (is_undef(a)) return a;
1274     if (is_undef(b)) return b;
1275     if (a.empty())
1276       return b;
1277     vecteur v(a);
1278     vecteur::const_iterator it=b.begin(),itend=b.end();
1279     if ( (itend-it)>std::log(double(a.size()))){
1280       v.reserve(a.size()+(itend-it));
1281       for (;it!=itend;++it)
1282 	v.push_back(*it);
1283       islesscomplexthanf_sort(v.begin(),v.end());
1284       vecteur res(1,v.front());
1285       res.reserve(v.size());
1286       it=v.begin()+1,itend=v.end();
1287       for (;it!=itend;++it){
1288 	if (*it!=res.back())
1289 	  res.push_back(*it);
1290       }
1291       return res;
1292     }
1293     for (;it!=itend;++it){
1294       if (!equalposcomp(v,*it))
1295 	v.push_back(*it);
1296     }
1297     return v;
1298   }
1299 
makesuite(const gen & a)1300   gen makesuite(const gen & a){
1301     if ( (a.type==_VECT) && (a.subtype==_SEQ__VECT) )
1302       return a;
1303     else
1304       return gen(vecteur(1,a),_SEQ__VECT);
1305   }
1306 
makesuite_inplace(const gen & a,const gen & b)1307   gen makesuite_inplace(const gen & a,const gen & b){
1308     if (a.type!=_VECT || a.subtype!=_VECT || (b.type==_VECT && b.subtype==_SEQ__VECT))
1309       return makesuite(a,b);
1310     a._VECTptr->push_back(b);
1311     return a;
1312   }
1313 
makesuite(const gen & a,const gen & b)1314   gen makesuite(const gen & a,const gen & b){
1315     if ( (a.type==_VECT) && (a.subtype==_SEQ__VECT) ){
1316       if ( (b.type==_VECT) && (b.subtype==_SEQ__VECT) )
1317 	return gen(mergevecteur(*a._VECTptr,*b._VECTptr),_SEQ__VECT);
1318       else {
1319 	vecteur va=*a._VECTptr;
1320 	va.push_back(b);
1321 	return gen(va,_SEQ__VECT);
1322       }
1323     }
1324     else {
1325       if ( (b.type==_VECT) && (b.subtype==_SEQ__VECT) ){
1326 	vecteur vb=*b._VECTptr;
1327 	vb.insert(vb.begin(),a);
1328 	return gen(vb,_SEQ__VECT);
1329       }
1330       else
1331 	return gen(makevecteur(a,b),_SEQ__VECT);
1332     }
1333   }
1334 
1335   // gluing is done line1 of a with line1 of b and so on
1336   // look at mergevecteur too
mergematrice(const matrice & a,const matrice & b)1337   matrice mergematrice(const matrice & a,const matrice & b){
1338     if (a.empty())
1339       return b;
1340     if (b.empty())
1341       return a;
1342     const_iterateur ita=a.begin(),itaend=a.end();
1343     const_iterateur itb=b.begin(),itbend=b.end();
1344     matrice res;
1345     res.reserve(itaend-ita);
1346     if (itaend-ita!=itbend-itb){
1347       if (debug_infolevel<1)
1348 	return vecteur(1,vecteur(1,gendimerr(gettext("mergematrice"))));
1349       if (debug_infolevel<1){
1350 	res.dbgprint();
1351 	std_matrix<gen> M;
1352 	matrice2std_matrix_gen(res,M);
1353 	M.dbgprint();
1354       }
1355       return vecteur(1,vecteur(1,gendimerr(gettext("mergematrice"))));
1356     }
1357     for (;ita!=itaend;++ita,++itb){
1358       if (ita->type!=_VECT || itb->type!=_VECT)
1359 	return vecteur(1,vecteur(1,gensizeerr(gettext("mergematrice"))));
1360       res.push_back(mergevecteur(*ita->_VECTptr,*itb->_VECTptr));
1361     }
1362     return res;
1363   }
1364 
horner(const vector<complex_double> & v,const complex_double & c)1365   static complex_double horner(const vector< complex_double > & v, const complex_double & c){
1366     vector< complex_double > :: const_iterator it=v.begin(),itend=v.end();
1367     complex_double res(0);
1368     for (;it!=itend;++it){
1369       res *= c;
1370       res += *it;
1371     }
1372     // COUT << v << "(" << c << ")" << "=" << res << '\n';
1373     return res;
1374   }
1375 
1376   // find a root of a polynomial with float coeffs
a_root(const vecteur & v,const complex_double & c0,double eps)1377   gen a_root(const vecteur & v,const complex_double & c0,double eps){
1378     if (v.empty())
1379       return gentypeerr(gettext("a_root"));
1380     vector< complex_double > v_d,dv_d;
1381     const_iterateur it=v.begin(),itend=v.end();
1382     int deg=int(itend-it)-1;
1383     if (deg==0)
1384       return gensizeerr(gettext("a_root"));
1385     if (deg==1)
1386       return -rdiv(v.back(),v.front(),context0);
1387     if (deg==2){ // use 2nd order equation formula
1388       return (-v[1]+sqrt(v[1]*v[1]-4*v[0]*v[2],context0))/(2*v[0]); // ok
1389     }
1390     v_d.reserve(deg+1);
1391     dv_d.reserve(deg);
1392     for (int d=deg;it!=itend;++it,--d){
1393       gen temp=it->evalf_double(1,context0); // ok
1394       if (temp.type==_DOUBLE_)
1395 	v_d.push_back(temp._DOUBLE_val);
1396       else {
1397 	if (temp.type!=_CPLX)
1398 	  return undef;
1399 	v_d.push_back(complex_double(temp._CPLXptr->_DOUBLE_val,(temp._CPLXptr+1)->_DOUBLE_val));
1400       }
1401     }
1402     // Preconditionning, x->x*lambda
1403     // a_n x^n + .. + a_0 = a_n*lambda^n x^n + a_[n-1]*lambda^(n-1)*x^(n-1) +
1404     // = a_n*lambda^n * ( x^n + a_[n-1]/a_n/lambda * x^(n-1) +
1405     //                    +  a_[n-2]/a_n/lambda^2 * x^(n-1) + ...)
1406     // take the largest ratio (a_[n-d]/a_n)^(1/d) for lambda
1407     double ratio=0.0,tmpratio;
1408     for (int d=1;d<=deg;++d){
1409       tmpratio=std::pow(complex_abs(v_d[d]/v_d[0]),1.0/d);
1410       if (tmpratio>ratio)
1411 	ratio=tmpratio;
1412     }
1413     double logratio=std::log(ratio);
1414     if (debug_infolevel)
1415       CERR << "balance ratio " << ratio << '\n';
1416     bool real0=v_d[0].imag()==0;
1417     // Recompute coefficients
1418     for (int d=1;d<=deg;++d){
1419       bool real=real0 && v_d[d].imag()==0;
1420       v_d[d]=std::exp(std::log(v_d[d]/v_d[0])-d*logratio);
1421       if (real)
1422 	v_d[d]=v_d[d].real();
1423     }
1424     v_d[0]=1;
1425     for (int d=0;d<deg;++d)
1426       dv_d.push_back(v_d[d]*(double)(deg-d)) ;
1427 #ifndef __APPLE__
1428     if (debug_infolevel>2)
1429       COUT << "Aroot init " << c0 << " after renormalization: " << v_d << '\n' << "Diff " << dv_d << '\n';
1430 #endif
1431     // newton method with prefactor
1432     complex_double c(c0),newc,fc,newfc,fprimec,rapport;
1433     double prefact=1.0;
1434     int maxloop=SOLVER_MAX_ITERATE;
1435     for (double j=1;j<1024;j=2*j,maxloop=(maxloop*3)/2){ // max 10 loop
1436       double prefactmult=0.5;
1437       fc=horner(v_d,c);
1438       for (int i=maxloop; i;--i){
1439 	fprimec=horner(dv_d,c);
1440 	if (fprimec==complex_double(0,0))
1441 	  break;
1442 	rapport=fc/fprimec;
1443 	if (complex_abs(rapport)>1/eps) // denominator not invertible -> start elsewhere
1444 	  break;
1445 	newc=c-prefact*rapport;
1446 	if (newc==c){
1447 	  if (complex_abs(fc)<eps)
1448 	    return gen(real(newc)*ratio,imag(newc)*ratio);
1449 	  break;
1450 	}
1451 	newfc=horner(v_d,newc);
1452 #ifndef __APPLE__
1453 	if (debug_infolevel>2)
1454 	  CERR << "proot (j=" << j << "i=" << i << "), z'=" << newc << " f(z')=" << newfc << " f(z)=" << fc << " " << prefact << '\n';
1455 #endif
1456 	if (complex_abs(rapport)<eps)
1457 	  return gen(real(newc)*ratio,imag(newc)*ratio);
1458 	if (complex_abs(newfc)>complex_abs(fc)){
1459 	  prefact=prefact*prefactmult;
1460 	  // prefactmult = std::max(0.1,prefactmult*prefactmult);
1461 	}
1462 	else {
1463 	  prefactmult=0.5;
1464 	  c=newc;
1465 	  fc=newfc;
1466 	  if (prefact>0.9)
1467 	    prefact=1;
1468 	  else
1469 	    prefact=prefact*1.1;
1470 	}
1471       }
1472       // c=complex_double(rand()*j/RAND_MAX,rand()*j/RAND_MAX);
1473       c=complex_double(std_rand()*1.0/RAND_MAX,std_rand()*1.0/RAND_MAX);
1474     }
1475     CERR << "proot error "+gen(v).print() << '\n';
1476     return c;
1477   }
1478 
companion(const vecteur & w)1479   matrice companion(const vecteur & w){
1480     vecteur v(w);
1481     if (!is_one(v.front()))
1482       v=divvecteur(v,v.front());
1483     int s=int(v.size())-1;
1484     if (s<=0)
1485       return vecteur(1,gendimerr());
1486     matrice m;
1487     m.reserve(s);
1488     for (int i=0;i<s;++i){
1489       vecteur w(s);
1490       w[s-1]=-v[s-i];
1491       if (i>0)
1492 	w[i-1]=plus_one;
1493       m.push_back(w);
1494     }
1495     return m;
1496   }
1497 
eigenval2(std_matrix<gen> & H,int n2,gen & l1,gen & l2,GIAC_CONTEXT)1498   bool eigenval2(std_matrix<gen> & H,int n2,gen & l1, gen & l2,GIAC_CONTEXT){
1499     gen a=H[n2-2][n2-2],b=H[n2-2][n2-1],c=H[n2-1][n2-2],d=H[n2-1][n2-1];
1500     gen delta=a*a-2*a*d+d*d+4*b*c;
1501     bool save=complex_mode(contextptr);
1502     complex_mode(true,contextptr);
1503     delta=sqrt(delta,contextptr);
1504     complex_mode(save,contextptr);
1505     l1=(a+d+delta)/2;
1506     l2=(a+d-delta)/2;
1507     return is_zero(im(l1,contextptr)) && is_zero(im(l2,contextptr));
1508   }
1509 
minmax(const vector<double> & lnval,const vector<int> & lndeg,double shift,double & maxval,int & maxdeg,double & minval,int & mindeg)1510   static void minmax(const vector<double> & lnval,const vector<int> &lndeg,double shift,double & maxval,int & maxdeg,double & minval,int & mindeg){
1511     maxdeg=0; maxval=0; mindeg=0; minval=0;
1512     for (unsigned i=0;i<lnval.size();++i){
1513       double val=lnval[i]-shift*lndeg[i];
1514       if (val>maxval){
1515 	maxdeg=lndeg[i];
1516 	maxval=val;
1517       }
1518       if (val<minval){
1519 	mindeg=lndeg[i];
1520 	minval=val;
1521       }
1522     }
1523   }
1524 
balance(vecteur & v,double & eps,GIAC_CONTEXT)1525   static gen balance(vecteur &v,double & eps,GIAC_CONTEXT){
1526     // Preconditionning, x->x*lambda
1527     // a_n x^n + .. + a_0 = a_n*lambda^n x^n + a_[n-1]*lambda^(n-1)*x^(n-1) +
1528     // = a_n*lambda^n * ( x^n + a_[n-1]/a_n/lambda * x^(n-1) +
1529     //                    +  a_[n-2]/a_n/lambda^2 * x^(n-1) + ...)
1530     double lneps=std::log(eps);
1531     int nbits=int(-3.3*lneps);
1532     gen ratio=0,tmpratio;
1533     int deg=int(v.size())-1;
1534     gen v0=abs(v[0],contextptr),lnv0=ln(v0,contextptr),lnv0d=evalf_double(accurate_evalf(ln(v0,contextptr),60),1,contextptr);
1535     if (lnv0d.type!=_DOUBLE_)
1536       return 1;
1537     vector<double> lnval; vector<int> lndeg;
1538     for (int d=1;d<=deg;++d){
1539       gen vd=abs(v[d],contextptr);
1540       if (!is_zero(vd)){
1541 	ratio=evalf_double(accurate_evalf(ln(abs(vd,contextptr),contextptr),60)-lnv0,1,contextptr);
1542 	if (ratio.type!=_DOUBLE_)
1543 	  return 1;
1544 	if (is_greater(ratio,d*lneps,contextptr)){
1545 	  lnval.push_back(ratio._DOUBLE_val);
1546 	  lndeg.push_back(d);
1547 	}
1548 	else
1549 	  v[d]=0;
1550       }
1551     }
1552     // search largest/smallest value in lnval
1553     int maxdeg=0,mindeg=0;
1554     double maxval=0,minval=0;
1555     minmax(lnval,lndeg,0,maxval,maxdeg,minval,mindeg);
1556     // maxval-maxdeg*logratio=minval-mindeg*logratio
1557     if (mindeg==maxdeg || maxval==minval)
1558       return 1;
1559     double a=0,b=(maxval-minval)/(maxdeg-mindeg),c=0,best=0;
1560     // seach the best value between a and b
1561     double fa=maxval-minval,fbest=fa;
1562     int N=100;
1563     double step=(b-a)/N;
1564     for (int i=1;i<N;++i){
1565       c += step;
1566       minmax(lnval,lndeg,c,maxval,maxdeg,minval,mindeg);
1567       double fc=maxval-minval;
1568       if (fc>=fbest)
1569 	break;
1570       fbest=fc;
1571       best=c;
1572     }
1573     gen bestg=accurate_evalf(gen(best),90);
1574     // adjust precision (number of bits)
1575     gen maxv;
1576     for (unsigned i=0;i<v.size();++i){
1577       gen tmp=abs(exp(-int(i)*bestg-lnv0,contextptr)*v[i],contextptr);
1578       if (is_greater(tmp,maxv,contextptr))
1579 	maxv=tmp;
1580     }
1581     double eps1=1/(evalf_double(maxv,1,contextptr)._DOUBLE_val);
1582     if (debug_infolevel)
1583       CERR << "proot coefficients ratio " << eps1 << '\n';
1584     if (eps1<eps){
1585       eps=eps1;
1586       nbits=int(-3.2*std::log(eps));
1587     }
1588     if (eps<1e-14)
1589       bestg=accurate_evalf(bestg,nbits);
1590     else
1591       bestg=accurate_evalf(bestg,90);
1592     // Recompute coefficients
1593     for (int d=0;d<=deg;++d){
1594       v[d]=exp(-d*bestg-lnv0,contextptr)*v[d];
1595     }
1596     return exp(bestg,contextptr);
1597   }
1598 
linfnorm(const vector<giac_double> & v)1599   giac_double linfnorm(const vector<giac_double> & v){
1600     giac_double res=0;
1601     vector<giac_double>::const_iterator it=v.begin(),itend=v.end();
1602     for (;it!=itend;++it){
1603       giac_double tmp=absdouble(*it);
1604       if (tmp>res) res=tmp;
1605     }
1606     return res;
1607   }
1608 
linfnorm(const matrix_double & v)1609   giac_double linfnorm(const matrix_double & v){
1610     giac_double res=0;
1611     matrix_double::const_iterator it=v.begin(),itend=v.end();
1612     for (;it!=itend;++it){
1613       giac_double tmp=linfnorm(*it);
1614       if (tmp>res) res=tmp;
1615     }
1616     return res;
1617   }
1618 
1619   // linfnorm for diag(d)*M*diag(d)^-1
linfnorm(const matrix_double & M,const vector<giac_double> & d)1620   giac_double linfnorm(const matrix_double & M,const vector<giac_double> & d){
1621     giac_double res=0;
1622     matrix_double::const_iterator it=M.begin(),itend=M.end();
1623     int i,j;
1624     for (i=0;it!=itend;++i,++it){
1625       vector<giac_double>::const_iterator jt=it->begin(),jtend=it->end();
1626       for (j=0;jt!=jtend;++j,++jt){
1627 	int tmp=int(d[i]*(*jt)/d[j]);
1628 	if (tmp<0) tmp=-tmp;
1629 	if (tmp>res)
1630 	  res=tmp;
1631       }
1632     }
1633     return res;
1634   }
1635 
diagonal_mult(const vector<giac_double> & d,bool invert,const vector<giac_double> & source,vector<giac_double> & target)1636   bool diagonal_mult(const vector<giac_double> & d,bool invert,const vector<giac_double> & source,vector<giac_double> & target){
1637     int n=int(d.size());
1638     if (source.size()!=n) return false;
1639     target.resize(n);
1640     if (invert){
1641       for (int i=0;i<n;++i)
1642 	target[i]=source[i]/d[i];
1643     }
1644     else {
1645       for (int i=0;i<n;++i)
1646 	target[i]=d[i]*source[i];
1647     }
1648     return true;
1649   }
1650 
rand_1(vector<giac_double> & z)1651   void rand_1(vector<giac_double> & z){
1652     int n=int(z.size());
1653     for (int i=0;i<n;i++){
1654       z[i]=(std_rand()<=RAND_MAX/2)?1:-1;
1655     }
1656   }
1657 
1658   // Balancing sparse matrices for computing eigenvalues, Tzu-Yi Chen, James W. Demme, Linear Algebra and its Application, 309 (2000) 261–287
balance_krylov(const matrix_double & H,vector<giac_double> & d,int niter,double cutoff)1659   bool balance_krylov(const matrix_double & H,vector<giac_double> & d,int niter,double cutoff){
1660     int n=int(H.size());
1661     if (!n || n!=H.front().size())
1662       return false;
1663     d=vector<giac_double>(n,1);
1664     vector<giac_double> z(n,1),z1(n),z2(n),p(n),r(n);
1665     rand_1(z);
1666     multmatvecteur(H,z,z1);
1667     giac_double Hinf=linfnorm(z1);
1668     matrix_double Htran;
1669     transpose_double(H,0,n,0,n,Htran);
1670     for (int j=0;j<niter;++j){
1671       // z=random vector of +/-1
1672       rand_1(z);
1673       // p:=D*H*D^-1*z
1674       diagonal_mult(d,true,z,z1);
1675       multmatvecteur(H,z1,z2);
1676       diagonal_mult(d,false,z2,p);
1677       // r:=tran(D*H*D^-1)*z=D^-1*tran(H)*D*z
1678       diagonal_mult(d,false,z,z1);
1679       multmatvecteur(Htran,z1,z2);
1680       diagonal_mult(d,true,z2,r);
1681       for (int i=0;i<n;++i){
1682 	if (absdouble(p[i])>cutoff*Hinf && r[i]!=0)
1683 	  d[i]=d[i]*std::sqrt(absdouble(r[i]/p[i]));
1684       }
1685     }
1686     return true;
1687   }
1688 
schur_eigenvalues(matrix_double & H1,vecteur & res,double eps,GIAC_CONTEXT)1689   static bool schur_eigenvalues(matrix_double & H1,vecteur & res,double eps,GIAC_CONTEXT){
1690     int dim=int(H1.size());
1691     if (debug_infolevel>2){
1692       if (dim)
1693 	*logptr(contextptr) << "0: " << H1[0][0] << H1[0][1] << '\n';
1694       if (dim>1)
1695 	*logptr(contextptr) << "1: " << H1[1][0] << H1[1][1] << '\n';
1696       for (int i=2;i<dim;++i){
1697 	*logptr(contextptr) << i << ": " << string(i-2,'*') << H1[i][i-2] << "," << H1[i][i-1] << "=" << H1[i][i] << "=";
1698 	if (i<dim-1)
1699 	  *logptr(contextptr) << H1[i][i+1] ;
1700 	*logptr(contextptr) << '\n';
1701       }
1702     }
1703     bool ans=true;
1704     // read eigenvalues on diagonal of H, using subdiagonal for complex pairs
1705     for (int i=0;i<dim;++i){
1706       if (i<dim-1 && std::sqrt(eps)>absdouble(H1[i+1][i])){
1707 	if (dim*eps<absdouble(H1[i+1][i]) && (i==0 || dim*eps<absdouble(H1[i][i-1]))){
1708 #ifndef GIAC_HAS_STO_38
1709 	  *logptr(contextptr) << gettext("schur row ") << i+1 << " " << H1[i+1][i] << '\n';
1710 #endif
1711 	  ans=false;
1712 	}
1713 	// subdiagonal element is 0 -> diagonal element is an eigenvalue
1714 	res.push_back(double(H1[i][i]));
1715 	continue;
1716       }
1717       if (i==dim-1 && std::sqrt(eps)>absdouble(H1[i][i-1])){
1718 	if (dim*eps<absdouble(H1[i][i-1])){
1719 #ifndef GIAC_HAS_STO_38
1720 	  *logptr(contextptr) << gettext("schur row ") << i << " " << H1[i][i-1] << '\n';
1721 #endif
1722 	  // ans=false; //
1723 	}
1724 	// subdiagonal element is 0 -> diagonal element is an eigenvalue
1725 	res.push_back(double(H1[i][i]));
1726 	if (debug_infolevel>2)
1727 	  CERR << "Francis algorithm Success " << res << '\n';
1728 	return ans;
1729       }
1730       // non-0, next one must be 0
1731       double test=0;
1732       if (i<dim-2)
1733 	test=absdouble(H1[i+2][i+1])/(absdouble(H1[i+1][i+1])+absdouble(H1[i][i])+absdouble(H1[i+1][i])+absdouble(H1[i][i+1]));
1734       if (i<dim-2 && dim*eps<test){
1735 #ifndef GIAC_HAS_STO_38
1736 	*logptr(contextptr) << gettext("schur row ") << i+2 << " " << H1[i+2][i+1] << '\n';
1737 #endif
1738 	ans=false;
1739 	if (std::sqrt(eps)<test)
1740 	  continue;
1741       }
1742       if (i==dim-1){
1743 	res.push_back(double(H1[i][i]));
1744 	return true;
1745       }
1746       giac_double l1,l2;
1747       if (eigenval2(H1,i+2,l1,l2)){
1748 	res.push_back(double(l1));
1749 	res.push_back(double(l2));
1750 	// CERR << "2 real " << res << '\n';
1751       }
1752       else {
1753 	res.push_back(gen(double(l1),-double(l2)));
1754 	res.push_back(gen(double(l1),double(l2)));
1755 	// CERR << "2 cplx " << res << '\n';
1756       }
1757       ++i;
1758     }
1759     return ans;
1760   }
1761 
matrice2std_matrix_complex_double(const matrice & m,matrix_complex_double & M,bool nomulti=false)1762   bool matrice2std_matrix_complex_double(const matrice & m,matrix_complex_double & M,bool nomulti=false){
1763     int n=int(m.size()),c;
1764     gen g;
1765     M.resize(n);
1766     for (int i=0;i<n;++i){
1767       const vecteur & mi=*m[i]._VECTptr;
1768       c=int(mi.size());
1769       std::vector<complex_double> & v =M[i];
1770       v.clear();
1771       v.reserve(c);
1772       const_iterateur it=mi.begin(),itend=mi.end();
1773       for (;it!=itend;++it){
1774 	if (nomulti && (it->type==_REAL || (it->type==_CPLX && it->_CPLXptr->type==_REAL)))
1775 	  return false;
1776 	g=evalf_double(*it,1,context0);
1777 	if (g.type==_CPLX && g._CPLXptr->type==_DOUBLE_ && (g._CPLXptr+1)->type==_DOUBLE_){
1778 	  v.push_back(complex_double(g._CPLXptr->_DOUBLE_val,(g._CPLXptr+1)->_DOUBLE_val));
1779 	  continue;
1780 	}
1781 	if (g.type!=_DOUBLE_)
1782 	  return false;
1783 	v.push_back(g._DOUBLE_val);
1784       }
1785     }
1786     return true;
1787   }
1788 
std_matrix_gen2matrice_destroy(std_matrix<gen> & M,matrice & m)1789   void std_matrix_gen2matrice_destroy(std_matrix<gen> & M,matrice & m){
1790     int n=int(M.size());
1791     m.clear();
1792     m.reserve(n);
1793     for (int i=0;i<n;++i){
1794       m.push_back(new ref_vecteur(0));
1795       m.back()._VECTptr->swap(M[i]);
1796     }
1797   }
1798 
proot_real1(const vecteur & v,double eps,int rprec,vecteur & res,GIAC_CONTEXT)1799   static bool proot_real1(const vecteur & v,double eps,int rprec,vecteur & res,GIAC_CONTEXT){
1800     if (v.size()<2)
1801       return false;
1802     matrice m(companion(v)),md;
1803     int dim=int(m.size());
1804     matrice I(midn(dim));
1805     std_matrix<gen> H,P;
1806     matrix_double H1,P1;
1807     matrice2std_matrix_gen(m,H);
1808     matrice2std_matrix_gen(I,P);
1809     if (eps>=1e-15 && std_matrix_gen2std_matrix_giac_double(H,H1,true)){
1810       std_matrix_gen2std_matrix_giac_double(P,P1,true);
1811       if (lapack_schur(H1,P1,false,res))
1812 	return true;
1813 #if 0
1814       return balanced_eigenvalues(H1,res,2*SOLVER_MAX_ITERATE,eps,true,contextptr);
1815 #else
1816       bool ans=francis_schur(H1,0,dim,P1,2*SOLVER_MAX_ITERATE,eps,true,false);
1817       // CERR << P << '\n' << H1 << '\n';
1818       return ans && schur_eigenvalues(H1,res,eps,contextptr);
1819 #endif
1820     }
1821     matrix_complex_double H2,P2;
1822     if (matrice2std_matrix_complex_double(m,H2,
1823 					  //false
1824 					   true /* no multi precision */
1825 					  )){
1826       if (eps<1e-13) eps=1e-13;
1827       if (debug_infolevel>2)
1828 	H2.dbgprint();
1829       matrice2std_matrix_complex_double(I,P2);
1830       bool ans=francis_schur(H2,0,dim,P2,2*SOLVER_MAX_ITERATE,eps,true,false);
1831       res.clear();
1832       for (unsigned i=0;i<H2.size();++i){
1833 	if (i+1<H2.size()){
1834 	  double d1=complex_abs(H2[i+1][i]);
1835 	  double d2=dim*eps*(complex_abs(H2[i][i])+complex_abs(H2[i+1][i+1]));
1836 	  if (d1>d2)
1837 	    ans=false;
1838 	}
1839 	complex_double c=H2[i][i];
1840 	// 3e-14 is approx 2^(-45) the number of bits of double in a gen
1841 	if (absdouble(real(c))<3e-14*absdouble(imag(c)))
1842 	  c=complex_double(0,imag(c));
1843 	if (absdouble(imag(c))<3e-14*absdouble(real(c)))
1844 	  res.push_back(real(c));
1845 	else
1846 	  res.push_back(c);
1847       }
1848       return ans;
1849     }
1850 #ifdef HAVE_LIBLAPACK
1851     // vecteur eigenvals;
1852     if (eps>=1e-13 && lapack_schur(H,P,false,res,contextptr))
1853       return true;
1854 #endif
1855 #if 0
1856     // Here we precompute P in simple precision
1857     // then start computation with inv(P)*H*P computed with current precision
1858     // -> disabled since it is slower...
1859     std_matrix<gen> Hf;
1860     matrice2std_matrix_gen(m,Hf);
1861     if (std_matrix_gen2std_matrix_giac_double(Hf,H1,true)){
1862       std_matrix_gen2std_matrix_giac_double(P,P1,true);
1863       bool ans=francis_schur(H1,0,dim,P1,2*SOLVER_MAX_ITERATE,1e-13,true,true);
1864       if (ans){
1865 	std_matrix_giac_double2std_matrix_gen(P1,P);
1866 	matrice p;
1867 	std_matrix_gen2matrice_destroy(P,p);
1868 	p=accurate_evalf(p,int(-3.2*std::log10(eps)));
1869 	matrice pinv=minv(p,contextptr);
1870 	matrice tmp,h;
1871 	mmult(p,m,tmp);
1872 	mmult(tmp,pinv,h);
1873 	matrice2std_matrix_gen(h,H);
1874 	matrice2std_matrix_gen(p,P);
1875       }
1876     }
1877 #endif
1878     bool complex_schur=false;
1879     for (unsigned i=0;!complex_schur && i<H.size();++i){
1880       for (unsigned j=0;j<H[i].size();++j){
1881 	if (H[i][j].type==_CPLX)
1882 	  complex_schur=true;
1883       }
1884     }
1885     if (!francis_schur(H,0,dim,P,2*SOLVER_MAX_ITERATE,dim*eps,false,complex_schur,false,false,contextptr))
1886       hessenberg_schur(H,P,2*SOLVER_MAX_ITERATE,dim*eps,contextptr);
1887     if (1){ // FIXME check that H is ok
1888       eps=dim*dim*eps;
1889       // read eigenvalues on diagonal of H, using subdiagonal for complex pairs
1890       for (int i=0;i<dim;++i){
1891 	if (i<dim-1 && is_greater(eps,abs(H[i+1][i],contextptr),contextptr)){
1892 	  // subdiagonal element is 0 -> diagonal element is an eigenvalue
1893 	  res.push_back(H[i][i]);
1894 	  continue;
1895 	}
1896 	if (i==dim-1 && is_greater(eps,abs(H[i][i-1],contextptr),contextptr)){
1897 	  // subdiagonal element is 0 -> diagonal element is an eigenvalue
1898 	  res.push_back(H[i][i]);
1899 	  if (debug_infolevel>2)
1900 	    CERR << "Francis algorithm Success " << res << '\n';
1901 	  return true;
1902 	}
1903 	// non-0, next one must be 0
1904 	if (i<dim-2 && !is_greater(eps,abs(H[i+2][i+1],contextptr),contextptr))
1905 	  return false;
1906 	if (i==dim-1)
1907 	  return false;
1908 	gen l1,l2;
1909 	eigenval2(H,i+2,l1,l2,contextptr);
1910 	res.push_back(l1);
1911 	res.push_back(l2);
1912 	++i;
1913       }
1914       if (debug_infolevel>2)
1915 	CERR << "Francis algorithm Success " << res << '\n';
1916       return true;
1917     }
1918     // old code using GSL
1919 #ifdef HAVE_LIBGSL
1920     int vsize=v.size();
1921     int deg2=2*(v.size()-1);
1922     double *a=new double[vsize];
1923     for (int j=0;j<vsize;j++){
1924       a[vsize-1-j]=evalf_double(v[j],1,contextptr)._DOUBLE_val;
1925     }
1926     double *z=new double[deg2];
1927     gsl_poly_complex_workspace * w = gsl_poly_complex_workspace_alloc (vsize);
1928     int gsl=gsl_poly_complex_solve (a, vsize, w, z);
1929     gsl_poly_complex_workspace_free (w);
1930     if (gsl!=GSL_SUCCESS){
1931       delete [] a; delete [] z;
1932       return false;
1933     }
1934     for (int j=0;j<deg2;j+=2){
1935       res.push_back(gen(z[j],z[j+1]));
1936     }
1937     delete [] a; delete [] z;
1938     return true;
1939 #else
1940     return false;
1941 #endif // HAVE_LIBGSL
1942   }
1943 
in_proot(const vecteur & w,double & eps,int & rprec,vecteur & res,bool isolaterealroot,GIAC_CONTEXT)1944   static bool in_proot(const vecteur & w,double & eps,int & rprec,vecteur & res,bool isolaterealroot,GIAC_CONTEXT){
1945 #ifdef EMCC
1946     if (eps<1e-300)
1947       eps=1e-11;
1948     return proot_real1(w,eps,rprec,res,contextptr);
1949 #endif
1950     // new code using francis_schur
1951     // if (has_num_coeff(w))
1952       isolaterealroot=false; // eliminating real roots is not stable enough
1953     vecteur v(w);
1954     gen prefact(1);
1955     double save_eps=eps;
1956     prefact=balance(v,eps,contextptr);
1957     // look if setting the barycenter of roots to be 0 is a good idea
1958     gen shift(-v[1]/v[0]/int(v.size()+1));
1959     vecteur vt=taylor(v,shift,0);
1960     gen maxv,maxvt;
1961     for (unsigned i=0;i<v.size();++i){
1962       gen tmp;
1963       tmp=abs(v[i],contextptr);
1964       if (is_greater(tmp,maxv,contextptr))
1965 	maxv=tmp;
1966       tmp=abs(vt[i],contextptr);
1967       if (is_greater(tmp,maxvt,contextptr))
1968 	maxvt=tmp;
1969     }
1970     if (is_greater(maxvt,maxv,contextptr))
1971       shift=0;
1972     else {
1973       eps=save_eps;
1974       double eps1=1/(evalf_double(maxvt,1,contextptr)._DOUBLE_val);
1975       if (debug_infolevel)
1976 	CERR << "proot after shift: coefficients ratio " << eps1 << '\n';
1977       if (eps1<eps)
1978 	eps=eps1;
1979       v=vt;
1980     }
1981 #if 0 // longfloat conversion does not work correctly or vect2GEN in pari.cc
1982     if (eps<1e-14 && pari_polroots(v,res,14,contextptr)){
1983       for (unsigned i=0;i<res.size();++i)
1984 	res[i] += shift;
1985       res=multvecteur(prefact,res);
1986       return true;
1987     }
1988 #else
1989 #ifdef HAVE_LIBPARI
1990     if (eps<1e-14 && pari_polroots(w,res,rprec,contextptr)){
1991       return true;
1992     }
1993 #endif
1994 #endif
1995     if (eps<1e-14 && isolaterealroot){
1996       // first try to isolate real roots
1997       gen epsg=pow(plus_two,-int(w.size())-50,contextptr);
1998       gen rr=complexroot(makesequence(w,epsg),false,contextptr);
1999       if (rr.type==_VECT && !rr._VECTptr->empty()){
2000 	vecteur rrv=*rr._VECTptr;
2001 	unsigned i=0;
2002 	for (;i<rrv.size();++i){
2003 	  if (rrv[i].type!=_VECT || rr[i]._VECTptr->size()!=2)
2004 	    break;
2005 	  rrv[i]=rrv[i]._VECTptr->front();
2006 	  if (rrv[i].type==_VECT && rrv[i]._VECTptr->size()==2)
2007 	    rrv[i]=(rrv[i][0]+rrv[i][1])/2;
2008 	  if (rrv[i].type==_REAL)
2009 	    rrv[i]=_milieu(rrv[i],contextptr);
2010 	  else
2011 	    rrv[i]=accurate_evalf(rrv[i],int(w.size())+50);
2012 	}
2013 	if (i==rrv.size()){
2014 	  rr=_pcoeff(rrv,contextptr);
2015 	  if (rr.type==_VECT){
2016 	    v=operator_div(w,*rr._VECTptr,0);
2017 	    double epseff=save_eps;
2018 	    if (in_proot(v,epseff,rprec,res,false,contextptr)){
2019 	      res=mergevecteur(rrv,res);
2020 	      return true;
2021 	    }
2022 	  }
2023 	}
2024       }
2025     }
2026     if (debug_infolevel)
2027       CERR << "proot, setting epsilon = " << eps << " for " << w << '\n';
2028     if (eps<1e-13)
2029       rprec=int((1-std::log10(eps))*3.2);
2030     // extract 0 as approx root
2031     unsigned mult0=0;
2032     while (!v.empty() && is_zero(v.back())){
2033       ++mult0;
2034       v.pop_back();
2035     }
2036     bool ans=proot_real1(v,eps,rprec,res,contextptr);
2037     for (unsigned i=0;i<res.size();++i)
2038       res[i] += shift;
2039     for (unsigned i=0;i<mult0;++i)
2040       res.push_back(shift);
2041     res=multvecteur(prefact,res);
2042     return ans;
2043   }
2044 
2045 #if 0
2046   static bool improve_root(const vecteur & v,gen & r,int nbits,int rprec){
2047     int vsize=v.size();
2048     int deg=vsize-1;
2049     vecteur cur_v(v);
2050     double ratiod=0.0,tmpratio;
2051     for (int d=1;d<=deg;++d){
2052       tmpratio=std::pow(evalf_double(abs(cur_v[d]/cur_v[0],context0),1,context0)._DOUBLE_val,1.0/d);
2053       if (tmpratio>ratiod)
2054 	ratiod=tmpratio;
2055     }
2056     gen ratio=accurate_evalf(gen(ratiod),nbits);
2057     if (ratiod>10 || ratiod<0.1){
2058       gen logratio=log(ratio,context0);
2059       if (debug_infolevel)
2060 	CERR << ratio << '\n';
2061       // Recompute coefficients
2062       for (int d=1;d<=deg;++d){
2063 	cur_v[d]=cur_v[d]/cur_v[0]*exp(-d*logratio,context0);
2064       }
2065       cur_v[0]=1;
2066     }
2067     else
2068       ratio=1;
2069     vecteur dcur_v=derivative(cur_v);
2070     int j=1;
2071     gen prefact=accurate_evalf(plus_one,nbits);
2072     gen oldval,newval,newr,dr,fprimer;
2073     r=r/ratio;
2074     oldval=horner(cur_v,r);
2075     for (;j<SOLVER_MAX_ITERATE*vsize;j++){
2076       if (!(j%vsize)){
2077 	if (is_zero(im(r,context0),context0))
2078 	  r=r*accurate_evalf(gen(1.,1e-2),nbits);
2079 	// random restart
2080 	else
2081 	  r=accurate_evalf(j/vsize*complex_double(std_rand()*1.0/RAND_MAX,std_rand()*1.0/RAND_MAX),nbits);
2082 	oldval=horner(cur_v,r);
2083 	prefact=accurate_evalf(plus_one,nbits);
2084       }
2085       fprimer=horner(dcur_v,r);
2086       dr=oldval/fprimer;
2087       newr=r-prefact*dr;
2088       if (is_positive(-rprec-ln(abs(dr,context0)/abs(r,context0),context0)/std::log(2.0),context0)){
2089 	r=ratio*newr;
2090 	return true;
2091       }
2092       newval=horner(cur_v,newr);
2093       if (is_positive(abs(newval,context0)-abs(oldval,context0),context0)){
2094 	prefact=prefact/2;
2095       }
2096       else {
2097 	r=newr;
2098 	oldval=newval;
2099 	prefact=prefact*accurate_evalf(gen(1.1),nbits);
2100 	if (is_positive(prefact-1,context0))
2101 	  prefact=accurate_evalf(plus_one,nbits);
2102       }
2103     }
2104     return false;
2105   }
2106 #endif
2107 
is_exact(const vecteur & v)2108   bool is_exact(const vecteur & v){
2109     const_iterateur it=v.begin(),itend=v.end();
2110     for (;it!=itend;++it){
2111       if (!is_exact(*it))
2112 	return false;
2113     }
2114     return true;
2115   }
2116 
is_exact(const gen & g)2117   bool is_exact(const gen & g){
2118     switch (g.type){
2119     case _DOUBLE_: case _REAL: case _FLOAT_: return false;
2120     case _CPLX:
2121       return is_exact(*g._CPLXptr) && is_exact(*(g._CPLXptr+1));
2122     case _VECT:
2123       return is_exact(*g._VECTptr);
2124     default:
2125       return true;
2126     }
2127   }
2128 
dkw_prod(const vecteur & z,int j)2129   gen dkw_prod(const vecteur & z,int j){
2130     gen zj=z[j],prod(1);
2131     for (int i=0;i<z.size();++i){
2132       if (i!=j)
2133 	prod=prod*(zj-z[i]);
2134     }
2135     return prod;
2136   }
2137 
2138   // Durand-Kerner-Weierstrass iteration for accurate roots of polynomial v
2139   // using companion matrix Schur eigenvalues as initial guess in Z
dkw(const vecteur & v,vecteur & racines,int nbits,double eps)2140   bool dkw(const vecteur & v,vecteur & racines,int nbits,double eps){
2141     vecteur z(accurate_evalf(racines,nbits));
2142     int deg=int(z.size());
2143     if (deg+1!=v.size())
2144       return false;
2145     bool reel=is_zero(im(v,context0));
2146     for (int i=0;reel && i<deg;++i){
2147       if (is_zero(im(racines[i],context0)))
2148 	continue;
2149       if (i<deg-1 && is_zero(im(racines[i]+racines[i+1],context0))){
2150 	++i;
2151 	continue;
2152       }
2153       reel=false;
2154     }
2155     vecteur w(deg);
2156     for (int i=0;i<SOLVER_MAX_ITERATE;++i){
2157       for (int j=0;j<deg;++j){
2158 	w[j]=horner(v,z[j])/dkw_prod(z,j);
2159 	if (reel){
2160 	  if (is_zero(im(z[j],context0)))
2161 	    w[j]=re(w[j],context0);
2162 	  else {
2163 	    if (j<deg-1){
2164 	      w[j+1]=conj(w[j],context0);
2165 	      ++j;
2166 	    }
2167 	  }
2168 	}
2169       }
2170       z=z-w;
2171       gen n=l2norm(w,context0);
2172       if (is_greater(eps/deg,n,context0)){
2173 	int epsbits=int(std::ceil(-std::log(eps)/std::log(2.0)));
2174 	if (epsbits<48){
2175 	  for (int i=0;i<deg;++i)
2176 	    racines[i]=evalf_double(z[i],1,context0);
2177 	}
2178 	else
2179 	  racines=accurate_evalf(z,epsbits);
2180 	return true;
2181       }
2182     }
2183     return false;
2184   }
2185 
proot(const vecteur & v,double & eps,int & rprec,bool ck_exact)2186   static vecteur proot(const vecteur & v,double & eps,int & rprec,bool ck_exact){
2187     int vsize=int(v.size());
2188     int deg=vsize-1;
2189     if (vsize<2)
2190       return vecteur(0);
2191     if (vsize==2)
2192       return vecteur(1,rprec<=50?evalf(-v[1]/v[0],1,context0):accurate_evalf(-v[1]/v[0],rprec)); // ok
2193     if (vsize==3 && !is_exactly_zero(v.back())){
2194       gen b2=accurate_evalf(-v[1]/2,rprec);
2195       gen delta=accurate_evalf(b2*b2-v[0]*v[2],rprec); // ok
2196       gen r1,r2;
2197       if (is_positive(b2,context0)){
2198 	r1=b2+sqrt(delta,context0);
2199 	r2=r1/v[0];
2200 	r1=v[2]/r1;
2201       }
2202       else {
2203 	r2=b2-sqrt(delta,context0);
2204 	r1=r2/v[0];
2205 	r2=v[2]/r2;
2206       }
2207       return makevecteur(r1,r2);
2208     }
2209     // check for 0
2210     if (v.back()==0){
2211       vecteur res=proot(vecteur(v.begin(),v.end()-1),eps,rprec,ck_exact);
2212       res.push_back(0);
2213       return res;
2214     }
2215     if (vsize%2 && v[1]==0){
2216       // check for composition with a power of X
2217       int gcddeg=0;
2218       for (int vi=2;vi<vsize;++vi){
2219 	if (v[vi]!=0)
2220 	  gcddeg=gcd(gcddeg,vi);
2221 	if (gcddeg==1)
2222 	  break;
2223       }
2224       if (gcddeg>1){
2225 	vecteur vd;
2226 	for (int i=0;i<vsize;i+=gcddeg){
2227 	  vd.push_back(v[i]);
2228 	}
2229 	vecteur resd=proot(vd,eps,rprec,ck_exact),res;
2230 	vecteur expj;
2231 	for (int j=0;j<gcddeg;++j){
2232 	  gen tmp=exp(j*cst_two_pi*cst_i/gcddeg,context0);
2233 	  if (rprec<=50)
2234 	    expj.push_back(evalf_double(tmp,1,context0));
2235 	  else
2236 	    expj.push_back(accurate_evalf(tmp,rprec));
2237 	}
2238 	for (int i=0;i<int(resd.size());++i){
2239 	  gen r=pow(resd[i],inv(gcddeg,context0),context0);
2240 	  for (int j=0;j<gcddeg;++j){
2241 	    gen tmp=r*expj[j];
2242 	    res.push_back(tmp);
2243 	  }
2244 	}
2245 	return res;
2246       }
2247     }
2248     // now check if the input is exact if there are multiple roots
2249     if (ck_exact && is_exact(v)){
2250 #if 1
2251       vecteur res;
2252       if (int(v.size())<PROOT_FACTOR_MAXDEG){
2253 	gen g=symb_horner(v,vx_var);
2254 	vecteur vv=factors(g,vx_var,context0);
2255 	for (unsigned i=0;i<vv.size()-1;i+=2){
2256 	  gen vi=vv[i];
2257 	  vi=_e2r(makevecteur(vi,vx_var),context0);
2258 	  if (vi.type==_VECT && vv[i+1].type==_INT_){
2259 #if 1 // ndef HAVE_LIBPARI
2260 	    gen norme=linfnorm(vi,context0);
2261 	    if (norme.type==_ZINT){
2262 	      rprec=giacmax(rprec,mpz_sizeinbase(*norme._ZINTptr,2));
2263 	      eps=std::pow(2.0,-rprec);
2264 	      if (eps==0) eps=1e-300;
2265 	    }
2266 #endif
2267 	    int mult=vv[i+1].val;
2268 	    vecteur current=proot(*vi._VECTptr,eps,rprec,false);
2269 	    for (unsigned j=0;j<current.size();++j){
2270 	      for (int k=0;k<mult;++k){
2271 		res.push_back(current[j]);
2272 	      }
2273 	    }
2274 	  }
2275 	}
2276 	return res;
2277       }
2278       polynome V;
2279       poly12polynome(v,1,V);
2280       factorization f=sqff(V);
2281       if (f.size()==1 && f.front().mult==1)
2282 	return proot(accurate_evalf(v,rprec),eps,rprec,false);
2283       factorization::const_iterator it=f.begin(),itend=f.end();
2284       for (;it!=itend;++it){
2285 	polynome pcur=it->fact;
2286 	int n=it->mult;
2287 	vecteur vcur;
2288 	polynome2poly1(pcur,1,vcur);
2289 	vecteur vf=accurate_evalf(vcur,rprec);
2290 	vecteur current=proot(vf,eps,rprec,false);
2291 	for (unsigned j=0;j<current.size();++j){
2292 	  for (int k=0;k<n;++k){
2293 	    res.push_back(current[j]);
2294 	  }
2295 	}
2296       }
2297       return res;
2298 #else // without multiplicities
2299       modpoly p=derivative(v),res;
2300       res=gcd(v,p,0);
2301       res=operator_div(v,res,0);
2302       gen tmp=evalf(res,1,context0);
2303       if (tmp.type!=_VECT || is_undef(tmp))
2304 	return res;
2305       return proot(*tmp._VECTptr,eps,rprec);
2306 #endif
2307     }
2308     else {
2309       if (!is_numericv(v,1))
2310 	return vecteur(0);
2311     }
2312     context ct;
2313 #ifdef HAVE_LIBPTHREAD
2314     pthread_mutex_lock(&context_list_mutex);
2315 #endif
2316     context_list().pop_back();
2317 #ifdef HAVE_LIBPTHREAD
2318     pthread_mutex_unlock(&context_list_mutex);
2319 #endif
2320     context * contextptr=&ct;
2321     epsilon(contextptr)=eps;
2322     bool add_conjugate=is_zero(im(v,contextptr),contextptr); // ok
2323     vecteur res,crystalball;
2324     bool cache=proot_cached(v,eps,crystalball);
2325     // CERR << v << " " << crystalball << '\n';
2326     if (cache)
2327       return crystalball;
2328     cache=true;
2329     // call pari if degree is large
2330     if (
2331 	0 && v.size()>=64 &&
2332 	pari_polroots(accurate_evalf(v,rprec),crystalball,giacmax(rprec,53),contextptr) && !is_undef(crystalball)){
2333       proot_cache(v,eps,crystalball);
2334       return crystalball;
2335     }
2336 #ifdef HAVE_LIBMPFR
2337     int nbits = 2*(rprec+vsize);
2338     vecteur v_accurate(accurate_evalf(v,nbits));
2339     v_accurate=divvecteur(v_accurate,v_accurate.front());
2340     // compute roots with companion matrix
2341     bool precis=true;
2342     if (crystalball.empty() && !in_proot(v,eps,rprec,crystalball,true,contextptr)){
2343       // initial guess not precise enough, DKW disabled
2344       if (0 && int(crystalball.size())==deg && dkw(v_accurate,crystalball,nbits,eps)){
2345 	proot_cache(v,eps,crystalball);
2346 	return crystalball;
2347       }
2348       precis=false;
2349       if (crystalball.size()!=v.size()-1)
2350 	CERR << "Francis algorithm failure for" << v << '\n';
2351       else
2352 	CERR << "Francis algorithm not precise enough for" << v << '\n';
2353     }
2354     int epsbits=-std::log(eps)/std::log(2.);
2355     if (precis && int(crystalball.size())==deg
2356 #ifndef EMCC
2357 	&& dkw(v_accurate,crystalball,nbits,eps)
2358 #endif
2359 	){
2360       proot_cache(v,eps,crystalball);
2361       return crystalball;
2362     }
2363     if ( (rprec<50 || rprec<epsbits+3) && int(crystalball.size())==deg){
2364       vecteur dv(derivative(v_accurate));
2365       vector<short int> done(deg);
2366       for (int j=0;j<deg;++j){
2367 	if (done[j])
2368 	  continue;
2369 	// find nearest root
2370 	gen cur=crystalball[j],mindist=plus_inf,mindist2=plus_inf;
2371 	vector<double> distances(deg);
2372 	int k2=-1,k3=-1;
2373 	for (int k=0;k<deg;k++){
2374 	  if (k==j) continue;
2375 	  gen curdist=abs(cur-crystalball[k],contextptr);
2376 	  distances[k]=evalf_double(curdist,1,contextptr)._DOUBLE_val;
2377 	  if (is_strictly_greater(mindist,curdist,contextptr)){
2378 	    mindist2=mindist;
2379 	    k3=k2;
2380 	    mindist=curdist;
2381 	    k2=k;
2382 	  }
2383 	}
2384 	gen tmp=accurate_evalf(crystalball[j],nbits);
2385 	gen decal=0;
2386 	for (unsigned k=0;int(k)<SOLVER_MAX_ITERATE;++k){
2387 	  gen num=horner(v_accurate,tmp),den=horner(dv,tmp),ratio=num/den;
2388 	  decal += ratio;
2389 	  gen prec=abs(ratio,contextptr);
2390 	  if (is_greater(eps*deg*10,prec,contextptr)){
2391 	    done[j]=1;
2392 	    tmp -= ratio;
2393 	    num=horner(v_accurate,tmp);
2394 	    den=horner(dv,tmp);
2395 	    ratio=num/den;
2396 	    prec=abs(ratio,contextptr);
2397 	    int precbits=60;
2398 	    if (is_exactly_zero(prec))
2399 	      precbits=2*epsbits;
2400 	    else
2401 	      precbits=_floor(-ln(prec,contextptr)/std::log(2.0),contextptr).val;
2402 	    if (precbits>2*epsbits)
2403 	      precbits=2*epsbits;
2404 	    if (precbits<=48)
2405 	      crystalball[j]=evalf_double(tmp,1,contextptr);
2406 	    else
2407 	      crystalball[j] =accurate_evalf(tmp,precbits);
2408 	    if (debug_infolevel)
2409 	      CERR << "Root " << j << " " << crystalball[j] << '\n';
2410 	    break;
2411 	  }
2412 	  if (is_greater(2.5*abs(decal,contextptr),mindist,contextptr)){
2413 	    // if decal is small wrt mindist2
2414 	    // we have roots that are almost equal
2415 	    // sort distance, and find a cluster of roots around
2416 	    vector<double> dists(distances);
2417 	    sort(distances.begin(),distances.end());
2418 	    unsigned dd=1; double coeff=2.0;
2419 	    for (;dd<distances.size()-1;++dd){
2420 	      if (distances[dd+1]>=coeff*distances[dd])
2421 		break;
2422 	      coeff *= .9;
2423 	    }
2424 #if 1
2425 	    if (dd<=distances.size()/3){
2426 	      vector<int> positions; vecteur roots;
2427 	      for (unsigned i=0;i<dists.size();++i){
2428 		if (done[i])
2429 		  continue;
2430 		if (dists[i]<=distances[dd]){
2431 		  positions.push_back(i);
2432 		  roots.push_back(accurate_evalf(crystalball[i],nbits));
2433 		  if (i+1<dists.size() && add_conjugate && !is_exactly_zero(im(crystalball[i],contextptr))){
2434 		    positions.push_back(i+1);
2435 		    roots.push_back(accurate_evalf(crystalball[i+1],nbits));
2436 		    ++i;
2437 		  }
2438 		}
2439 	      }
2440 	      if (roots.size()>=10)
2441 		k=SOLVER_MAX_ITERATE;
2442 	      if (debug_infolevel)
2443 		CERR << CLOCK()*1e-6 << "Entering generalized Bairstow " << dd << " roots " << positions << '\n';
2444 	      vecteur current=pcoeff(roots),dcurrent;
2445 	      for (;int(k)<SOLVER_MAX_ITERATE;++k){
2446 		modpoly Q,R,dR;
2447 		DivRem(v_accurate,current,0,Q,R);
2448 		// find partial derivatives
2449 		matrice m;
2450 		for (unsigned i=0;i<roots.size();++i){
2451 		  dR=Q % current;
2452 		  if (dR.size()<roots.size())
2453 		    dR=mergevecteur(vecteur(roots.size()-dR.size()),dR);
2454 		  m.push_back(dR);
2455 		  Q.push_back(0); // multiply Q by x for next partial derivative
2456 		}
2457 		// invert jacobian matrix
2458 		reverse(m.begin(),m.end());
2459 		m=mtran(m);
2460 		while (R.size()<m.size())
2461 		  R.insert(R.begin(),accurate_evalf(zero,nbits));
2462 		// solve system
2463 		dcurrent=linsolve(m,R,contextptr);
2464 		vecteur dcurrentv=lidnt(dcurrent);
2465 		if (!dcurrentv.empty()){
2466 		  if (debug_infolevel)
2467 		    CERR << "non invertible jacobian" << '\n';
2468 		  break;
2469 		}
2470 		dcurrent.insert(dcurrent.begin(),0);
2471 		// termination test
2472 		gen ck=0;
2473 		for (unsigned i=1;i<dcurrent.size();++i){
2474 		  if (!is_exactly_zero(current[i]))
2475 		    ck+=abs(dcurrent[i]/current[i],contextptr);
2476 		}
2477 		current=addvecteur(current,dcurrent);
2478 		if (is_greater(eps,ck,contextptr))
2479 		  break;
2480 	      }
2481 	      if (int(k)>=SOLVER_MAX_ITERATE){
2482 		CERR << "Unable to isolate roots number "<< positions << '\n' << accurate_evalf(roots,50) << '\n';
2483 		for (unsigned i=0;i<positions.size();++i)
2484 		  done[positions[i]]=-1;
2485 		cache=false;
2486 		break;
2487 	      }
2488 	      else {
2489 		// proot recursive call, and stores roots
2490 		// check if current has a multiple root up to precision eps
2491 		int curdeg=current.size()-1;
2492 		gen multi=-current[1]/(curdeg*current[0]);
2493 		roots=vecteur(curdeg,multi);
2494 		vecteur test=pcoeff(roots);
2495 		test=subvecteur(current,test);
2496 		gen testn=l2norm(test,contextptr);
2497 		if (curdeg>1 && is_greater(eps,testn,contextptr)){
2498 		  int precbits=48;
2499 		  if (testn!=0)
2500 		    precbits=_floor(-ln(testn,contextptr)/std::log(2.0),contextptr).val;
2501 		  multi=accurate_evalf(multi,precbits);
2502 		  for (unsigned i=0;i<positions.size();++i){
2503 		    done[positions[i]]=1;
2504 		    crystalball[positions[i]] =multi;
2505 		  }
2506 		}
2507 		else {
2508 		  double eps1=std::pow(2.0,-nbits);
2509 		  roots=proot(current,eps1,nbits);
2510 		  for (unsigned i=0;i<positions.size();++i){
2511 		    // -> Set precision
2512 		    roots[i]=accurate_evalf(roots[i],nbits);
2513 		    num=horner(v_accurate,roots[i]);
2514 		    den=horner(dv,roots[i]);
2515 		    ratio=num/den;
2516 		    prec=abs(ratio,contextptr);
2517 		    int precbits=60;
2518 		    if (is_exactly_zero(prec))
2519 		      precbits=2*epsbits;
2520 		    else
2521 		      precbits=_floor(-ln(prec,contextptr)/std::log(2.0),contextptr).val;
2522 		    if (precbits>2*epsbits)
2523 		      precbits=2*epsbits;
2524 		    done[positions[i]]=1;
2525 		    if (precbits<=48)
2526 		      crystalball[positions[i]]=evalf_double(roots[i],1,contextptr);
2527 		    else
2528 		      crystalball[positions[i]] =accurate_evalf(roots[i],precbits);
2529 		  }
2530 		}
2531 		break;
2532 	      }
2533 	    }
2534 #else
2535 	    // the second one is crystalball[k2]
2536 	    if (is_greater(mindist2,3*abs(ratio,contextptr),contextptr)){
2537 	      if (debug_infolevel)
2538 		CERR << "Entering Bairstow " << j << " " << k2 << '\n';
2539 	      tmp=accurate_evalf(crystalball[j],nbits);
2540 	      if (crystalball[j]==conj(crystalball[j+1],contextptr)) k2=j+1;
2541 	      gen tmp2=accurate_evalf(crystalball[k2],nbits);
2542 	      modpoly current(3,1); current[1]=-tmp-tmp2; current[2]=tmp*tmp2;
2543 	      for (;k<SOLVER_MAX_ITERATE;++k){
2544 		modpoly Q,R,dsR,dpR;
2545 		DivRem(v_accurate,current,0,Q,R);
2546 		dpR=Q % current;
2547 		if (dpR.empty() || is_zero(dpR.back()))
2548 		  break;
2549 		Q.push_back(0);
2550 		dsR=Q % current;
2551 		if (dsR.empty() || is_zero(dsR.back()))
2552 		  break;
2553 		gen A,B,C(dsR.back()),D(dpR.back()),R0,R1;
2554 		if (dpR.size()==2)
2555 		  B=dpR[0];
2556 		if (dsR.size()==2)
2557 		  A=dsR[0];
2558 		gen delta=A*D-B*C;
2559 		if (is_zero(delta))
2560 		  break;
2561 		if (!R.empty()){
2562 		  R1=R.back();
2563 		  if (R.size()==2)
2564 		    R0=R.front();
2565 		}
2566 		gen dc1=(D*R0-B*R1)/delta,dc2=(A*R1-C*R0)/delta;
2567 		current[1] += dc1;
2568 		current[2] += dc2;
2569 		if (is_greater(eps*deg*10,abs(dc1/current[1],contextptr)+abs(dc2/current[2],contextptr),contextptr)){
2570 		  // recompute crystalball[j]/k2 and tmp/tmp2
2571 		  gen s=current[1],p=current[2];
2572 		  delta=s*s-4*p;
2573 		  delta=sqrt(delta,contextptr);
2574 		  if (is_positive(s,contextptr)){
2575 		    tmp=(-s-delta)/2;
2576 		    tmp2=p/tmp;
2577 		  }
2578 		  else {
2579 		    tmp2=(-s+delta)/2;
2580 		    tmp=p/tmp2;
2581 		  }
2582 		  decal=0;
2583 		  ratio=0;
2584 		  if (eps<1e-14){
2585 		    crystalball[j]=accurate_evalf(tmp,-3.2*std::log(eps));
2586 		    crystalball[k2]=accurate_evalf(tmp2,-3.2*std::log(eps));
2587 		  }
2588 		  else {
2589 		    crystalball[j]=evalf_double(tmp,1,contextptr);
2590 		    crystalball[k2]=evalf_double(tmp2,1,contextptr);
2591 		  }
2592 		  break;
2593 		}
2594 	      }
2595 	    }
2596 #endif
2597 	    if (is_greater(3*abs(decal,contextptr),mindist,contextptr)){
2598 	      cache=false;
2599 	      done[j]=false;
2600 	      CERR << "Bad conditionned root j= " << j << " value " << crystalball[j] << " ratio " << evalf_double(abs(ratio,contextptr),1,contextptr) << " mindist " << mindist << '\n';
2601 	      break;
2602 	    }
2603 	  }
2604 	  tmp -= ratio;
2605 	}
2606       }
2607       if (!cache && pari_polroots(v,crystalball,14,contextptr))
2608 	cache=true;
2609       if (0 && !cache){ // could be improved via Hensel lifting
2610 	vecteur good;
2611 	for (unsigned i=0;i<crystalball.size();++i){
2612 	  if (done[i]==1)
2613 	    good.push_back(crystalball[i]);
2614 	}
2615 	good=pcoeff(good);
2616 	vecteur rem=operator_div(v,good,0);
2617 	if (rem.size()<=crystalball.size()/2){
2618 	  rem=*_proot(rem,contextptr)._VECTptr;
2619 	  CERR << rem << '\n';
2620 	}
2621       }
2622       if (cache)
2623 	proot_cache(v,eps,crystalball);
2624       return crystalball;
2625     } // if rprec<50 ...
2626 
2627 #else // HAVE_LIBMPFR
2628     int nbits=45;
2629     rprec = 37;
2630     vecteur v_accurate(*evalf_double(v,1,contextptr)._VECTptr);
2631     if (crystalball.empty()){
2632       in_proot(v,eps,rprec,crystalball,true,contextptr);
2633       // CERR << crystalball << '\n';
2634       proot_cache(v,eps,crystalball);
2635     }
2636     return crystalball;
2637     // GSL call is much faster but not very accurate
2638     //if (eps<1e-5)
2639     //  eps=1e-5;
2640 #endif //HAVE_LIBMPFR
2641     vecteur dv_accurate(derivative(v_accurate));
2642     gen r,vr,dr;
2643     vecteur cur_v(v_accurate),dcur_v(dv_accurate),new_v;
2644     for (int i=0;;++i,eps*=1.1){
2645       if (cur_v.size()<2)
2646 	return res;
2647       // gen scale=linfnorm(cur_v);
2648       // r=a_root(cur_v,0,scale.evalf_double(1,contextptr)._DOUBLE_val*eps); // ok
2649       if (!crystalball.empty()){
2650 	r=crystalball.back();
2651 	crystalball.pop_back();
2652       }
2653       else
2654 	r=a_root(*evalf_double(cur_v,1,contextptr)._VECTptr,0,eps); // ok
2655       if (debug_infolevel)
2656 	CERR << "Approx float root " << r << '\n';
2657       if (is_undef(r))
2658 	return res;
2659       r=accurate_evalf(r,nbits);
2660       int j=1;
2661       gen prefact=accurate_evalf(plus_one,nbits);
2662       gen oldval,newval,newr,fprimer;
2663       oldval=horner(cur_v,r);
2664       int vsize2=vsize*(1+nbits/48);
2665       for (;j<SOLVER_MAX_ITERATE*vsize2;j++){
2666 	if (!(j%vsize2)){
2667 	  if (is_zero(im(r,contextptr),contextptr))
2668 	    r=r*accurate_evalf(gen(1.,1e-2),nbits);
2669 	  // random restart
2670 	  else
2671 	    r=accurate_evalf(j/vsize*complex_double(std_rand()*1.0/RAND_MAX,std_rand()*1.0/RAND_MAX),nbits);
2672 	  oldval=horner(cur_v,r);
2673 	  prefact=accurate_evalf(plus_one,nbits);
2674 	}
2675 	fprimer=horner(dcur_v,r);
2676 	dr=oldval/fprimer;
2677 	newr=r-prefact*dr;
2678 	if (is_zero(dr) || is_positive(-rprec-ln(abs(dr,contextptr)/abs(r,contextptr),contextptr)/std::log(2.0),contextptr)){
2679 	  r=newr;
2680 	  break;
2681 	}
2682 	newval=horner(cur_v,newr);
2683 	if (is_strictly_positive(abs(newval,contextptr)-abs(oldval,contextptr),contextptr)){
2684 	  prefact=prefact/2;
2685 	}
2686 	else {
2687 	  r=newr;
2688 	  oldval=newval;
2689 	  prefact=prefact*accurate_evalf(gen(1.1),nbits);
2690 	  if (is_positive(prefact-1,contextptr))
2691 	    prefact=accurate_evalf(plus_one,nbits);
2692 	}
2693       }
2694       for (j=0;j<vsize;j++){
2695 	dr=horner(v_accurate,r)/horner(dv_accurate,r);
2696 	r=r-dr;
2697 	if (is_zero(dr) || is_positive(-rprec-ln(abs(dr,contextptr)/abs(r,contextptr),contextptr)/std::log(2.0),contextptr))
2698 	  break;
2699       }
2700       if (j==vsize)
2701 	return vecteur(1,gensizeerr(gettext("Proot error : no root found for ")+gen(v).print(contextptr)));
2702       if (debug_infolevel)
2703 	CERR << "Root found " << evalf_double(r,1,contextptr) << '\n';
2704       if (add_conjugate && is_greater(abs(im(r,contextptr),contextptr),eps,contextptr) ){ // ok
2705 	res.push_back(rprec<53?evalf_double(conj(r,contextptr),1,contextptr):conj(accurate_evalf(r,rprec),contextptr)); // ok
2706 	if (!crystalball.empty()){
2707 	  gen rcrystal=crystalball.back();
2708 	  if (is_greater(1e-5,abs(rcrystal-res.back(),contextptr),contextptr))
2709 	    crystalball.pop_back();
2710 	}
2711 	vr=horner(cur_v,r,0,new_v);
2712 	horner(new_v,conj(r,contextptr),0,cur_v); // ok
2713 	cur_v=*(re(cur_v,contextptr)._VECTptr); // ok
2714       }
2715       else {
2716 	if (add_conjugate)
2717 	  r=re(r,contextptr);
2718 	vr=horner(cur_v,r,0,new_v);
2719 	cur_v=new_v;
2720       }
2721       res.push_back(rprec<53?evalf_double(r,1,contextptr):accurate_evalf(r,rprec)); // ok
2722       dcur_v=derivative(cur_v);
2723     } // end i loop
2724   }
2725 
proot(const vecteur & v,double & eps,int & rprec)2726   vecteur proot(const vecteur & v,double & eps,int & rprec){
2727     return proot(v,eps,rprec,true);
2728   }
2729 
proot(const vecteur & v,double eps)2730   vecteur proot(const vecteur & v,double eps){
2731     int rprec=45;
2732     return proot(v,eps,rprec);
2733   }
2734 
real_proot(const vecteur & v,double eps,GIAC_CONTEXT)2735   vecteur real_proot(const vecteur & v,double eps,GIAC_CONTEXT){
2736 #if 1
2737     gen r(complexroot(makesequence(v,eps),false,contextptr));
2738     if (r.type!=_VECT) return vecteur(1,undef);
2739     const vecteur &w = *r._VECTptr;
2740     if (is_undef(w)) return w;
2741     int nbits=int(1-3.2*std::log(eps));
2742     vecteur res;
2743     const_iterateur it=w.begin(),itend=w.end();
2744     for (;it!=itend;++it){
2745       if (it->type==_VECT && it->_VECTptr->size()==2){
2746 	gen tmp=it->_VECTptr->front();
2747 	if (tmp.type==_VECT){
2748 	  tmp=(tmp._VECTptr->front()+tmp._VECTptr->back())/2;
2749 	  if (eps<1e-14)
2750 	    tmp=accurate_evalf(tmp,nbits);
2751 	  else
2752 	    tmp=evalf_double(tmp,1,contextptr);
2753 	}
2754 	res.push_back(tmp);
2755       }
2756     }
2757     return res;
2758 #else
2759     vecteur w(proot(v,eps));
2760     if (is_undef(w)) return w;
2761     vecteur res;
2762     const_iterateur it=w.begin(),itend=w.end();
2763     for (;it!=itend;++it){
2764       if (is_real(*it,contextptr))
2765 	res.push_back(*it);
2766     }
2767     return res;
2768 #endif
2769   }
2770 
2771   // eps is defined using the norm of v
proot(const vecteur & v)2772   vecteur proot(const vecteur & v){
2773     double eps=1e-12;
2774     // this should take care of precision inside v!
2775     return proot(v,eps);
2776   }
2777 
_proot(const gen & v,GIAC_CONTEXT)2778   gen _proot(const gen & v,GIAC_CONTEXT){
2779     if ( v.type==_STRNG && v.subtype==-1) return  v;
2780     if (v.type!=_VECT)
2781       return _proot(makesequence(v,ggb_var(v)),contextptr);
2782     if (v._VECTptr->empty())
2783       return v;
2784     vecteur w=*v._VECTptr;
2785     int digits=decimal_digits(contextptr);
2786     double eps=epsilon(contextptr);
2787     if (v.subtype==_SEQ__VECT && w.back().type==_INT_){
2788       digits=giacmax(w.back().val,14);
2789       eps=std::pow(0.1,double(digits));
2790       w.pop_back();
2791     }
2792     if (w.size()==1)
2793       w.push_back(ggb_var(w[0]));
2794     if (w.size()==2 && w[1].type==_IDNT){
2795       gen tmp=_e2r(gen(w,_SEQ__VECT),contextptr);
2796       if (is_undef(tmp)) return tmp;
2797       if (tmp.type==_FRAC)
2798 	tmp=tmp._FRACptr->num;
2799       if (tmp.type!=_VECT)
2800 	return vecteur(0);
2801       w=*tmp._VECTptr;
2802     }
2803     for (unsigned i=0;i<w.size();++i){
2804       gen tmp=evalf(w[i],1,contextptr);
2805       if (tmp.type>_REAL && tmp.type!=_FLOAT_ && tmp.type!=_CPLX)
2806 	return gensizeerr(contextptr);
2807     }
2808     int rprec(int(digits*3.3));
2809     return _sorta(proot(w,eps,rprec),contextptr);
2810   }
symb_proot(const gen & e)2811   gen symb_proot(const gen & e) {
2812     return symbolic(at_proot,e);
2813   }
2814   static const char _proot_s []="proot";
2815   static define_unary_function_eval (__proot,&_proot,_proot_s);
2816   define_unary_function_ptr5( at_proot ,alias_at_proot,&__proot,0,true);
2817 
pcoeff(const vecteur & v)2818   vecteur pcoeff(const vecteur & v){
2819     vecteur w(1,plus_one),new_w,somme;
2820     gen a,b;
2821     const_iterateur it=v.begin(),itend=v.end();
2822     for (;it!=itend;++it){
2823       if (it->type==_CPLX && it+1!=itend && is_zero(*it-conj(*(it+1),context0))){
2824 	a=re(*it,context0);
2825 	b=im(*it,context0);
2826 	b=a*a+b*b;
2827 	a=-2*a;
2828 	w=w*makevecteur(1,a,b);
2829 	++it;
2830 	continue;
2831       }
2832       new_w=w;
2833       new_w.push_back(zero); // new_w=w*x
2834       mulmodpoly(w,-(*it),w); // w = -w*root
2835       addmodpoly(new_w,w,somme);
2836       w=somme;
2837     }
2838     return w;
2839   }
_pcoeff(const gen & v,GIAC_CONTEXT)2840   gen _pcoeff(const gen & v,GIAC_CONTEXT){
2841     if ( v.type==_STRNG && v.subtype==-1) return  v;
2842     if (v.type!=_VECT)
2843       return symb_pcoeff(v);
2844     return gen(pcoeff(*v._VECTptr),_POLY1__VECT);
2845   }
symb_pcoeff(const gen & e)2846   gen symb_pcoeff(const gen & e) {
2847     return symbolic(at_pcoeff,e);
2848   }
2849   static const char _pcoeff_s []="pcoeff";
2850   static define_unary_function_eval (__pcoeff,&_pcoeff,_pcoeff_s);
2851   define_unary_function_ptr5( at_pcoeff ,alias_at_pcoeff,&__pcoeff,0,true);
2852 
_peval(const gen & e,GIAC_CONTEXT)2853   gen _peval(const gen & e,GIAC_CONTEXT){
2854     if ( e.type==_STRNG && e.subtype==-1) return  e;
2855     if (e.type!=_VECT)
2856       return gentypeerr(contextptr);
2857     vecteur & args=*e._VECTptr;
2858     if ( (args.size()==2) && (args.front().type==_VECT) )
2859       return horner(*(args.front()._VECTptr),args.back());
2860     if ( (args.size()!=3) || (args[1].type!=_VECT) || (args[2].type!=_VECT) )
2861       return gentypeerr(contextptr);
2862     gen pol(args.front());
2863     vecteur vars(*args[1]._VECTptr);
2864     vecteur vals(*args[2]._VECTptr);
2865     if (vars.size()!=vals.size())
2866       return gendimerr(contextptr);
2867     for (int i=0;i<signed(vars.size());++i){
2868       if (vars[i].type!=_IDNT)
2869 	return gensizeerr(contextptr);
2870     }
2871     // convert to internal form:
2872     // now put vars at the beginning of the list of variables
2873     vecteur lv(vars);
2874     lvar(e,lv);
2875     vecteur lv1(lv.begin()+vars.size(),lv.end());
2876     pol=sym2r(pol,lv,contextptr);
2877     gen polnum,polden;
2878     fxnd(pol,polnum,polden);
2879     for (int i=0;i<signed(vals.size());++i){
2880       if (debug_infolevel)
2881 	CERR << "// Peval conversion of var " << i << " " << CLOCK()*1e-6 << '\n';
2882       vals[i]=e2r(vals[i],lv1,contextptr);
2883     }
2884     if (debug_infolevel)
2885       CERR << "// Peval conversion to internal form completed " << CLOCK()*1e-6 << '\n';
2886     if (polnum.type==_POLY)
2887       polnum=peval(*polnum._POLYptr,vals,0);
2888     if (polden.type==_POLY)
2889       polden=peval(*polden._POLYptr,vals,0);
2890     pol=rdiv(polnum,polden,contextptr);
2891     return r2sym(pol,lv1,contextptr);
2892   }
symb_peval(const gen & arg1,const gen & arg2)2893   gen symb_peval(const gen & arg1,const gen & arg2) {
2894     return symbolic(at_peval,makesequence(arg1,arg2));
2895   }
2896   static const char _peval_s []="peval";
2897   static define_unary_function_eval (__peval,&_peval,_peval_s);
2898   define_unary_function_ptr5( at_peval ,alias_at_peval,&__peval,0,true);
2899 
vrows(const vecteur & a)2900   int vrows(const vecteur & a){
2901     return int(a.size());
2902   }
2903 
2904   // addvecteur is different from addmodpoly if a and b have != sizes
2905   // because it always start adding at the beginning of a and b
addvecteur(const vecteur & a,const vecteur & b,vecteur & res)2906   void addvecteur(const vecteur & a,const vecteur & b,vecteur & res){
2907     if (&b==&res && &b!=&a){
2908       addvecteur(b,a,res);
2909       return ;
2910     }
2911     vecteur::const_iterator itb=b.begin(), itbend=b.end();
2912     if (&a==&res){ // in-place addition
2913       vecteur::iterator ita=res.begin(), itaend=res.end();
2914       for (;(ita!=itaend)&&(itb!=itbend);++ita,++itb){
2915 	*ita=*ita+*itb;
2916       }
2917       for (;itb!=itbend;++itb)
2918 	res.push_back(*itb);
2919       return;
2920     }
2921     vecteur::const_iterator ita=a.begin(), itaend=a.end();
2922     res.clear();
2923     res.reserve(giacmax(int(itbend-itb),int(itaend-ita)));
2924     for (;(ita!=itaend)&&(itb!=itbend);++ita,++itb){
2925       res.push_back(*ita+*itb);
2926     }
2927     for (;ita!=itaend;++ita)
2928       res.push_back(*ita);
2929     for (;itb!=itbend;++itb)
2930       res.push_back(*itb);
2931   }
2932 
2933   // subvecteur is different from submodpoly if a and b have != sizes
2934   // because it always start substr. at the beginning of a and b
subvecteur(const vecteur & a,const vecteur & b,vecteur & res)2935   void subvecteur(const vecteur & a,const vecteur & b,vecteur & res){
2936     if (&b==&res){
2937       vecteur::const_iterator ita=a.begin(), itaend=a.end();
2938       vecteur::iterator itb=res.begin(), itbend=res.end();
2939       for (;(ita!=itaend)&&(itb!=itbend);++ita,++itb){
2940 	*itb=*ita-*itb;
2941       }
2942       for (;ita!=itaend;++ita)
2943 	res.push_back(*ita);
2944       return;
2945     }
2946     vecteur::const_iterator itb=b.begin(), itbend=b.end();
2947     if (&a==&res){ // in-place substract
2948       vecteur::iterator ita=res.begin(), itaend=res.end();
2949       for (;(ita!=itaend)&&(itb!=itbend);++ita,++itb){
2950 	operator_minus_eq(*ita,*itb,context0);
2951       }
2952       for (;itb!=itbend;++itb)
2953 	res.push_back(-*itb);
2954       return;
2955     }
2956     vecteur::const_iterator ita=a.begin(), itaend=a.end();
2957     res.clear();
2958     res.reserve(giacmax(int(itbend-itb),int(itaend-ita)));
2959     for (;(ita!=itaend)&&(itb!=itbend);++ita,++itb){
2960       res.push_back(*ita-*itb);
2961     }
2962     for (;ita!=itaend;++ita)
2963       res.push_back(*ita);
2964     for (;itb!=itbend;++itb)
2965       res.push_back(-*itb);
2966   }
2967 
addvecteur(const vecteur & a,const vecteur & b)2968   vecteur addvecteur(const vecteur & a,const vecteur & b){
2969     vecteur res;
2970     addvecteur(a,b,res);
2971     return res;
2972   }
2973 
subvecteur(const vecteur & a,const vecteur & b)2974   vecteur subvecteur(const vecteur & a,const vecteur & b){
2975     vecteur res;
2976     subvecteur(a,b,res);
2977     return res;
2978   }
2979 
negvecteur(const vecteur & v)2980   vecteur negvecteur(const vecteur & v){
2981     vecteur w;
2982     negmodpoly(v,w);
2983     return w;
2984   }
2985 
dotvecteur(const vecteur & a,const vecteur & b)2986   gen dotvecteur(const vecteur & a,const vecteur & b){
2987     vecteur::const_iterator ita=a.begin(), itaend=a.end();
2988     vecteur::const_iterator itb=b.begin(), itbend=b.end();
2989     if (ita==itaend || itb==itbend) return 0;
2990     gen res,tmp;
2991     //if (ita->type==_VECT && itb->type==_VECT && dotvecteur_interp(a,b,res)) return res;
2992     //if (0 && itaend-ita>10 && itbend-itb>10 && ita->type==_POLY && itb->type==_POLY && dotvecteur_interp(a,b,res)) return res;
2993     for (;(ita!=itaend)&&(itb!=itbend);++ita,++itb){
2994       type_operator_times((*ita),(*itb),tmp);
2995       res += tmp;
2996     }
2997     return res;
2998   }
2999 
dotvecteur(const gen & g1,const gen & g2)3000   gen dotvecteur(const gen & g1,const gen & g2){
3001     gen a=remove_at_pnt(g1);
3002     gen b=remove_at_pnt(g2);
3003     if (a.type!=_VECT || b.type!=_VECT)
3004       return gensizeerr(gettext("dotvector"));
3005     if (a.subtype==_VECTOR__VECT)
3006       return dotvecteur(vector2vecteur(*a._VECTptr),b);
3007     if (b.subtype==_VECTOR__VECT)
3008       return dotvecteur(a,vector2vecteur(*b._VECTptr));
3009     return dotvecteur(*a._VECTptr,*b._VECTptr);
3010   }
3011 
multvecteur(const gen & a,const vecteur & b,vecteur & res)3012   void multvecteur(const gen & a,const vecteur & b,vecteur & res){
3013     if (b.empty()){
3014       res.clear();
3015       return;
3016     }
3017     if (b.front().type==_VECT && ckmatrix(b)){
3018       vecteur temp;
3019       if (&b==&res){
3020 	iterateur it=res.begin(),itend=res.end();
3021 	for (;it!=itend;++it){
3022 	  if (it->type==_VECT)
3023 	    multvecteur(a,*it->_VECTptr,*it->_VECTptr);
3024 	  else
3025 	    *it = a*(*it);
3026 	}
3027 	return;
3028       }
3029       const_iterateur it=b.begin(),itend=b.end();
3030       res.clear();
3031       res.reserve(itend-it);
3032       for (;it!=itend;++it){
3033 	if (it->type==_VECT){
3034 	  multvecteur(a,*it->_VECTptr,temp);
3035 	  res.push_back(temp);
3036 	}
3037 	else
3038 	  res.push_back(a*(*it));
3039       }
3040       return;
3041     }
3042     if (is_exactly_zero(a)){
3043       if (&b==&res){
3044 	iterateur it=res.begin(),itend=res.end();
3045 	for (;it!=itend;++it)
3046 	  *it=(*it)*zero;
3047       }
3048       else {
3049 	const_iterateur it=b.begin(),itend=b.end();
3050 	res.clear();
3051 	res.reserve(itend-it);
3052 	for (;it!=itend;++it)
3053 	  res.push_back((*it)*zero);
3054       }
3055     }
3056     else {
3057       mulmodpoly(b,a,0,res);
3058     }
3059   }
3060 
multvecteur(const gen & a,const vecteur & b)3061   vecteur multvecteur(const gen & a,const vecteur & b){
3062     vecteur res;
3063     multvecteur(a,b,res);
3064     return res;
3065   }
3066 
divvecteur(const vecteur & b,const gen & a,vecteur & res)3067   void divvecteur(const vecteur & b,const gen & a,vecteur & res){
3068     if (b.empty()){
3069       res.clear();
3070       return;
3071     }
3072     if (&b==&res){
3073       if (is_one(a))
3074 	return;
3075       iterateur it=res.begin(),itend=res.end();
3076       mpz_t tmpz;
3077       mpz_init(tmpz);
3078       for (;it!=itend;++it){
3079 	if (it->type==_VECT){
3080 	  vecteur temp;
3081 	  divvecteur(*it->_VECTptr,a,*it->_VECTptr);
3082 	}
3083 	else {
3084 #ifndef USE_GMP_REPLACEMENTS
3085 	  if (it->type==_ZINT && a.type==_ZINT && it->ref_count()==1){
3086 	    my_mpz_gcd(tmpz,*it->_ZINTptr,*a._ZINTptr);
3087 	    if (mpz_cmp_ui(tmpz,1)==0)
3088 	      *it=fraction(*it,a);
3089 	    else {
3090 	      mpz_divexact(*it->_ZINTptr,*it->_ZINTptr,tmpz);
3091 	      ref_mpz_t * den=new ref_mpz_t;
3092 	      mpz_divexact(den->z,*a._ZINTptr,tmpz);
3093 	      *it = fraction(*it,den);
3094 	    }
3095 	  }
3096 	  else
3097 #endif
3098 	    *it=rdiv(*it,a,context0);
3099 	}
3100       }
3101       mpz_clear(tmpz);
3102       return;
3103     }
3104     if (b.front().type==_VECT && ckmatrix(b)){
3105       const_iterateur it=b.begin(),itend=b.end();
3106       res.clear();
3107       res.reserve(itend-it);
3108       for (;it!=itend;++it){
3109 	if (it->type==_VECT){
3110 	  vecteur temp;
3111 	  divvecteur(*it->_VECTptr,a,temp);
3112 	  res.push_back(temp);
3113 	}
3114 	else
3115 	  res.push_back(rdiv(*it,a,context0));
3116       }
3117       return;
3118     }
3119     divmodpoly(b,a,res);
3120   }
3121 
divvecteur(const vecteur & b,const gen & a)3122   vecteur divvecteur(const vecteur & b,const gen & a){
3123     vecteur res;
3124     divvecteur(b,a,res);
3125     return res;
3126   }
3127 
multmatvecteur(const matrice & a,const vecteur & b,vecteur & res)3128   void multmatvecteur(const matrice & a,const vecteur & b,vecteur & res){
3129     vector<int> B; gen x;
3130     int btype=gf_char2_vecteur2vectorint(b,B,x);
3131     if (btype>0){
3132       vector< vector<int> > A;
3133       int atype=gf_char2_matrice2vectorvectorint(a,A,x);
3134       if (atype==0 || atype==btype){
3135 	vector< vector<int> >::const_iterator ita=A.begin(), itaend=A.end();
3136 	res.clear();
3137 	res.reserve(itaend-ita);
3138 	for (;ita!=itaend;++ita)
3139 	  res.push_back(galois_field(plus_two,btype,x,dotgf_char2(*ita,B,btype)));
3140       }
3141     }
3142     vecteur::const_iterator ita=a.begin(), itaend=a.end();
3143     res.clear();
3144     res.reserve(itaend-ita);
3145     for (;ita!=itaend;++ita)
3146       res.push_back(dotvecteur(*(ita->_VECTptr),b));
3147   }
3148 
multmatvecteur(const matrice & a,const vecteur & b)3149   vecteur multmatvecteur(const matrice & a,const vecteur & b){
3150     vecteur res;
3151     multmatvecteur(a,b,res);
3152     return res;
3153   }
3154 
multvecteurmat(const vecteur & a,const matrice & b,vecteur & res)3155   void multvecteurmat(const vecteur & a,const matrice & b,vecteur & res){
3156     matrice btran;
3157     mtran(b,btran);
3158     multmatvecteur(btran,a,res);
3159   }
3160 
multvecteurmat(const vecteur & a,const matrice & b)3161   vecteur multvecteurmat(const vecteur & a,const matrice & b){
3162     vecteur res;
3163     multvecteurmat(a,b,res);
3164     return res;
3165   }
3166 
ckmultmatvecteur(const vecteur & a,const vecteur & b,GIAC_CONTEXT)3167   gen ckmultmatvecteur(const vecteur & a,const vecteur & b,GIAC_CONTEXT){
3168     if (ckmatrix(a)){
3169       if (ckmatrix(b)){
3170 	matrice res;
3171 	if (!mmultck(a,b,res))
3172 	  return gendimerr("");
3173 	gen tmp=_simplifier(res,contextptr);
3174 	// code added for e.g. matpow([[0,1],[0,0]],n)
3175 	if (contains(tmp,undef))
3176 	  return res;
3177 	return tmp;
3178       }
3179       // matrice * vecteur
3180       vecteur res;
3181       if (a.front()._VECTptr->size()!=b.size())
3182 	return gendimerr(gettext("dotvecteur"));
3183       multmatvecteur(a,b,res);
3184       return _simplifier(res,contextptr);
3185     }
3186     if (ckmatrix(b)){
3187       vecteur res;
3188       multvecteurmat(a,b,res);
3189       return _simplifier(res,contextptr);
3190     }
3191     if (xcas_mode(contextptr)==3 || calc_mode(contextptr)==1)
3192       return apply(a,b,prod);
3193     return dotvecteur(a,b);
3194   }
3195 
3196   // *********************
3197   // ***   Matrices    ***
3198   // *********************
3199 
ckmatrix(const matrice & a,bool allow_embedded_vect)3200   bool ckmatrix(const matrice & a,bool allow_embedded_vect){
3201     vecteur::const_iterator it=a.begin(),itend=a.end();
3202     if (itend==it)
3203       return false;
3204     int s=-1;
3205     int cur_s;
3206     for (;it!=itend;++it){
3207       if (it->type!=_VECT)
3208 	return false;
3209       cur_s=int(it->_VECTptr->size());
3210       if (!cur_s)
3211 	return false;
3212       if (s<0)
3213 	s = cur_s;
3214       else {
3215 	if (s!=cur_s)
3216 	  return false;
3217 	if (s && (it->_VECTptr->front().type==_VECT && it->_VECTptr->front().subtype!=_POLY1__VECT) && !allow_embedded_vect)
3218 	  return false;
3219 	for (int i=0;i<s;++i)
3220 	  if (is_undef((*it->_VECTptr)[i]))
3221 	    return false;
3222       }
3223     }
3224     return true;
3225   }
3226 
ckmatrix(const matrice & a)3227   bool ckmatrix(const matrice & a){
3228     return ckmatrix(a,false);
3229   }
3230 
ckmatrix(const gen & a,bool allow_embedded_vect)3231   bool ckmatrix(const gen & a,bool allow_embedded_vect){
3232     if (a.type!=_VECT)
3233       return false;
3234     return ckmatrix(*a._VECTptr,allow_embedded_vect);
3235   }
3236 
ckmatrix(const gen & a)3237   bool ckmatrix(const gen & a){
3238     return ckmatrix(a,false);
3239   }
3240 
is_squarematrix(const matrice & a)3241   bool is_squarematrix(const matrice & a){
3242     if (!ckmatrix(a))
3243       return false;
3244     return a.size()==a.front()._VECTptr->size();
3245   }
3246 
is_squarematrix(const gen & a)3247   bool is_squarematrix(const gen & a){
3248     if (!ckmatrix(a))
3249       return false;
3250     return a._VECTptr->size()==a._VECTptr->front()._VECTptr->size();
3251   }
3252 
is_fully_numeric(const vecteur & v,int withfracint)3253   bool is_fully_numeric(const vecteur & v, int withfracint){
3254     const_iterateur it=v.begin(),itend=v.end();
3255     for (;it!=itend;++it){
3256       if (!is_fully_numeric(*it, withfracint))
3257 	return false;
3258     }
3259     return true;
3260   }
3261 
is_fully_numeric(const gen & a,int withfracint)3262   bool is_fully_numeric(const gen & a, int withfracint){
3263     switch (a.type){
3264     case _DOUBLE_: case _FLOAT_:
3265       return true;
3266     case _REAL:
3267       return true;
3268     case _CPLX:
3269       return is_fully_numeric(*a._CPLXptr, withfracint) && is_fully_numeric(*(a._CPLXptr+1), withfracint);
3270     case _VECT:
3271       return is_fully_numeric(*a._VECTptr, withfracint);
3272     case _IDNT:
3273       return strcmp(a._IDNTptr->id_name,"pi")==0;
3274     case _INT_:
3275     case _ZINT:
3276       return withfracint & num_mask_withint;
3277     case _FRAC:
3278       return (withfracint & num_mask_withfrac) && is_fully_numeric(a._FRACptr->num,withfracint) && is_fully_numeric(a._FRACptr->den,withfracint);
3279     default:
3280       return false;
3281     }
3282   }
3283 
mrows(const matrice & a)3284   int mrows(const matrice & a){
3285     return int(a.size());
3286   }
3287 
mcols(const matrice & a)3288   int mcols(const matrice & a){
3289     return int(a.begin()->_VECTptr->size());
3290   }
3291 
mdims(const matrice & m,int & r,int & c)3292   void mdims(const matrice &m,int & r,int & c){
3293     r=int(m.size());
3294     c=0;
3295     if (r){
3296       const gen & g=m.front();
3297       if (g.type==_VECT)
3298 	c=int(g._VECTptr->size());
3299     }
3300   }
3301 
mtran(const matrice & a,matrice & res,int ncolres)3302   void mtran(const matrice & a,matrice & res,int ncolres){
3303     if (!ckmatrix(a,true)){
3304       res=vecteur(1,vecteur(ncolres,gensizeerr("Unable to tranpose")));
3305       return;
3306     }
3307     vecteur::const_iterator it=a.begin(),itend=a.end();
3308     int n=int(itend-it); // nrows of a = ncols of res if ncolres was 0
3309     res.clear();
3310     if (!n)
3311       return;
3312     if (!ncolres)
3313       ncolres=n;
3314     int c=int(it->_VECTptr->size()); // ncols of a = rows of res
3315     res.reserve(c);
3316     // find begin of each row
3317 #if 1 // def VISUALC
3318     vecteur::const_iterator * itr=new vecteur::const_iterator[ncolres];
3319 #else
3320     vecteur::const_iterator itr[ncolres];
3321 #endif
3322     vecteur::const_iterator * itrend= itr+ncolres;
3323     vecteur::const_iterator * itrcur;
3324     int i;
3325     for (i=0;(i<n) && (it!=itend);++it,++i)
3326       itr[i]=it->_VECTptr->begin();
3327     for (;(i<ncolres) ;++i)
3328 #if 1 // def VISUALC
3329       * (int *) &itr[i]=0;
3330 #else
3331       itr[i]=(vecteur::const_iterator) NULL;
3332 #endif
3333     // make current row of res with currents elements of itr[]
3334     for (int j=0;j<c;++j){
3335       gen cr=new_ref_vecteur(0);
3336       vecteur & cur_row=*cr._VECTptr;
3337       cur_row.clear();
3338       cur_row.reserve(ncolres);
3339       for (itrcur=itr;itrcur!=itrend;++itrcur){
3340 	if
3341 #if 1 // def VISUALC
3342 	  (* (int *)itrcur!=0)
3343 #else
3344 	  (*itrcur!=(vecteur::const_iterator)NULL)
3345 #endif
3346 	    {
3347 	      cur_row.push_back(**itrcur);
3348 	      ++(*itrcur);
3349 	    }
3350 	else
3351 	  cur_row.push_back(0);
3352       }
3353       res.push_back(cr);
3354     }
3355 #if 1 // def VISUALC
3356     delete [] itr;
3357 #endif
3358   }
3359 
3360 #ifndef GIAC_HAS_STO_38
3361   #define GIAC_DETBLOCK // current bloc implementation for det is slower
3362 
negate_int(vector<vector<int>> & Nblock)3363   void negate_int(vector< vector<int> > & Nblock){
3364     int imax=Nblock.size();
3365     for (int i=0;i<imax;++i){
3366       vector<int>::iterator it=Nblock[i].begin(),itend=Nblock[i].end();
3367       for (;it!=itend;++it){
3368 	*it=-*it;
3369       }
3370     }
3371   }
3372 
tran_int(const vector<vector<int>> & a,vector<vector<int>> & res,int r1=0,int r2=0,int c1=0,int c2=0)3373   void tran_int(const vector< vector<int> > & a,vector< vector<int> > & res,int r1=0,int r2=0,int c1=0,int c2=0){
3374     vector< vector<int> >::const_iterator it=a.begin()+r1,itend=r2>r1?it+(r2-r1):a.end();
3375     int ncolres=itend-it; // nrows of a = ncols of res
3376     if (!ncolres){
3377       res.clear();
3378       return;
3379     }
3380     int c=c2>c1?c2-c1:it->size(); // ncols of a = rows of res
3381     res.resize(c);
3382     // find begin of each row
3383 #if defined( VISUALC ) || defined( BESTA_OS ) || defined(EMCC) || defined(__clang__)
3384     vector<int>::const_iterator * itr=(vector<int>::const_iterator *)alloca(ncolres*sizeof(vector<int>::const_iterator));
3385 #else
3386     vector<int>::const_iterator itr[ncolres];
3387 #endif
3388     vector<int>::const_iterator * itrend= itr+ncolres;
3389     vector<int>::const_iterator * itrcur;
3390     int i;
3391     for (i=0;it!=itend;++it,++i)
3392       itr[i]=it->begin()+c1;
3393     // make current row of res with currents elements of itr[]
3394     for (int j=0;j<c;++j){
3395       vector<int> & cur_row = res[j];
3396       cur_row.clear();
3397       cur_row.reserve(ncolres);
3398       for (itrcur=itr;itrcur!=itrend;++itrcur){
3399 	cur_row.push_back(**itrcur);
3400 	++(*itrcur);
3401       }
3402     }
3403   }
3404 #endif
3405 
mtran(const matrice & a)3406   matrice mtran(const matrice & a){
3407     matrice res;
3408     mtran(a,res);
3409     return res;
3410   }
3411 
_tran(const gen & a,GIAC_CONTEXT)3412   gen _tran(const gen & a,GIAC_CONTEXT){
3413     if ( a.type==_STRNG && a.subtype==-1) return  a;
3414     if (a.type==_MAP){
3415       gen_map res;
3416       gen g(res);
3417       sparse_trn(*a._MAPptr,*g._MAPptr,false,contextptr);
3418       return g;
3419     }
3420     vecteur v;
3421     if (!ckmatrix(a)){
3422       if (a.type==_VECT && !a._VECTptr->empty())
3423 	v=vecteur(1,a);
3424       else
3425 	return symb_tran(a);
3426     }
3427     else
3428       v=*a._VECTptr;
3429     matrice res;
3430     mtran(v,res);
3431     return gen(res,_MATRIX__VECT);
3432   }
3433   static const char _tran_s []="tran";
3434   static define_unary_function_eval (__tran,&_tran,_tran_s);
3435   define_unary_function_ptr5( at_tran ,alias_at_tran,&__tran,0,true);
3436 
matrice2std_matrix_double(const matrice & m,matrix_double & M,bool nomulti=false)3437   bool matrice2std_matrix_double(const matrice & m,matrix_double & M,bool nomulti=false){
3438     if (debug_infolevel)
3439       CERR << CLOCK()*1e-6 << " converting to double" << '\n';
3440     int n=int(m.size()),c;
3441     gen g;
3442     M.resize(n);
3443     for (int i=0;i<n;++i){
3444       const vecteur & mi=*m[i]._VECTptr;
3445       c=int(mi.size());
3446       std::vector<giac_double> & v =M[i];
3447       v.clear();
3448       v.reserve(c);
3449       const_iterateur it=mi.begin(),itend=mi.end();
3450       for (;it!=itend;++it){
3451 	if (it->type==_DOUBLE_){
3452 	  v.push_back(it->_DOUBLE_val);
3453 	  continue;
3454 	}
3455 	if (nomulti && it->type==_REAL)
3456 	  return false;
3457 	g=evalf(*it,1,context0);
3458 	if (g.type==_FLOAT_){
3459 	  v.push_back(get_double(g._FLOAT_val));
3460 	  continue;
3461 	}
3462 	if (g.type!=_DOUBLE_)
3463 	  return false;
3464 	v.push_back(g._DOUBLE_val);
3465       }
3466     }
3467     return true;
3468   }
3469 
dotvecteur(const std::vector<giac_double> & a,const std::vector<giac_double> & b)3470   giac_double dotvecteur(const std::vector<giac_double> & a,const std::vector<giac_double> & b){
3471     std::vector<giac_double>::const_iterator ita=a.begin(), itaend=a.end();
3472     std::vector<giac_double>::const_iterator itb=b.begin(), itbend=b.end();
3473     giac_double res=0;
3474     for (;(ita!=itaend)&&(itb!=itbend);++ita,++itb){
3475       res += (*ita)*(*itb);
3476     }
3477     return res;
3478   }
3479 
dotvecteur_double(const std::vector<giac_double> & a,const std::vector<giac_double> & b)3480   giac_double dotvecteur_double(const std::vector<giac_double> & a,const std::vector<giac_double> & b){
3481     return dotvecteur(a,b);
3482   }
3483 
3484   // H*w->v, assumes correct sizes (v already initialized)
multmatvecteur(const matrix_double & H,const std::vector<giac_double> & w,vector<giac_double> & v)3485   void multmatvecteur(const matrix_double & H,const std::vector<giac_double> & w,vector<giac_double> & v){
3486     unsigned n=unsigned(H.size());
3487     for (unsigned j=0;j<n;++j){
3488       vector<giac_double>::const_iterator it=H[j].begin(),itend=H[j].end(),jt=w.begin();
3489       giac_double res=0.0;
3490       for (;it!=itend;++jt,++it)
3491 	res += (*it)*(*jt);
3492       v[j]=res;
3493     }
3494   }
3495 
dotvecteur(const std::vector<complex_double> & a,const std::vector<complex_double> & b)3496   complex_double dotvecteur(const std::vector<complex_double> & a,const std::vector<complex_double> & b){
3497     std::vector<complex_double>::const_iterator ita=a.begin(), itaend=a.end();
3498     std::vector<complex_double>::const_iterator itb=b.begin(), itbend=b.end();
3499     complex_double res=0;
3500     for (;(ita!=itaend)&&(itb!=itbend);++ita,++itb){
3501       res += (*ita)*(*itb);
3502     }
3503     return res;
3504   }
3505 
smod_inplace(matrice & res,const gen & pi_p)3506   void smod_inplace(matrice & res,const gen & pi_p){
3507 #ifndef USE_GMP_REPLACEMENTS
3508     if (pi_p.type==_ZINT && ckmatrix(res)){
3509       mpz_t tmpz;
3510       mpz_init(tmpz);
3511       for (unsigned i=0;i<res.size();++i){
3512 	iterateur it=res[i]._VECTptr->begin(),itend=res[i]._VECTptr->end();
3513 	for (;it!=itend;++it){
3514 	  if (it->type!=_ZINT) // already smod-ed!
3515 	    continue;
3516 	  if (it->ref_count()!=1)
3517 	    *it=smod(*it,pi_p);
3518 	  if (mpz_cmp_ui(*it->_ZINTptr,0)>0){
3519 	    mpz_sub(tmpz,*it->_ZINTptr,*pi_p._ZINTptr);
3520 	    mpz_neg(tmpz,tmpz);
3521 	    if (mpz_cmp(*it->_ZINTptr,tmpz)>0){
3522 	      mpz_neg(tmpz,tmpz);
3523 	      mpz_swap(tmpz,*it->_ZINTptr);
3524 	    }
3525 	  }
3526 	  else {
3527 	    mpz_add(tmpz,*it->_ZINTptr,*pi_p._ZINTptr);
3528 	    mpz_neg(tmpz,tmpz);
3529 	    if (mpz_cmp(*it->_ZINTptr,tmpz)<0){
3530 	      mpz_neg(tmpz,tmpz);
3531 	      mpz_swap(tmpz,*it->_ZINTptr);
3532 	    }
3533 	  }
3534 	}
3535       }
3536       mpz_clear(tmpz);
3537     }
3538     else
3539 #endif // USE_GMP_REPLACEMENTS
3540       res=smod(res,pi_p);
3541   }
3542 
3543   void uncoerce(gen & g,unsigned prealloc) ;
uncoerce(vecteur & v,unsigned prealloc)3544   void uncoerce(vecteur & v,unsigned prealloc){
3545     iterateur it=v.begin(),itend=v.end();
3546     for (;it!=itend;++it)
3547       uncoerce(*it,prealloc);
3548   }
3549 
uncoerce(gen & g,unsigned prealloc)3550   void uncoerce(gen & g,unsigned prealloc) {
3551     if (g.type==_INT_){
3552       int tmp =g.val;
3553 #ifdef SMARTPTR64
3554       * ((ulonglong * ) &g) = ulonglong(new ref_mpz_t(prealloc)) << 16;
3555 #else
3556       g.__ZINTptr = new ref_mpz_t(prealloc);
3557 #endif
3558       g.type=_ZINT;
3559       mpz_set_si(*g._ZINTptr,tmp);
3560     }
3561     else {
3562       if (g.type==_VECT)
3563 	uncoerce(*g._VECTptr,prealloc);
3564     }
3565   }
3566 
3567 #if 1 // ndef GIAC_HAS_STO_38
3568   const int mmult_double_blocksize=45; // 2*45^2*sizeof(double)= a little less than 32K
3569   int mmult_int_blocksize=60; // 2*60^2*sizeof(int)= a little less than 32K
_blockmatrix_mult_size(const gen & args,GIAC_CONTEXT)3570   gen _blockmatrix_mult_size(const gen & args,GIAC_CONTEXT){
3571     if (args.type==_VECT && args._VECTptr->empty())
3572       return mmult_int_blocksize;
3573     if (args.type!=_INT_ || args.val<1)
3574       return gensizeerr(contextptr);
3575     return mmult_int_blocksize=args.val;
3576   }
3577   static const char _blockmatrix_mult_size_s []="blockmatrix_mult_size";
3578   static define_unary_function_eval (__blockmatrix_mult_size,&_blockmatrix_mult_size,_blockmatrix_mult_size_s);
3579   define_unary_function_ptr5( at_blockmatrix_mult_size ,alias_at_blockmatrix_mult_size,&__blockmatrix_mult_size,0,true);
3580 
3581 
3582   // multiply a[a0..a1,i0+delta..i1+delta] with bloc btran[b0..b1,i0..i1]
3583   // and adds or subtracts to c[a0+c0..a1+c0,b0+c1..b1+c1]
mmult_double_block(const matrix_double & A,int a0,int a1,const matrix_double & Btran,int b0,int b1,matrix_double & C,int c0,int c1,int i0,int i1,int delta=0,bool add=true)3584   void mmult_double_block(const matrix_double & A,int a0,int a1,const matrix_double & Btran,int b0,int b1,matrix_double & C,int c0,int c1,int i0,int i1,int delta=0,bool add=true){
3585     for (int a=a0;a<a1;++a){
3586       const vector<giac_double> & Aa=A[a];
3587       vector<giac_double> & Ca=C[a+c0];
3588       matrix_double::const_iterator it=Btran.begin()+b0,itend=Btran.begin()+b1-5;
3589       vector<giac_double>::iterator jt=Ca.begin()+b0+c1;
3590       for (;it<=itend;){
3591 	giac_double t0=0.0,t1=0.0,t2=0.0,t3=0.0,t4=0.0;
3592 	const giac_double * i=&Aa[i0+delta], *iend=i+(i1-i0);
3593 	const giac_double *j0=&(*it)[i0];++it;
3594 	const giac_double *j1=&(*it)[i0];++it;
3595 	const giac_double *j2=&(*it)[i0];++it;
3596 	const giac_double *j3=&(*it)[i0];++it;
3597 	const giac_double *j4=&(*it)[i0];++it;
3598 #if 1
3599 	for (;i<iend-4;j0+=5,j1+=5,j2+=5,j3+=5,j4+=5,i+=5){
3600 	  giac_double u = *i;
3601 	  t0 += u*(*j0);
3602 	  t1 += u*(*j1);
3603 	  t2 += u*(*j2);
3604 	  t3 += u*(*j3);
3605 	  t4 += u*(*j4);
3606 	  u = i[1];
3607 	  t0 += u*(j0[1]);
3608 	  t1 += u*(j1[1]);
3609 	  t2 += u*(j2[1]);
3610 	  t3 += u*(j3[1]);
3611 	  t4 += u*(j4[1]);
3612 	  u = i[2];
3613 	  t0 += u*(j0[2]);
3614 	  t1 += u*(j1[2]);
3615 	  t2 += u*(j2[2]);
3616 	  t3 += u*(j3[2]);
3617 	  t4 += u*(j4[2]);
3618 	  u = i[3];
3619 	  t0 += u*(j0[3]);
3620 	  t1 += u*(j1[3]);
3621 	  t2 += u*(j2[3]);
3622 	  t3 += u*(j3[3]);
3623 	  t4 += u*(j4[3]);
3624 	  u = i[4];
3625 	  t0 += u*(j0[4]);
3626 	  t1 += u*(j1[4]);
3627 	  t2 += u*(j2[4]);
3628 	  t3 += u*(j3[4]);
3629 	  t4 += u*(j4[4]);
3630 	}
3631 #endif
3632 	for (;i<iend;++j0,++j1,++j2,++j3,++j4,++i){
3633 	  giac_double u = *i;
3634 	  t0 += u*(*j0);
3635 	  t1 += u*(*j1);
3636 	  t2 += u*(*j2);
3637 	  t3 += u*(*j3);
3638 	  t4 += u*(*j4);
3639 	}
3640 	if (add){
3641 	  *jt+=t0; ++jt;
3642 	  *jt+=t1; ++jt;
3643 	  *jt+=t2; ++jt;
3644 	  *jt+=t3; ++jt;
3645 	  *jt+=t4; ++jt;
3646 	}
3647 	else {
3648 	  *jt-=t0; ++jt;
3649 	  *jt-=t1; ++jt;
3650 	  *jt-=t2; ++jt;
3651 	  *jt-=t3; ++jt;
3652 	  *jt-=t4; ++jt;
3653 	}
3654       }
3655       itend +=5;
3656       for (;it<itend;++it){
3657 	giac_double t=0.0;
3658 	const giac_double * i=&Aa[i0+delta], *iend=i+(i1-i0), *j=&(*it)[i0];
3659 	for (;i<iend;++j,++i)
3660 	  t += (*i)*(*j);
3661 	if (add){
3662 	  *jt+=t;
3663 	}
3664 	else {
3665 	  *jt-=t;
3666 	}
3667 	++jt;
3668       }
3669     }
3670   }
3671 
3672   // multiply bloc a[a0..a1,i0+delta..i1+delta] with bloc b[b0..b1,i0..i1]
3673   // and adds or subtracts to c[a0+c0..a1+c0,b0+c1..b1+c1]
3674   // computation is done modulo p (if p==0 no reduction)
3675   // assumes that a and b are reduced mod p and (i1-i0+1)*p^2 < 2^63
mmult_mod_block(const vector<vector<int>> & A,int a0,int a1,const vector<vector<int>> & Btran,int b0,int b1,vector<vector<int>> & C,int c0,int c1,int i0,int i1,int p,int delta=0,bool add=true)3676   static void mmult_mod_block(const vector< vector<int> > & A,int a0,int a1,const vector< vector<int> > & Btran,int b0,int b1,vector< vector<int> > & C,int c0,int c1,int i0,int i1,int p,int delta=0,bool add=true){
3677     for (int a=a0;a<a1;++a){
3678       const vector<int> & Aa=A[a];
3679       vector<int> & Ca=C[a+c0];
3680       vector< vector<int> >::const_iterator it=Btran.begin()+b0,itend=Btran.begin()+b1-6;
3681       vector<int>::iterator jt=Ca.begin()+b0+c1;
3682       for (;it<=itend;){
3683 	longlong t0=0,t1=0,t2=0,t3=0,t4=0,t5=0;
3684 	const int * i=&Aa[i0+delta], *iend=i+(i1-i0);
3685 	const int *j0=&(*it)[i0];++it;
3686 	const int *j1=&(*it)[i0];++it;
3687 	const int *j2=&(*it)[i0];++it;
3688 	const int *j3=&(*it)[i0];++it;
3689 	const int *j4=&(*it)[i0];++it;
3690 	const int *j5=&(*it)[i0];++it;
3691 	for (;i<iend-5;j0+=6,j1+=6,j2+=6,j3+=6,j4+=6,j5+=6,i+=6){
3692 	  longlong u = *i;
3693 	  t0 += u*(*j0);
3694 	  t1 += u*(*j1);
3695 	  t2 += u*(*j2);
3696 	  t3 += u*(*j3);
3697 	  t4 += u*(*j4);
3698 	  t5 += u*(*j5);
3699 	  u = i[1];
3700 	  t0 += u*(j0[1]);
3701 	  t1 += u*(j1[1]);
3702 	  t2 += u*(j2[1]);
3703 	  t3 += u*(j3[1]);
3704 	  t4 += u*(j4[1]);
3705 	  t5 += u*(j5[1]);
3706 	  u = i[2];
3707 	  t0 += u*(j0[2]);
3708 	  t1 += u*(j1[2]);
3709 	  t2 += u*(j2[2]);
3710 	  t3 += u*(j3[2]);
3711 	  t4 += u*(j4[2]);
3712 	  t5 += u*(j5[2]);
3713 	  u = i[3];
3714 	  t0 += u*(j0[3]);
3715 	  t1 += u*(j1[3]);
3716 	  t2 += u*(j2[3]);
3717 	  t3 += u*(j3[3]);
3718 	  t4 += u*(j4[3]);
3719 	  t5 += u*(j5[3]);
3720 	  u = i[4];
3721 	  t0 += u*(j0[4]);
3722 	  t1 += u*(j1[4]);
3723 	  t2 += u*(j2[4]);
3724 	  t3 += u*(j3[4]);
3725 	  t4 += u*(j4[4]);
3726 	  t5 += u*(j5[4]);
3727 	  u = i[5];
3728 	  t0 += u*(j0[5]);
3729 	  t1 += u*(j1[5]);
3730 	  t2 += u*(j2[5]);
3731 	  t3 += u*(j3[5]);
3732 	  t4 += u*(j4[5]);
3733 	  t5 += u*(j5[5]);
3734 	}
3735 	for (;i<iend;++j0,++j1,++j2,++j3,++j4,++j5,++i){
3736 	  longlong u = *i;
3737 	  t0 += u*(*j0);
3738 	  t1 += u*(*j1);
3739 	  t2 += u*(*j2);
3740 	  t3 += u*(*j3);
3741 	  t4 += u*(*j4);
3742 	  t5 += u*(*j5);
3743 	}
3744 	if (add){
3745 	  if (p){
3746 	    *jt = (*jt+t0)%p; ++jt;
3747 	    *jt = (*jt+t1)%p; ++jt;
3748 	    *jt = (*jt+t2)%p; ++jt;
3749 	    *jt = (*jt+t3)%p; ++jt;
3750 	    *jt = (*jt+t4)%p; ++jt;
3751 	    *jt = (*jt+t5)%p; ++jt;
3752 	  }
3753 	  else {
3754 	    *jt+=t0; ++jt;
3755 	    *jt+=t1; ++jt;
3756 	    *jt+=t2; ++jt;
3757 	    *jt+=t3; ++jt;
3758 	    *jt+=t4; ++jt;
3759 	    *jt+=t5; ++jt;
3760 	  }
3761 	}
3762 	else {
3763 	  if (p){
3764 	    *jt = (*jt-t0)%p; ++jt;
3765 	    *jt = (*jt-t1)%p; ++jt;
3766 	    *jt = (*jt-t2)%p; ++jt;
3767 	    *jt = (*jt-t3)%p; ++jt;
3768 	    *jt = (*jt-t4)%p; ++jt;
3769 	    *jt = (*jt-t5)%p; ++jt;
3770 	  }
3771 	  else {
3772 	    *jt-=t0; ++jt;
3773 	    *jt-=t1; ++jt;
3774 	    *jt-=t2; ++jt;
3775 	    *jt-=t3; ++jt;
3776 	    *jt-=t4; ++jt;
3777 	    *jt-=t5; ++jt;
3778 	  }
3779 	}
3780       }
3781       itend +=6;
3782       for (;it<itend;++it){
3783 	longlong t=0;
3784 	const int * i=&Aa[i0+delta], *iend=i+(i1-i0), *j=&(*it)[i0];
3785 	for (;i<iend;++j,++i)
3786 	  t += longlong(*i)*(*j);
3787 	if (add){
3788 	  if (p)
3789 	    *jt = (*jt+t)%p;
3790 	  else
3791 	    *jt += t;
3792 	}
3793 	else {
3794 	  if (p)
3795 	    *jt = (*jt-t)%p;
3796 	  else
3797 	    *jt -= t;
3798 	}
3799 	++jt;
3800       }
3801     }
3802   }
3803 
3804 
3805   // matrix multiplication mod p: C[c0..,c1..] += A[Ar0..Ar1,Ac0..Ac1]*B
3806   // B is represented by Btran, take B[Br0..Br1,Bc0] if Br1>Br0
3807   // or -= if add=false
in_mmult_mod(const vector<vector<int>> & A,const vector<vector<int>> & Btran,vector<vector<int>> & C,int c0,int c1,int p,int Ar0,int Ar1,int Ac0,int Ac1,bool add,int Br0=0,int Br1=0,int Bc0=0)3808   void in_mmult_mod(const vector< vector<int> > & A,const vector< vector<int> > & Btran,vector< vector<int> > & C,int c0,int c1,int p,int Ar0,int Ar1,int Ac0,int Ac1,bool add,int Br0=0,int Br1=0,int Bc0=0){
3809     int resrows=Ar1>Ar0?Ar1-Ar0:A.size(),rescols=Btran.size();
3810     if (Br1>Br0)
3811       rescols=Br1-Br0;
3812     else
3813       Br0=0;
3814     int n=Ac1>Ac0?Ac1-Ac0:A.front().size();
3815     for (int i=0;i<n;i+=mmult_int_blocksize){
3816       int iend=i+mmult_int_blocksize;
3817       if (iend>n)
3818 	iend=n;
3819       for (int k=0;k<resrows;k+=mmult_int_blocksize){
3820 	int kend=k+mmult_int_blocksize;
3821 	if (kend>resrows)
3822 	  kend=resrows;
3823 	for (int j=0;j<rescols;j+=mmult_int_blocksize){
3824 	  int jend=j+mmult_int_blocksize;
3825 	  if (jend>rescols)
3826 	    jend=rescols;
3827 	  mmult_mod_block(A,k+Ar0,kend+Ar0,Btran,Br0+j,Br0+jend,C,c0-Ar0,c1-Br0,Bc0+i,Bc0+iend,p,Ac0-Bc0,add);
3828 	}
3829       }
3830     }
3831   }
3832 
3833   struct thread_mmult_double_t {
3834     const matrix_double *a,*btran;
3835     matrix_double *c;
3836     int k,kend,n,rescols,Ar0,Br0,Ac0,Bc0,c0,c1;
3837     bool add;
3838   };
3839 
do_thread_mmult_double(void * ptr_)3840   void * do_thread_mmult_double(void * ptr_){
3841     thread_mmult_double_t * ptr=(thread_mmult_double_t *) ptr_;
3842     const matrix_double & a=*ptr->a;
3843     const matrix_double & btran=*ptr->btran;
3844     matrix_double & c=*ptr->c;
3845     int kstart=ptr->k,resrows=ptr->kend,n=ptr->n,rescols=ptr->rescols;
3846     int Ar0=ptr->Ar0,Br0=ptr->Br0,Ac0=ptr->Ac0,Bc0=ptr->Bc0,c0=ptr->c0,c1=ptr->c1;
3847     if (kstart>=resrows)
3848       return ptr;
3849     for (int k=kstart;k<resrows;k+=mmult_double_blocksize){
3850       int kend=k+mmult_double_blocksize;
3851       if (kend>resrows)
3852 	kend=resrows;
3853       for (int i=0;i<n;i+=mmult_double_blocksize){
3854 	int iend=i+mmult_double_blocksize;
3855 	if (iend>n)
3856 	  iend=n;
3857 	for (int j=0;j<rescols;j+=mmult_double_blocksize){
3858 	  int jend=j+mmult_double_blocksize;
3859 	  if (jend>rescols)
3860 	    jend=rescols;
3861 	  mmult_double_block(a,k+Ar0,kend+Ar0,btran,Br0+j,Br0+jend,c,c0-Ar0,c1-Br0,Bc0+i,Bc0+iend,Ac0-Bc0,ptr->add);
3862 	}
3863       }
3864     }
3865     return ptr;
3866   }
3867 
3868   // C +-= A[Ar0..Ar1-1,Ac0..Ac1-1]*B[Br0..Br1,Bc0], where B is given by Btran
in_mmult_double(const matrix_double & A,const matrix_double & Btran,matrix_double & C,int c0,int c1,int Ar0,int Ar1,int Ac0,int Ac1,bool add,int Br0=0,int Br1=0,int Bc0=0)3869   void in_mmult_double(const matrix_double & A,const matrix_double & Btran,matrix_double & C,int c0,int c1,int Ar0,int Ar1,int Ac0,int Ac1,bool add,int Br0=0,int Br1=0,int Bc0=0){
3870     int resrows=Ar1>Ar0?Ar1-Ar0:A.size(),rescols=Btran.size();
3871     if (Br1>Br0)
3872       rescols=Br1-Br0;
3873     else
3874       Br0=0;
3875     int n=Ac1>Ac0?Ac1-Ac0:A.front().size();
3876 #ifdef HAVE_LIBPTHREAD
3877     int nthreads=threads_allowed?threads:1;
3878     if (nthreads>1){
3879       pthread_t tab[nthreads];
3880       thread_mmult_double_t multdparam[nthreads];
3881       for (int j=0;j<nthreads;++j){
3882 	thread_mmult_double_t tmp={&A,&Btran,&C,0,0,n,rescols,Ar0,Br0,Ac0,Bc0,c0,c1,add};
3883 	multdparam[j]=tmp;
3884       }
3885       int kstep=int(std::ceil(resrows/double(nthreads))),k=0;
3886       for (int j=0;j<nthreads;++j){
3887 	multdparam[j].k=k;
3888 	k += kstep;
3889 	if (k>resrows)
3890 	  k=resrows;
3891 	multdparam[j].kend=k;
3892 	bool res=true;
3893 	if (j<nthreads-1)
3894 	  res=pthread_create(&tab[j],(pthread_attr_t *) NULL,do_thread_mmult_double,(void *) &multdparam[j]);
3895 	if (res)
3896 	  do_thread_mmult_double((void *)&multdparam[j]);
3897       }
3898       for (int j=0;j<nthreads;++j){
3899 	void * ptr=(void *)&nthreads; // non-zero initialisation
3900 	if (j<nthreads-1)
3901 	  pthread_join(tab[j],&ptr);
3902       }
3903       return ;
3904     } // end nthreads
3905 #endif // PTHREAD
3906 
3907     for (int i=0;i<n;i+=mmult_double_blocksize){
3908       int iend=i+mmult_double_blocksize;
3909       if (iend>n)
3910 	iend=n;
3911       for (int k=0;k<resrows;k+=mmult_double_blocksize){
3912 	int kend=k+mmult_double_blocksize;
3913 	if (kend>resrows)
3914 	  kend=resrows;
3915 	for (int j=0;j<rescols;j+=mmult_double_blocksize){
3916 	  int jend=j+mmult_double_blocksize;
3917 	  if (jend>rescols)
3918 	    jend=rescols;
3919 	  mmult_double_block(A,k+Ar0,kend+Ar0,Btran,Br0+j,Br0+jend,C,c0-Ar0,c1-Br0,Bc0+i,Bc0+iend,Ac0-Bc0,add);
3920 	}
3921       }
3922     }
3923   }
3924 
linfnorm(const vector<int> & v)3925   int linfnorm(const vector<int> & v){
3926     int n=0,cur;
3927     vector<int>::const_iterator it=v.begin(),itend=v.end();
3928     for (;it!=itend;++it){
3929       cur = *it;
3930       if (cur>=-n && cur<=n)
3931 	continue;
3932       if (cur<0)
3933 	n=-cur;
3934       else
3935 	n=cur;
3936     }
3937     return n;
3938   }
3939 
linfnorm(const vector<vector<int>> & A)3940   int linfnorm(const vector< vector<int> > & A){
3941     int n=0,a=A.size();
3942     for (int i=0;i<a;++i){
3943       n=giacmax(n,linfnorm(A[i]));
3944     }
3945     return n;
3946   }
3947 
3948   // matrix multiplication mod p: C = A*B
3949   // B is given by Btransposed, Ac1-Ac0 or ncols(A) should be = to nrows(B)=ncols(Btran)
mmult_mod(const vector<vector<int>> & A,const vector<vector<int>> & Btran,vector<vector<int>> & C,int p,int Ar0,int Ar1,int Ac0,int Ac1,int Brbeg,int Brend,int Bcbeg,int Crbeg,int Ccbeg,bool add)3950   void mmult_mod(const vector< vector<int> > & A,const vector< vector<int> > & Btran,vector< vector<int> > & C,int p,int Ar0,int Ar1,int Ac0,int Ac1,int Brbeg,int Brend,int Bcbeg,int Crbeg,int Ccbeg,bool add){
3951     int resrows,rescols;
3952     resrows=Ar1>Ar0?Ar1-Ar0:A.size();
3953     rescols=Brend>Brbeg?Brend-Brbeg:Btran.size();
3954     int Acols=Ac1>Ac0?Ac1-Ac0:(A.empty()?0:A.front().size());
3955     // we must resize otherwise mmult_mod calls in smallmodrref do not adjust matrix sizes correctly
3956     if (!add){
3957       // if (C.size()<resrows+Crbeg)
3958       C.resize(resrows+Crbeg);
3959       for (int i=0;i<resrows;++i){
3960 	// if (C[Crbeg+i].size()<Ccbeg+rescols)
3961 	C[Crbeg+i].resize(Ccbeg+rescols);
3962 	fill(C[Crbeg+i].begin()+Ccbeg,C[Crbeg+i].begin()+Ccbeg+rescols,0);
3963       }
3964     }
3965     // before enabling strassen_mod for p=0, check A and Btran inf norms!
3966     if (
3967 	//0 &&
3968 	resrows>strassen_limit && rescols >strassen_limit && Acols>strassen_limit && Crbeg==0 && Ccbeg==0){
3969       if (p!=0){
3970 	strassen_mod(false,true,A,Btran,C,p,Ar0,Ar1,Ac0,Ac1,Brbeg,Brend,Bcbeg);
3971 	return;
3972       }
3973       int ainf=linfnorm(A), binf=linfnorm(Btran);
3974       double nstep=std::ceil(std::log(giacmin(resrows,rescols)/double(strassen_limit))/std::log(2.0));
3975       if (ainf*nstep*binf*nstep<RAND_MAX){
3976 	strassen_mod(false,true,A,Btran,C,p,Ar0,Ar1,Ac0,Ac1,Brbeg,Brend,Bcbeg);
3977 	return;
3978       }
3979     }
3980     in_mmult_mod(A,Btran,C,Crbeg,Ccbeg,p,Ar0,Ar1,Ac0,Ac1,true,Brbeg,Brend,Bcbeg);
3981   }
3982 
3983   // Improve if &B==&C && defaults param
add_mod(bool add,const vector<vector<int>> & A,const vector<vector<int>> & B,vector<vector<int>> & C,int p,int Ar0=0,int Ar1=0,int Ac0=0,int Ac1=0,int Br0=0,int Bc0=0,int Cr0=0,int Cc0=0)3984   void add_mod(bool add,const vector< vector<int> > & A,const vector< vector<int> > & B,vector< vector<int> > & C,int p,int Ar0=0,int Ar1=0,int Ac0=0,int Ac1=0,int Br0=0,int Bc0=0,int Cr0=0,int Cc0=0){
3985     if (Ar1<=Ar0) Ar1=A.size()+Ar0;
3986     if (!A.empty() && Ac1<=Ac0) Ac1=A.front().size()+Ac0;
3987     vector< vector<int> >::const_iterator at=A.begin()+Ar0,atend=A.begin()+Ar1,bt=B.begin()+Br0;
3988     if (&B!=&C && int(C.size())<Cr0+Ar1-Ar0)
3989       C.resize(Cr0+Ar1-Ar0);
3990     vector< vector<int> >::iterator ct=C.begin()+Cr0;
3991     for (;at!=atend;++ct,++bt,++at){
3992       const vector<int> & ai=*at;
3993       const vector<int> & bi=*bt;
3994       vector<int> & ci=*ct;
3995       if (&B!=&C && int(ci.size())<Cc0+Ac1-Ac0)
3996 	ci.resize(Cc0+Ac1-Ac0);
3997       vector<int>::const_iterator it=ai.begin()+Ac0,itend=ai.begin()+Ac1,jt=bi.begin()+Bc0;
3998       vector<int>::iterator kt=ci.begin()+Cc0;
3999       if (p){
4000 	if (!add && &B==&C){
4001 	  for (;it!=itend;++kt,++it)
4002 	    *kt =(*kt+longlong(*it))%p;
4003 	  continue;
4004 	}
4005 	if (add){
4006 	  for (;it!=itend;++kt,++jt,++it)
4007 	    *kt =(*kt+longlong(*it)+*jt)%p;
4008 	}
4009 	else {
4010 	  for (;it!=itend;++kt,++jt,++it)
4011 	    *kt=(*it+*jt)%p;
4012 	}
4013       }
4014       else {
4015 	if (!add && &B==&C){
4016 	  for (;it!=itend;++kt,++it)
4017 	    *kt += *it;
4018 	  continue;
4019 	}
4020 	if (add){
4021 	  for (;it!=itend;++kt,++jt,++it)
4022 	    *kt += *it+*jt;
4023 	}
4024 	else {
4025 	  for (;it!=itend;++kt,++jt,++it)
4026 	    *kt=(*it+*jt);
4027 	}
4028       }
4029     }
4030   }
4031 
4032 
sub_mod(const vector<vector<int>> & A,const vector<vector<int>> & B,vector<vector<int>> & C,int p,int Ar0=0,int Ar1=0,int Ac0=0,int Ac1=0,int Br0=0,int Bc0=0,int Cr0=0,int Cc0=0)4033   void sub_mod(const vector< vector<int> > & A,const vector< vector<int> > & B,vector< vector<int> > & C,int p,int Ar0=0,int Ar1=0,int Ac0=0,int Ac1=0,int Br0=0,int Bc0=0,int Cr0=0,int Cc0=0){
4034     if (Ar1<=Ar0) Ar1=A.size()+Ar0;
4035     if (!A.empty() && Ac1<=Ac0) Ac1=A.front().size()+Ac0;
4036     vector< vector<int> >::const_iterator at=A.begin()+Ar0,atend=A.begin()+Ar1,bt=B.begin()+Br0;
4037     if (int(C.size())<Cr0+Ar1-Ar0)
4038       C.resize(Cr0+Ar1-Ar0);
4039     vector< vector<int> >::iterator ct=C.begin()+Cr0;
4040     for (;at!=atend;++ct,++bt,++at){
4041       const vector<int> & ai=*at;
4042       const vector<int> & bi=*bt;
4043       vector<int> & ci=*ct;
4044       if (int(ci.size())<Cc0+Ac1-Ac0)
4045 	ci.resize(Cc0+Ac1-Ac0);
4046       vector<int>::const_iterator it=ai.begin()+Ac0,itend=ai.begin()+Ac1,jt=bi.begin()+Bc0;
4047       vector<int>::iterator kt=ci.begin()+Cc0;
4048       if (p){
4049 	for (;it!=itend;++kt,++jt,++it)
4050 	  *kt=(*it-*jt)%p;
4051       }
4052       else {
4053 	for (;it!=itend;++kt,++jt,++it)
4054 	  *kt=(*it-*jt);
4055       }
4056     }
4057   }
4058 
mod(vector<int> & A,int p)4059   void mod(vector<int> & A,int p){
4060     unsigned a=A.size();
4061     for (unsigned i=0;i<a;++i)
4062       A[i] %= p;
4063   }
4064 
mod(vector<vector<int>> & A,int p)4065   void mod (vector< vector<int> > & A,int p){
4066     unsigned a=A.size();
4067     for (unsigned i=0;i<a;++i)
4068       mod(A[i], p);
4069   }
4070 
4071   // Strassen multiplication, work in progress
4072   // find A*B, B is given by Btran (transposed)
4073   // ncols(A)=nrows(B)=ncols(Btran)
4074   // answer size: nrows(A),ncols(B)=nrows(B)
4075   // reduce should be set to false by default, true means we can do + without reduction
4076   int strassen_limit=180;
_strassen_limit(const gen & g0,GIAC_CONTEXT)4077   gen _strassen_limit(const gen & g0,GIAC_CONTEXT){
4078     if ( g0.type==_STRNG && g0.subtype==-1) return  g0;
4079     gen g=evalf_double(g0,1,contextptr);
4080     if (g.type!=_DOUBLE_)
4081       return strassen_limit;
4082     return strassen_limit=int(g._DOUBLE_val);
4083   }
4084   static const char _strassen_limit_s []="strassen_limit";
4085   static define_unary_function_eval (__strassen_limit,&_strassen_limit,_strassen_limit_s);
4086   define_unary_function_ptr5( at_strassen_limit ,alias_at_strassen_limit,&__strassen_limit,0,true);
4087 
_lapack_limit(const gen & g0,GIAC_CONTEXT)4088   gen _lapack_limit(const gen & g0,GIAC_CONTEXT){
4089     if ( g0.type==_STRNG && g0.subtype==-1) return  g0;
4090     gen g=evalf_double(g0,1,contextptr);
4091     if (g.type!=_DOUBLE_)
4092       return CALL_LAPACK;
4093     return CALL_LAPACK=int(g._DOUBLE_val);
4094   }
4095   static const char _lapack_limit_s []="lapack_limit";
4096   static define_unary_function_eval (__lapack_limit,&_lapack_limit,_lapack_limit_s);
4097   define_unary_function_ptr5( at_lapack_limit ,alias_at_lapack_limit,&__lapack_limit,0,true);
4098 
alloc(vector<vector<int>> & v,int ac,int r)4099   static void alloc(vector<vector<int> > &v,int ac,int r){
4100     for (unsigned i=0;i<v.size();++i){
4101       v[i].reserve(r);
4102       v[i].resize(ac);
4103     }
4104   }
4105 
4106   // skip_reduce has not been tested yet. Needs to change inversion algorithm
4107   // and use half block instead of block of size 60
strassen_mod(bool skip_reduce,bool add,const vector<vector<int>> & A,const vector<vector<int>> & Btran,vector<vector<int>> & C,int p,int arbeg,int arend,int acbeg,int acend,int brbeg,int brend,int bcbeg)4108   void strassen_mod(bool skip_reduce,bool add,const vector< vector<int> > & A,const vector< vector<int> > & Btran,vector< vector<int> > & C,int p,int arbeg,int arend,int acbeg,int acend,int brbeg,int brend,int bcbeg){
4109     if (A.empty() || Btran.empty())
4110       return;
4111     int a,ac,b;
4112     if (arend>arbeg){
4113       a=arend-arbeg;
4114     }
4115     else {
4116       arend=a=A.size();
4117     }
4118     if (acend>acbeg){
4119       ac=acend-acbeg;
4120     }
4121     else {
4122       acend=ac=A.front().size();
4123     }
4124     if (brend>brbeg){
4125       b=brend-brbeg;
4126     }
4127     else {
4128       brend=b=Btran.size();
4129     }
4130     // ac should be equal to number of lines of B=bc
4131     if (a<=strassen_limit || ac<=strassen_limit ||
4132 	b<=strassen_limit){
4133       if (p && skip_reduce){
4134 	if (arbeg==0 && arend==int(A.size())){
4135 	  vector< vector<int> > A_(A);
4136 	  mod(A_,p);
4137 	  if (brbeg==0 && brend==int(Btran.size())){
4138 	    vector< vector<int> > Btran_(Btran);
4139 	    mod(Btran_,p);
4140 	    mmult_mod(A_,Btran_,C,p,arbeg,arend,acbeg,acend,brbeg,brend,bcbeg);
4141 	  }
4142 	  else
4143 	    mmult_mod(A_,Btran,C,p,arbeg,arend,acbeg,acend,brbeg,brend,bcbeg);
4144 	}
4145 	else {
4146 	  if (brbeg==0 && brend==int(Btran.size())){
4147 	    vector< vector<int> > Btran_(Btran);
4148 	    mod(Btran_,p);
4149 	    mmult_mod(A,Btran_,C,p,arbeg,arend,acbeg,acend,brbeg,brend,bcbeg);
4150 	  }
4151 	  else
4152 	    mmult_mod(A,Btran,C,p,arbeg,arend,acbeg,acend,brbeg,brend,bcbeg);
4153 	}
4154       }
4155       else
4156 	mmult_mod(A,Btran,C,p,arbeg,arend,acbeg,acend,brbeg,brend,bcbeg);
4157       return;
4158     }
4159     if (debug_infolevel>2)
4160       CERR << CLOCK()*1e-6 << "Strassen begin " << a << "," << ac << "," << b << '\n';
4161     // if all +/- in recursion fit in an int,
4162     // s and t computations can be done mod 0, provided we reduce mod p just above
4163     if (p && !skip_reduce){
4164       int n1=giacmin(a,giacmin(ac,b))/strassen_limit;
4165       if (2*(sizeinbase2(n1)-1)+sizeinbase2(p)<32)
4166 	skip_reduce=true;
4167     }
4168     if (ac%2 || a%2 || b%2){ // add missing 0 to get even dimensions
4169       vector< vector<int> > A_(a+1),Btran_(b+1);
4170       int ac_=ac;
4171       if (ac%2)
4172 	++ac_;
4173       for (int i=0;i<a;++i){
4174 	A_[i]=vector<int>(A[arbeg+i].begin()+acbeg,A[arbeg+i].begin()+acbeg+ac);
4175 	if (ac%2)
4176 	  A_[i].push_back(0);
4177       }
4178       for (int i=0;i<b;++i){
4179 	Btran_[i]=vector<int>(Btran[brbeg+i].begin()+bcbeg,Btran[brbeg+i].begin()+bcbeg+ac);
4180 	if (ac%2)
4181 	  Btran_[i].push_back(0);
4182       }
4183       if (a%2==0)
4184 	A_.pop_back();
4185       else
4186 	A_[a]=vector<int>(ac);
4187       if (b%2==0)
4188 	Btran_.pop_back();
4189       else
4190 	Btran_[b]=vector<int>(ac);
4191       strassen_mod(skip_reduce,add,A_,Btran_,C,p);
4192       if (a%2)
4193 	C.pop_back();
4194       if (b%2){
4195 	for (int i=0;i<a;++i)
4196 	  C[i].pop_back();
4197       }
4198       return;
4199     }
4200     if (int(C.size())!=a)
4201       C.resize(a);
4202     for (unsigned i=0;i<C.size();++i){
4203       if (int(C[i].size())!=b)
4204 	C[i].resize(b);
4205     }
4206     a/=2; ac/=2; b/=2;
4207     // s1=a21+a22
4208     int acb=giacmax(ac,b);
4209     vector< vector<int> > s1(a); alloc(s1,ac,acb);
4210     // vector< vector<int> > s1(a,vector<int>(ac));
4211     add_mod(false,A,A,s1,skip_reduce?0:p,arbeg+a,arbeg+2*a,acbeg,acbeg+ac,arbeg+a,acbeg+ac);
4212     // s2=s1-a11
4213     vector< vector<int> > s2(a); alloc(s2,ac,acb);
4214     // vector< vector<int> > s2(a,vector<int>(ac));
4215     sub_mod(s1,A,s2,skip_reduce?0:p,0,a,0,ac,arbeg,acbeg);
4216     // s3=a11-a21
4217     vector< vector<int> > s3(a); alloc(s3,ac,acb);
4218     // vector< vector<int> > s3(a,vector<int>(ac));
4219     sub_mod(A,A,s3,skip_reduce?0:p,arbeg,arbeg+a,acbeg,acbeg+ac,arbeg+a,acbeg);
4220     // s4=a12-s2
4221     vector< vector<int> > s4(a); alloc(s4,ac,acb);
4222     // vector< vector<int> > s4(a,vector<int>(ac));
4223     sub_mod(A,s2,s4,skip_reduce?0:p,arbeg,arbeg+a,acbeg+ac,acbeg+2*ac,0,0);
4224     // t1=b12-b11=btran21-btran11
4225     vector< vector<int> > t1; t1.reserve(giacmax(a,b)); t1.resize(b); alloc(t1,ac,acb);
4226     // vector< vector<int> > t1(b,vector<int>(ac));
4227     sub_mod(Btran,Btran,t1,skip_reduce?0:p,brbeg+b,brbeg+2*b,bcbeg,bcbeg+ac,brbeg,bcbeg);
4228     // t2=b22-t1=btran22-t1
4229     vector< vector<int> > t2(b,vector<int>(ac));
4230     sub_mod(Btran,t1,t2,skip_reduce?0:p,brbeg+b,brbeg+2*b,bcbeg+ac,bcbeg+2*ac,0,0);
4231     // t3=b22-b12=btran22-btran21
4232     vector< vector<int> > t3(b,vector<int>(ac));
4233     sub_mod(Btran,Btran,t3,skip_reduce?0:p,brbeg+b,brbeg+2*b,bcbeg+ac,bcbeg+2*ac,brbeg+b,bcbeg);
4234     // t4=b21-t2=btran12-t2
4235     vector< vector<int> > t4(b,vector<int>(ac));
4236     sub_mod(Btran,t2,t4,skip_reduce?0:p,brbeg,brbeg+b,bcbeg+ac,bcbeg+2*ac,0,0);
4237     if (debug_infolevel>2)
4238       CERR << CLOCK()*1e-6 << "Strassen recurse " << a << "," << ac << "," << b << '\n';
4239     // p3=s1*t1
4240     vector< vector<int> > p3(a,vector<int>(b));
4241     strassen_mod(skip_reduce,false,s1,t1,p3,p);
4242     // p4=s2*t2
4243     alloc(s1,b,b); vector< vector<int> > & p4=s1;
4244     // vector< vector<int> > p4(a,vector<int>(b));
4245     strassen_mod(skip_reduce,false,s2,t2,p4,p);
4246     // p5=s3*t3
4247     alloc(s2,b,b); vector< vector<int> > & p5=s2;
4248     // vector< vector<int> > p5(a,vector<int>(b));
4249     strassen_mod(skip_reduce,false,s3,t3,p5,p);
4250     // p6=s4*b22
4251     alloc(s3,b,b); vector< vector<int> > & p6=s3;
4252     // vector< vector<int> > p6(a,vector<int>(b));
4253     strassen_mod(skip_reduce,false,s4,Btran,p6,p,0,0,0,0,brbeg+b,brbeg+2*b,bcbeg+ac);
4254     // p7=a22*t4
4255     alloc(s4,b,b); vector< vector<int> > & p7=s4;
4256     // vector< vector<int> > p7(a,vector<int>(b));
4257     strassen_mod(skip_reduce,false,A,t4,p7,p,arbeg+a,arbeg+2*a,acbeg+ac,acbeg+2*ac,0,b,0);
4258     // p2=a12*b21=a12*btran12
4259     t1.resize(a); alloc(t1,b,b); vector< vector<int> > & p2=t1;
4260     // vector< vector<int> > p2(a,vector<int>(b));
4261     strassen_mod(skip_reduce,false,A,Btran,p2,p,arbeg,arbeg+a,acbeg+ac,acbeg+2*ac,brbeg,brbeg+b,bcbeg+ac);
4262     // p1=a11*b11
4263     t2.resize(a); alloc(t2,b,b); vector< vector<int> > & p1=t2;
4264     // vector< vector<int> > p1(a,vector<int>(b));
4265     strassen_mod(skip_reduce,false,A,Btran,p1,p,arbeg,arbeg+a,acbeg,acbeg+ac,brbeg,brbeg+b,bcbeg);
4266     t3.clear();
4267     t4.clear();
4268     if (debug_infolevel>2)
4269       CERR << CLOCK()*1e-6 << "Strassen final add " << a << "," << ac << "," << b << '\n';
4270     // c11=u1=p1+p2
4271     add_mod(add,p1,p2,C,p);
4272     // u2=p1+p4 stored in p4
4273     add_mod(false,p1,p4,p4,skip_reduce?0:p); // mod 0 since not used directly
4274     // u3=u2+p5 stored in p5
4275     add_mod(false,p4,p5,p5,skip_reduce?0:p);
4276     // c21=u4=u3+p7
4277     add_mod(add,p5,p7,C,p,0,0,0,0,0,0,a,0);
4278     // c22=u5=u3+p3
4279     add_mod(add,p5,p3,C,p,0,0,0,0,0,0,a,b);
4280     // u6=u2+p3 stored in p3
4281     add_mod(false,p4,p3,p3,skip_reduce?0:p);
4282     // c12=u7=u6+p6
4283     add_mod(add,p3,p6,C,p,0,0,0,0,0,0,0,b);
4284     p1.clear();
4285     p2.clear();
4286     p3.clear();
4287     p4.clear();
4288     p5.clear();
4289     p6.clear();
4290     p7.clear();
4291     if (debug_infolevel>2)
4292       CERR << CLOCK()*1e-6 << "Strassen end " << a << "," << ac << "," << b << '\n';
4293   }
4294 
4295   // Find x=a mod amod and =b mod bmod
4296   // We have x=a+A*amod=b+B*Bmod
4297   // hence A*amod-B*bmod=b-a
4298   // let u*amod+v*bmod=1
4299   // then A=(b-a)*u is a solution
4300   // hence x=a+(b-a)*u*amod mod (amod*bmod) is the solution
4301   // hence x=a+((b-a)*u mod bmod)*amod
ichinrem_inplace(matrice & a,const matrice & b,const gen & amod,int bmod,int fullreduction)4302   static bool ichinrem_inplace(matrice & a,const matrice &b,const gen & amod, int bmod,int fullreduction){
4303     gen U,v,d;
4304     egcd(amod,bmod,U,v,d);
4305     if (!is_one(d) || U.type!=_ZINT)
4306       return false;
4307     int u=mpz_get_si(*U._ZINTptr);
4308     longlong q;
4309     for (unsigned i=0;i<a.size();++i){
4310       gen * ai = &a[i]._VECTptr->front(), * aiend=ai+a[i]._VECTptr->size();
4311       gen * bi = &b[i]._VECTptr->front();
4312       if (fullreduction==2){
4313 	q=smod(bi[i]-ai[i],bmod).val;
4314 	q=smod(q*u,bmod); // (q*u) % bmod ;
4315 	ai[i] += int(q)*amod;
4316 	ai += a.size();
4317 	bi += a.size();
4318       }
4319       for (;ai!=aiend;++bi,++ai){
4320 	q=longlong(bi->val)-(ai->type==_INT_?ai->val:modulo(*ai->_ZINTptr,bmod));
4321 	q=smod(q*u,bmod); // (q*u) % bmod;
4322 	if (amod.type==_ZINT && ai->type==_ZINT){
4323 	  if (q>=0)
4324 	    mpz_addmul_ui(*ai->_ZINTptr,*amod._ZINTptr,int(q));
4325 	  else
4326 	    mpz_submul_ui(*ai->_ZINTptr,*amod._ZINTptr,-int(q));
4327 	}
4328 	else
4329 	  *ai += int(q)*amod;
4330       }
4331     }
4332     return true;
4333   }
4334 
4335   struct thread_mmult_mod_t {
4336     int p;
4337     const matrice *a,*btran;
4338     vector< vector<int> > *ai,*btrani,*ci;
4339   };
4340 
thread_mmult_mod(void * ptr_)4341   void * thread_mmult_mod(void * ptr_){
4342     thread_mmult_mod_t * ptr = (thread_mmult_mod_t *) ptr_;
4343     vecteur2vectvector_int(*ptr->a,ptr->p,*ptr->ai);
4344     vecteur2vectvector_int(*ptr->btran,ptr->p,*ptr->btrani);
4345     mmult_mod(*ptr->ai,*ptr->btrani,*ptr->ci,ptr->p);
4346     return ptr;
4347   }
4348 
4349   // a and btran must have integer coefficients
4350   // matrix multiplication using modular reconstruction
mmult_int(const matrice & a,const matrice & btran,matrice & c)4351   bool mmult_int(const matrice & a,const matrice & btran,matrice & c){
4352     if (debug_infolevel>2)
4353       CERR << CLOCK()*1e-6 << " begin mmult_int" << '\n';
4354     int n=a.front()._VECTptr->size();
4355     gen ainf=linfnorm(a,context0),binf=linfnorm(btran,context0),resinf=n*ainf*binf;
4356     if (debug_infolevel>2)
4357       CERR << CLOCK()*1e-6 << " after linfnorm" << '\n';
4358     double nsteps=nbits(resinf);
4359     int resrows=mrows(a);
4360     int rescols=mrows(btran);
4361     vector< vector<int> > ai(resrows,vector<int>(n));
4362     vector< vector<int> > btrani(rescols,vector<int>(n));
4363     vector< vector<int> > ci(resrows,vector<int>(rescols));
4364     // ||res||_inf <= ||a||_inf * ||b||_inf*n
4365     if (resinf.type==_INT_){
4366       vecteur2vectvector_int(a,0,ai); vecteur2vectvector_int(btran,0,btrani);
4367       mmult_mod(ai,btrani,ci,0);
4368       vectvector_int2vecteur(ci,c);
4369       if (debug_infolevel>2)
4370 	CERR << CLOCK()*1e-6 << " end mmult_int" << '\n';
4371       return true;
4372     }
4373     double a2=nbits(ainf),b2=nbits(binf);
4374     if ( (a2<128) || (b2<128) ||
4375 	 (a2/b2<1.4 && b2/a2<1.4) ) {
4376       // non modular multiplication, using mpz_addmul
4377       c=vecteur(resrows);
4378       for (int i=0;i<resrows;++i){
4379 	vecteur resi(rescols);
4380 	for (int j=0;j<rescols;++j){
4381 	  gen tmp;
4382 	  tmp.uncoerce();
4383 	  const_iterateur it=a[i]._VECTptr->begin(),itend=a[i]._VECTptr->end(),jt=btran[j]._VECTptr->begin();
4384 	  for (;it!=itend;++jt,++it){
4385 	    if (it->type==_INT_){
4386 	      if (jt->type==_INT_){
4387 		longlong x=longlong(it->val)*jt->val;
4388 #if defined x86_64 && !defined(WIN64) && !defined USE_GMP_REPLACEMENTS//fred
4389 		if (x>=0)
4390 		  mpz_add_ui(*tmp._ZINTptr,*tmp._ZINTptr,x);
4391 		else
4392 		  mpz_sub_ui(*tmp._ZINTptr,*tmp._ZINTptr,-x);
4393 #else
4394 		tmp += gen(x);
4395 		tmp.uncoerce();
4396 #endif
4397 	      }
4398 	      else {
4399 		if (it->val>0)
4400 		  mpz_addmul_ui(*tmp._ZINTptr,*jt->_ZINTptr,it->val);
4401 		else
4402 		  mpz_submul_ui(*tmp._ZINTptr,*jt->_ZINTptr,-it->val);
4403 	      }
4404 	    } // end it->type==_INT_
4405 	    else {
4406 	      if (jt->type==_INT_){
4407 		if (jt->val>0)
4408 		  mpz_addmul_ui(*tmp._ZINTptr,*it->_ZINTptr,jt->val);
4409 		else
4410 		  mpz_submul_ui(*tmp._ZINTptr,*it->_ZINTptr,-jt->val);
4411 	      }
4412 	      else
4413 		mpz_addmul(*tmp._ZINTptr,*it->_ZINTptr,*jt->_ZINTptr);
4414 	    }
4415 	  }
4416 	  if (mpz_sizeinbase(*tmp._ZINTptr,2)>=31)
4417 	    resi[j]=*tmp._ZINTptr;
4418 	  else
4419 	    resi[j]=int(mpz_get_si(*tmp._ZINTptr));
4420 	}
4421 	c[i]=resi;
4422       }
4423       if (debug_infolevel>2)
4424 	CERR << CLOCK()*1e-6 << " end mmult_int" << '\n';
4425       return true;
4426     }
4427     double p0=3037000500./std::sqrt(double(n))/5.; // so that p0^2*rows(a)<2^63
4428     nsteps = nsteps/std::log(p0)*std::log(2.0);
4429     gen p=int(p0),pi_p(1);
4430     matrice cmod;
4431     int i=0,j=0;
4432 #ifdef HAVE_LIBPTHREAD
4433     int nthreads=threads_allowed?threads:1;
4434     if (nthreads>1){
4435       pthread_t tab[nthreads-1];
4436 #ifdef __clang__
4437       vector< vector<int> > *tabai = (vector< vector<int> > *)alloca(nthreads*sizeof(vector< vector<int> >)),
4438 	*tabbtrani = (vector< vector<int> > *)alloca(nthreads*sizeof(vector< vector<int> >)),
4439 	*tabci = (vector< vector<int> > *)alloca(nthreads*sizeof(vector< vector<int> >));
4440 #else
4441       vector< vector<int> > tabai[nthreads],tabbtrani[nthreads],tabci[nthreads];
4442 #endif
4443       thread_mmult_mod_t multmodparam[nthreads];
4444       for (int k=0;k<nthreads;++k){
4445 	thread_mmult_mod_t tmp={0,&a,&btran,&tabai[k],&tabbtrani[k],&tabci[k]};
4446 	multmodparam[k]=tmp;
4447       }
4448       for (;i<=(nsteps/nthreads)*nthreads;){
4449 	for (j=0;j<nthreads;++j){
4450 	  p=nextprime(p+1);
4451 	  multmodparam[j].p=p.val;
4452 	  bool res=true;
4453 	  if (j<nthreads-1)
4454 	    res=pthread_create(&tab[j],(pthread_attr_t *) NULL,thread_mmult_mod,(void *) &multmodparam[j]);
4455 	  if (res)
4456 	    thread_mmult_mod((void *)&multmodparam[j]);
4457 	}
4458 	for (j=0;j<nthreads;++j){
4459 	  void * ptr=(void *)&nthreads; // non-zero initialisation
4460 	  if (j<nthreads-1)
4461 	    pthread_join(tab[j],&ptr);
4462 	  if (ptr){
4463 	    if (i==0)
4464 	      vectvector_int2vecteur(*multmodparam[j].ci,c);
4465 	    else {
4466 	      vectvector_int2vecteur(*multmodparam[j].ci,cmod);
4467 	      ichinrem_inplace(c,cmod,pi_p,multmodparam[j].p,0 /* fullreduction */);
4468 	    }
4469 	    ++i;
4470 	    pi_p=multmodparam[j].p*pi_p;
4471 	  } // end if(ptr)
4472 	} // end loop on j
4473       } // end loop on i
4474     } // end if nthreads>1
4475 #endif
4476     // finish
4477     for (;i<=nsteps;++i){
4478       p=nextprime(p+1);
4479       vecteur2vectvector_int(a,p.val,ai); vecteur2vectvector_int(btran,p.val,btrani);
4480       mmult_mod(ai,btrani,ci,p.val);
4481       if (i==0)
4482 	vectvector_int2vecteur(ci,c);
4483       else {
4484 	vectvector_int2vecteur(ci,cmod);
4485 	ichinrem_inplace(c,cmod,pi_p,p.val,0 /* fullreduction */);
4486       }
4487       pi_p=p*pi_p;
4488     }
4489     smod_inplace(c,pi_p);
4490     return true;
4491   }
4492 
4493 
4494   // ad*b->c where b is given by it's tranposed btrand
mmult_double(const matrix_double & ad,const matrix_double & btrand,matrix_double & c)4495   void mmult_double(const matrix_double & ad,const matrix_double & btrand,matrix_double & c){
4496     int n=ad.front().size();
4497     int resrows=ad.size();
4498     int rescols=btrand.size();
4499     if (c.empty())
4500       c=matrix_double(resrows,vector<giac_double>(rescols));
4501     else {
4502       c.resize(resrows);
4503       for (int i=0;i<resrows;++i)
4504 	c[i].resize(rescols);
4505     }
4506 #ifdef HAVE_LIBPTHREAD
4507     int nthreads=threads_allowed?threads:1;
4508     if (nthreads>1){
4509       pthread_t tab[nthreads-1];
4510       thread_mmult_double_t multdparam[nthreads];
4511       for (int j=0;j<nthreads;++j){
4512 	thread_mmult_double_t tmp={&ad,&btrand,&c,0,0,n,rescols,0,0,0,0,0,0,true};
4513 	multdparam[j]=tmp;
4514       }
4515       int kstep=int(std::ceil(resrows/double(nthreads))),k=0;
4516       for (int j=0;j<nthreads;++j){
4517 	multdparam[j].k=k;
4518 	k += kstep;
4519 	if (k>resrows)
4520 	  k=resrows;
4521 	multdparam[j].kend=k;
4522 	bool res=true;
4523 	if (j<nthreads-1)
4524 	  res=pthread_create(&tab[j],(pthread_attr_t *) NULL,do_thread_mmult_double,(void *) &multdparam[j]);
4525 	if (res)
4526 	  do_thread_mmult_double((void *)&multdparam[j]);
4527       }
4528       for (int j=0;j<nthreads;++j){
4529 	void * ptr=(void *)&nthreads; // non-zero initialisation
4530 	if (j<nthreads-1)
4531 	  pthread_join(tab[j],&ptr);
4532       }
4533       return ;
4534     } // end nthreads
4535 #endif // PTHREAD
4536     for (int i=0;i<n;i+=mmult_double_blocksize){
4537       int iend=i+mmult_double_blocksize;
4538       if (iend>n)
4539 	iend=n;
4540       for (int k=0;k<resrows;k+=mmult_double_blocksize){
4541 	int kend=k+mmult_double_blocksize;
4542 	if (kend>resrows)
4543 	  kend=resrows;
4544 	for (int j=0;j<rescols;j+=mmult_double_blocksize){
4545 	  int jend=j+mmult_double_blocksize;
4546 	  if (jend>rescols)
4547 	    jend=rescols;
4548 	  mmult_double_block(ad,k,kend,btrand,j,jend,c,0,0,i,iend);
4549 	}
4550       }
4551     }
4552   }
4553 
4554 #endif // GIAC_HAS_STO_38
4555 
mmult_double(const matrice & a,const matrice & btran,matrice & res)4556   bool mmult_double(const matrice & a,const matrice & btran,matrice & res){
4557     matrix_double ad,btrand;
4558     if (matrice2std_matrix_double(a,ad,true) && matrice2std_matrix_double(btran,btrand,true)){
4559       int resrows=mrows(a);
4560       int rescols=mrows(btran);
4561 #if 1 // ndef GIAC_HAS_STO_38
4562       int n;
4563       if (!ad.empty() && resrows>=2*mmult_double_blocksize && rescols>=2*mmult_double_blocksize && (n=ad.front().size())>=mmult_double_blocksize){
4564 	if (n>=CALL_LAPACK && resrows>=CALL_LAPACK && rescols>=CALL_LAPACK){
4565 #ifdef HAVE_LIBLAPACK
4566 	  /*
4567 	   *       DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
4568 	   *
4569 	   *       .. Scalar Arguments ..
4570 	   *       DOUBLE PRECISION ALPHA,BETA
4571 	   *       INTEGER K,LDA,LDB,LDC,M,N
4572 	   *       CHARACTER TRANSA,TRANSB
4573 	   *       ..
4574 	   *       .. Array Arguments ..
4575 	   *       DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
4576 	   *       ..
4577 	   *> DGEMM  performs one of the matrix-matrix operations
4578 	   *>
4579 	   *>    C := alpha*op( A )*op( B ) + beta*C,
4580 	   *>
4581 	   *> where  op( X ) is one of
4582 	   *>
4583 	   *>    op( X ) = X   or   op( X ) = X**T,
4584 	   *>
4585 	   *> alpha and beta are scalars, and A, B and C are matrices, with op( A )
4586 	   *> an m by k matrix,  op( B )  a  k by n matrix and  C an m by n matrix.
4587 	   *  Arguments:
4588 	   *  ==========
4589 	   *>          TRANSA is CHARACTER*1 'T' for transpose, 'N' for normal
4590 	   *>          TRANSB is CHARACTER*1
4591 	   *>          M is INTEGER
4592 	   *>           On entry,  M  specifies  the number  of rows  of the  matrix
4593 	   *>           op( A )  and of the  matrix  C.  M  must  be at least  zero.
4594 	   *>          N is INTEGER
4595 	   *>           On entry,  N  specifies the number  of columns of the matrix
4596 	   *>           op( B ) and the number of columns of the matrix C. N must be
4597 	   *>           at least zero.
4598 	   *>          K is INTEGER
4599 	   *>           On entry,  K  specifies  the number of columns of the matrix
4600 	   *>           op( A ) and the number of rows of the matrix op( B ). K must
4601 	   *>           be at least  zero.
4602 	   *>          ALPHA is DOUBLE PRECISION.
4603 	   *>           On entry, ALPHA specifies the scalar alpha.
4604 	   *>          A is DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
4605 	   *>           k  when  TRANSA = 'N' or 'n',  and is  m  otherwise.
4606 	   *>           Before entry with  TRANSA = 'N' or 'n',  the leading  m by k
4607 	   *>           part of the array  A  must contain the matrix  A,  otherwise
4608 	   *>           the leading  k by m  part of the array  A  must contain  the
4609 	   *>           matrix A.
4610 	   *>          LDA is INTEGER
4611 	   *>           On entry, LDA specifies the first dimension of A as declared
4612 	   *>           in the calling (sub) program. When  TRANSA = 'N' or 'n' then
4613 	   *>           LDA must be at least  max( 1, m ), otherwise  LDA must be at
4614 	   *>          B is DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
4615 	   *>           n  when  TRANSB = 'N' or 'n',  and is  k  otherwise.
4616 	   *>           Before entry with  TRANSB = 'N' or 'n',  the leading  k by n
4617 	   *>           part of the array  B  must contain the matrix  B,  otherwise
4618 	   *>           the leading  n by k  part of the array  B  must contain  the
4619 	   *>           matrix B.
4620 	   *>          LDB is INTEGER
4621 	   *>           On entry, LDB specifies the first dimension of B as declared
4622 	   *>           in the calling (sub) program. When  TRANSB = 'N' or 'n' then
4623 	   *>           LDB must be at least  max( 1, k ), otherwise  LDB must be at
4624 	   *>           least  max( 1, n ).
4625 	   *>          BETA is DOUBLE PRECISION.
4626 	   *>           On entry,  BETA  specifies the scalar  beta.  When  BETA  is
4627 	   *>           supplied as zero then C need not be set on input.
4628 	   *>          C is DOUBLE PRECISION array of DIMENSION ( LDC, n ).
4629 	   *>           Before entry, the leading  m by n  part of the array  C must
4630 	   *>           contain the matrix  C,  except when  beta  is zero, in which
4631 	   *>           case C need not be set on entry.
4632 	   *>           On exit, the array  C  is overwritten by the  m by n  matrix
4633 	   *>           ( alpha*op( A )*op( B ) + beta*C ).
4634 	   *>          LDC is INTEGER
4635 	   *>           On entry, LDC specifies the first dimension of C as declared
4636 	   *>           in  the  calling  (sub)  program.   LDC  must  be  at  least
4637 	   *>           max( 1, m ).
4638 	   */
4639 	  integer M(resrows),N(rescols),K(n);
4640 	  double * A = new double[resrows*n];
4641 	  double * B = new double[rescols*n];
4642 	  double * C = new double[resrows*rescols];
4643 	  matrice2lapack(a,A,context0);
4644 	  matrice2lapack(btran,B,context0);
4645 	  double alpha=1.0;
4646 	  double beta=0.0;
4647 #ifdef POCKETCAS
4648 	  cblas_dgemm(CblasColMajor, CblasNoTrans, CblasTrans, M, N, K, alpha, A, /*LDA*/ M, B, /*LDB*/ N, beta, C, /*LDC*/ M);
4649 #else
4650 	  dgemm_((char*)"N",(char*)"T",&M,&N,&K,&alpha,A,/*LDA*/&M,B,/*LDB*/&N,&beta,C,/*LDC*/&M);
4651 #endif
4652 	  lapack2matrice(C,resrows,rescols,res);
4653 	  delete [] A; delete [] B; delete [] C;
4654 	  return true;
4655 #endif // LAPACK
4656 	} // if n>LAPACK_CALL ...
4657 	matrix_double c(resrows,vector<giac_double>(rescols));
4658 	mmult_double(ad,btrand,c);
4659 	std_matrix<gen> cg;
4660 	std_matrix_giac_double2std_matrix_gen(c,cg);
4661 	std_matrix_gen2matrice_destroy(cg,res);
4662 	return true;
4663       }
4664 #endif // GIAC_HAS_STO_38
4665       matrix_double::const_iterator ita=ad.begin(),itaend=ad.end();
4666       matrix_double::const_iterator itbbeg=btrand.begin(),itb,itbend=btrand.end();
4667       res.clear();
4668       res.reserve(resrows);
4669       for (;ita!=itaend;++ita){
4670 	res.push_back(new_ref_vecteur(rescols));
4671 	gen * cur = &res.back()._VECTptr->front();
4672 	for (itb=itbbeg;itb!=itbend;++cur,++itb){
4673 	  giac_double res=0.0;
4674 	  const giac_double * i=&ita->front(),*iend=i+ita->size(),*j=&itb->front();
4675 	  for (;i!=iend;++j,++i){
4676 	    res += (*i)*(*j);
4677 	  }
4678 	  *cur=double(res);
4679 	  // *cur=double(dotvecteur(*ita,*itb));
4680 	}
4681       }
4682       return true;
4683     }
4684     matrix_complex_double zad,zbtrand;
4685     if (!matrice2std_matrix_complex_double(a,zad,true) || !matrice2std_matrix_complex_double(btran,zbtrand,true))
4686       return false;
4687     matrix_complex_double::const_iterator ita=zad.begin(),itaend=zad.end();
4688     matrix_complex_double::const_iterator itbbeg=zbtrand.begin(),itb,itbend=zbtrand.end();
4689     int resrows=mrows(a);
4690     int rescols=mrows(btran);
4691     res.clear();
4692     res.reserve(resrows);
4693     for (;ita!=itaend;++ita){
4694       res.push_back(new_ref_vecteur(rescols));
4695       vecteur & cur_row=*res.back()._VECTptr;
4696       for (itb=itbbeg;itb!=itbend;++itb)
4697 	cur_row[itb-itbbeg]=dotvecteur(*ita,*itb);
4698     }
4699     return true;
4700   }
4701 
fracvect(const vecteur & v)4702   bool fracvect(const vecteur & v){
4703     for (unsigned i=0;i<v.size();++i){
4704       if (!is_cinteger(v[i]) && v[i].type!=_FRAC)
4705 	return false;
4706     }
4707     return true;
4708   }
4709 
matrix_density(const matrice & a)4710   double matrix_density(const matrice & a){
4711     int z=0,c=0;
4712     const_iterateur it=a.begin(),itend=a.end();
4713     for (;it!=itend;++it){
4714       if (it->type!=_VECT){
4715 	if (is_zero(*it)) ++z;
4716 	++c;
4717 	continue;
4718       }
4719       const_iterateur jt=it->_VECTptr->begin(),jtend=it->_VECTptr->end();
4720       for (;jt!=jtend;++jt){
4721 	if (is_zero(*jt)) ++z;
4722 	++c;
4723       }
4724     }
4725     return (c-z)/double(c);
4726   }
4727 
mmult(const matrice & a_,const matrice & b,matrice & res)4728   void mmult(const matrice & a_,const matrice & b,matrice & res){
4729     matrice btran;
4730     if (debug_infolevel>2)
4731       CERR << CLOCK()*1e-6 << " mmult begin" << '\n';
4732     mtran(b,btran);
4733     mmult_atranb(a_,btran,res);
4734   }
mmult_atranb(const matrice & a_,const matrice & btran,matrice & res)4735   void mmult_atranb(const matrice & a_,const matrice & btran,matrice & res){
4736     // now make the (dotvecteur) product of row i of a with rows of btran to get
4737     // row i of res
4738 #ifndef GIAC_HAS_STO_38
4739     if (is_integer_matrice(a_) && is_integer_matrice(btran) && mmult_int(a_,btran,res))
4740       return;
4741     vector< vector<int> > A,Btran;
4742     gen x;
4743     int Atype=gf_char2_matrice2vectorvectorint(a_,A,x);
4744     int Btype=gf_char2_matrice2vectorvectorint(btran,Btran,x);
4745     if ( (Atype>0 && Btype>0 && Atype==Btype) ||
4746 	 (Atype>0 && Btype==0) ||
4747 	 (Btype>0 && Atype==0) ){
4748       int M=Atype?Atype:Btype;
4749       vector< vector<int> > C;
4750       gf_char2_mmult_atranb(A,Btran,C,M);
4751       gf_char2_vectorvectorint2mat(C,res,M,x);
4752       return ;
4753     }
4754     int p=0;
4755     if (is_mod_matrice(a_,A,p) && is_mod_matrice(btran,Btran,p)){
4756       vector< vector<int> > C;
4757       mmult_mod(A,Btran,C,p);
4758       vectvector_int2vecteur(C,res);
4759       res=*makemod(res,p)._VECTptr;
4760       return;
4761     }
4762     int at=a_.front()[0].type,bt=btran.front()[0].type;
4763     // if ( ( (at==_POLY && bt==_POLY) || (at==_VECT && bt==_VECT) ) && mmult_interp(a_,btran,res) ) return ;
4764 #endif
4765 #if 1 // ndef BCD // creating a copy of the matrices take too much memory and slows down on Aspen
4766     if ( (has_num_coeff(a_) || has_num_coeff(btran)) && mmult_double(a_,btran,res))
4767       return;
4768 #endif
4769     if (debug_infolevel>2)
4770       CERR << CLOCK()*1e-6 << " find lcm deno" << '\n';
4771     matrice a(a_);
4772     vecteur adeno(a.size(),1),bdeno(btran.size(),1);
4773     for (unsigned i=0;i<a.size();++i){
4774       a[i]=*a[i]._VECTptr;
4775       if (fracvect(*a[i]._VECTptr))
4776 	lcmdeno(*a[i]._VECTptr,adeno[i],context0);
4777     }
4778     for (unsigned i=0;i<btran.size();++i){
4779       if (fracvect(*btran[i]._VECTptr))
4780 	lcmdeno(*btran[i]._VECTptr,bdeno[i],context0);
4781     }
4782     if (debug_infolevel>2)
4783       CERR << CLOCK()*1e-6 << " lcm deno done" << '\n';
4784 #if !defined(GIAC_HAS_STO_38) && !defined(EMCC)
4785     if (
4786 	//a.front()._VECTptr->size()>=7 &&
4787 	is_integer_matrice(a) && is_integer_matrice(btran) && mmult_int(a,btran,res)
4788 	)
4789       ;
4790     else
4791 #endif
4792       {
4793 	vecteur::const_iterator ita=a.begin(),itaend=a.end();
4794 	vecteur::const_iterator itbbeg=btran.begin(),itb,itbend=btran.end();
4795 	int resrows=mrows(a);
4796 	int rescols=mrows(btran);
4797 	res.clear();
4798 	res.reserve(resrows);
4799 	double a_density=matrix_density(a),b_density=matrix_density(btran);
4800 	if (a_density*b_density>0.1){
4801 	  /* code for dense matrices */
4802 	   vecteur cur_row;
4803 	   for (;ita!=itaend;++ita){
4804 	     cur_row.clear();
4805 	     cur_row.reserve(rescols);
4806 	     for (itb=itbbeg;itb!=itbend;++itb)
4807 	       cur_row.push_back(dotvecteur(*(ita->_VECTptr),*(itb->_VECTptr)));
4808 	     res.push_back(cur_row);
4809 	   }
4810 	} // end dense matrices
4811 	else {
4812 	  int s=int(btran.size());
4813 	  gen tmp;
4814 	  const_iterateur it,itend;
4815 	  vector<const_iterateur> itbb(s);
4816 	  iterateur itc;
4817 	  for (;ita!=itaend;++ita){
4818 	    vecteur c(rescols,zero);
4819 	    it=ita->_VECTptr->begin();
4820 	    itend=ita->_VECTptr->end();
4821 	    itb=itbbeg;
4822 	    for (int i=0;i<s;++i,++itb)
4823 	      itbb[i]=itb->_VECTptr->begin();
4824 	    for (;it!=itend;++it){
4825 	      const gen & acur=*it;
4826 	      if (is_zero(acur,context0)){
4827 		int p=1;
4828 		++it;
4829 		for (; (it!=itend) && is_zero(*it,context0);++it,++p){
4830 		}
4831 		if (it==itend)
4832 		  break;
4833 		else
4834 		  --it;
4835 		for (int i=0;i<s;++i)
4836 		  itbb[i]+=p;
4837 	      }
4838 	      else {
4839 		itc=c.begin();
4840 		gen tmp;
4841 		for (int i=0;i<s;++itc,++(itbb[i]),++i){
4842 		  type_operator_times(acur, *(itbb[i]),tmp);
4843 		  *itc += tmp;
4844 		}
4845 	      }
4846 	    }
4847 	    res.push_back(c);
4848 	  }
4849 	} // end sparse matrices
4850       } // end #endif else
4851     for (unsigned i=0;i<adeno.size();++i){
4852       vecteur & v=*res[i]._VECTptr;
4853       for (unsigned j=0;j<bdeno.size();++j){
4854 	v[j] = v[j]/(adeno[i]*bdeno[j]);
4855       }
4856     }
4857     // if (!res1.empty() && res1!=res) CERR << "err" << '\n';
4858   }
4859 
mmult(const matrice & a,const matrice & b)4860   matrice mmult(const matrice & a,const matrice & b){
4861     matrice res;
4862     mmult(a,b,res);
4863     return res;
4864   }
4865 
mmultck(const matrice & a,const matrice & b,matrice & res)4866   bool mmultck(const matrice & a, const matrice & b,matrice & res){
4867     if (mcols(a)!=mrows(b))
4868       return false;
4869     mmult(a,b,res);
4870     return true;
4871   }
4872 
mmultck(const matrice & a,const matrice & b)4873   matrice mmultck(const matrice & a, const matrice & b){
4874     matrice res;
4875     if (!mmultck(a,b,res))
4876       return vecteur(1,vecteur(1,gendimerr(gettext("mmultck"))));
4877     return res;
4878   }
4879 
mtrace(const matrice & a)4880   gen mtrace(const matrice & a){
4881     gen res(0);
4882     vecteur::const_iterator it=a.begin(),itend=a.end();
4883     for (int i=0;it!=itend;++it,++i)
4884       res = res + (*it)[i];
4885     return res;
4886   }
4887 
ckmtrace(const gen & a,GIAC_CONTEXT)4888   gen ckmtrace(const gen & a,GIAC_CONTEXT){
4889     if (!is_squarematrix(a))
4890       return symbolic(at_trace,a); // gendimerr(contextptr); required to keep trace for geometry
4891     return mtrace(*a._VECTptr);
4892   }
4893   static const char _trace_s []="trace";
4894   static define_unary_function_eval (__trace,&ckmtrace,_trace_s);
4895   define_unary_function_ptr5( at_trace ,alias_at_trace,&__trace,0,true);
4896 
common_deno(const vecteur & v)4897   gen common_deno(const vecteur & v){
4898     const_iterateur it=v.begin(),itend=v.end();
4899     gen lcm_deno(1);
4900     for (;it!=itend;++it){
4901       if (it->type==_FRAC)
4902 	lcm_deno=rdiv(lcm_deno,gcd(lcm_deno,it->_FRACptr->den),context0)*(it->_FRACptr->den);
4903     }
4904     return lcm_deno;
4905   }
4906 
common_num(const vecteur & v)4907   static gen common_num(const vecteur & v){
4908     const_iterateur it=v.begin(),itend=v.end();
4909     gen gcd_num(0);
4910     for (;it!=itend;++it){
4911       if (it->type!=_FRAC)
4912 	gcd_num=gcd(gcd_num,*it);
4913     }
4914     return gcd_num;
4915   }
4916 
trim(const gen & a,const gen & b,double eps)4917   static inline gen trim(const gen & a,const gen & b,double eps){
4918     if (eps && a.type==_DOUBLE_ && b.type==_DOUBLE_ &&
4919 	fabs(a._DOUBLE_val)<eps*fabs(b._DOUBLE_val))
4920       return 0;
4921     else
4922       return a;
4923   }
4924 
exact_div(const gen & a,const gen & b)4925   gen exact_div(const gen & a,const gen & b){
4926     if (a.type==_POLY && b.type==_POLY){
4927       polynome *quoptr=new polynome, rem;
4928       if (!divrem1(*a._POLYptr,*b._POLYptr,*quoptr,rem,2))
4929 	CERR << "bad quo("+a.print()+","+b.print()+")" << '\n';
4930       gen res= *quoptr;
4931       // if (!is_zero(a-b*res))
4932       //	CERR << "Bad division" << '\n';
4933       return res;
4934 #if 0
4935       polynome quo;
4936       if (!a._POLYptr->Texactquotient(*b._POLYptr,quo))
4937 	CERR << "bad quo("+a.print()+","+b.print()+")" << '\n';
4938       return quo;
4939 #endif
4940     }
4941     return rdiv(a,b,context0);
4942   }
4943 
4944   // v=(c1*v1+c2*v2)/c
4945   // Set cstart to 0, or to c+1 for lu decomposition
linear_combination(const gen & c1,const vecteur & v1,const gen & c2,const vecteur & v2,const gen & c,const gen & cinv,vecteur & v,double eps,int cstart)4946   void linear_combination(const gen & c1,const vecteur & v1,const gen & c2,const vecteur & v2,const gen & c,const gen & cinv,vecteur & v,double eps,int cstart){
4947     if (!is_one(cinv)){
4948       if (cinv.type==_FRAC)
4949 	linear_combination(c1*cinv._FRACptr->num,v1,c2*cinv._FRACptr->num,v2,cinv._FRACptr->den,1,v,eps,cstart);
4950       else
4951 	linear_combination(c1*cinv,v1,c2*cinv,v2,1,1,v,eps,cstart);
4952       return;
4953     }
4954     const_iterateur it1=v1.begin()+cstart,it1end=v1.end(),it2=v2.begin()+cstart;
4955     iterateur jt1=v.begin()+cstart;
4956 #ifdef DEBUG_SUPPORT
4957     if (it1end-it1!=v2.end()-it2)
4958       setdimerr();
4959 #endif
4960     if (it2==jt1){
4961       linear_combination(c2,v2,c1,v1,c,1,v,eps,cstart);
4962       return;
4963     }
4964     if (it1==jt1){
4965       if (is_one(c)){
4966 	for (;jt1!=it1end;++jt1,++it2){
4967 	  *jt1=trim(c1*(*jt1)+c2*(*it2),c1,eps);
4968 	}
4969       }
4970       else {
4971 	int t=0;
4972 	if (c1.type==c2.type){
4973 	  t=c1.type;
4974 	  if (t==_EXT && *(c1._EXTptr+1)!=*(c2._EXTptr+1))
4975 	    t=0;
4976 	}
4977 	for (;jt1!=it1end;++jt1,++it2){
4978 #ifndef USE_GMP_REPLACEMENTS
4979 	  if (t==_ZINT && jt1->type==_ZINT && c.type==_ZINT && it2->type==_ZINT && jt1->ref_count()==1){
4980 	    mpz_mul(*jt1->_ZINTptr,*jt1->_ZINTptr,*c1._ZINTptr);
4981 	    mpz_addmul(*jt1->_ZINTptr,*it2->_ZINTptr,*c2._ZINTptr);
4982 	    mpz_divexact(*jt1->_ZINTptr,*jt1->_ZINTptr,*c._ZINTptr);
4983 	    if (mpz_sizeinbase(*jt1->_ZINTptr,2)<31)
4984 	      *jt1=int(mpz_get_si(*jt1->_ZINTptr));
4985 	    continue;
4986 	  }
4987 #endif
4988 	  if (t==_EXT && jt1->type==_EXT && it2->type==_EXT && *(jt1->_EXTptr+1)==*(c1._EXTptr+1) && *(it2->_EXTptr+1)==*(c1._EXTptr+1)){
4989 	    gen tmp=change_subtype(*c1._EXTptr,_POLY1__VECT)*(*jt1->_EXTptr)+change_subtype(*c2._EXTptr,_POLY1__VECT)*(*it2->_EXTptr);
4990 	    tmp=ext_reduce(tmp,*(c1._EXTptr+1));
4991 	    *jt1=exact_div(tmp,c);
4992 	    continue;
4993 	  }
4994 	  *jt1=trim(exact_div(c1*(*jt1)+c2*(*it2),c),c1,eps);
4995 	}
4996       }
4997       return;
4998     }
4999     v.clear();
5000     v.reserve(it1end-it1);
5001     if (is_one(c)){
5002       for (;it1!=it1end;++it1,++it2)
5003 	v.push_back(trim(c1*(*it1)+c2*(*it2),c1,eps));
5004     }
5005     else {
5006       for (;it1!=it1end;++it1,++it2)
5007 	v.push_back(trim(exact_div(c1*(*it1)+c2*(*it2),c),c1,eps));
5008     }
5009   }
5010 
5011   // v1=v1+c2*v2 smod modulo
modlinear_combination(vecteur & v1,const gen & c2,const vecteur & v2,const gen & modulo,int cstart,int cend)5012   void modlinear_combination(vecteur & v1,const gen & c2,const vecteur & v2,const gen & modulo,int cstart,int cend){
5013     if (!is_exactly_zero(c2)){
5014       iterateur it1=v1.begin()+cstart,it1end=v1.end();
5015       if (cend && cend>=cstart && cend<it1end-v1.begin())
5016 	it1end=v1.begin()+cend;
5017       const_iterateur it2=v2.begin()+cstart;
5018       for (;it1!=it1end;++it1,++it2)
5019 	*it1=smod((*it1)+c2*(*it2),modulo);
5020     }
5021   }
5022 
5023   // v=c1*v1+c2*v2
double_linear_combination(double c1,const std::vector<giac_double> & v1,double c2,const std::vector<giac_double> & v2,std::vector<giac_double> & v,int cstart)5024   void double_linear_combination(double c1,const std::vector<giac_double> & v1,double c2,const std::vector<giac_double> & v2,std::vector<giac_double> & v,int cstart){
5025     std::vector<giac_double>::const_iterator it1=v1.begin()+cstart,it1end=v1.end();
5026     std::vector<giac_double>::const_iterator it2=v2.begin()+cstart;
5027     std::vector<giac_double>::iterator it=v.begin()+cstart;
5028     for (;it1!=it1end;++it,++it1,++it2)
5029       *it = c1*(*it1)+c2*(*it2);
5030   }
5031 
5032   // v1=v1+c2*v2
double_linear_combination(std::vector<giac_double> & v1,double c2,const std::vector<giac_double> & v2,int cstart,int cend)5033   void double_linear_combination(std::vector<giac_double> & v1,double c2,const std::vector<giac_double> & v2,int cstart,int cend){
5034     if (c2){
5035       std::vector<giac_double>::iterator it1=v1.begin()+cstart,it1end=v1.end();
5036       if (cend && cend>=cstart && cend<it1end-v1.begin())
5037 	it1end=v1.begin()+cend;
5038       std::vector<giac_double>::const_iterator it2=v2.begin()+cstart;
5039       for (;it1!=it1end;++it1,++it2)
5040 	*it1 += c2*(*it2);
5041     }
5042   }
5043 
5044 #ifndef GIAC_HAS_STO_38
5045   // v1 += c1*w, v2 += c2*w, v3 += c3*w, v4 += c4*w;
double_multilinear_combination(std::vector<giac_double> & v1,giac_double c1,std::vector<giac_double> & v2,giac_double c2,std::vector<giac_double> & v3,giac_double c3,std::vector<giac_double> & v4,giac_double c4,const std::vector<giac_double> & w,int cstart,int cend)5046   void double_multilinear_combination(std::vector<giac_double> & v1,giac_double c1,std::vector<giac_double> & v2,giac_double c2,std::vector<giac_double> & v3,giac_double c3,std::vector<giac_double> & v4,giac_double c4,const std::vector<giac_double> & w,int cstart,int cend){
5047     if (!c1 && !c2 && !c3 && !c4)
5048       return;
5049     std::vector<giac_double>::iterator it1=v1.begin()+cstart,it1end=v1.end(),it2=v2.begin()+cstart,it3=v3.begin()+cstart,it4=v4.begin()+cstart;
5050     if (cend && cend>=cstart && cend<it1end-v1.begin())
5051       it1end=v1.begin()+cend;
5052     std::vector<giac_double>::const_iterator jt=w.begin()+cstart;
5053     for (;it1!=it1end;++jt,++it4,++it3,++it2,++it1){
5054       giac_double tmp=*jt;
5055       *it1 += c1*tmp;
5056       *it2 += c2*tmp;
5057       *it3 += c3*tmp;
5058       *it4 += c4*tmp;
5059     }
5060   }
5061 
5062 #ifdef PSEUDO_MOD
pseudo_quo(longlong x,int p,unsigned invp,unsigned nbits)5063   inline int pseudo_quo(longlong x,int p,unsigned invp,unsigned nbits){
5064     longlong q=(((x>>nbits)*invp)>>(nbits));
5065     longlong y = x-q*p;
5066     while (y>=p){
5067       ++q; y-=p;
5068     }
5069     while (y<=-p){
5070       --q; y+=p;
5071     }
5072     return q;
5073   }
5074 
5075   // find pseudo remainder of x mod p, 2^nbits>=p>2^(nbits-1)
5076   // assumes invp=2^(2*nbits)/p+1 has been precomputed
5077   // and abs(x)<2^(31+nbits)
5078   // |remainder| <= max(2^nbits,|x|*p/2^(2nbits)), <=2*p if |x|<=p^2
pseudo_mod(longlong x,int p,unsigned invp,unsigned nbits)5079   inline int pseudo_mod(longlong x,int p,unsigned invp,unsigned nbits){
5080 #if 1 // def INT128
5081     // if ( x - (((x>>nbits)*invp)>>(nbits))*p != int(x - (((x>>nbits)*invp)>>(nbits))*p)){ CERR << "erreur " << x << " " << p << '\n'; exit(1); }
5082     //if ( ((x - (((x>>nbits)*invp)>>(nbits))*p)-x) % p ){ CERR << "erreur " << x << " " << p << " " << invp << " " << nbits << '\n'; exit(1); }
5083     return x - (((x>>nbits)*invp)>>(nbits))*p;
5084 #else
5085     // longlong X=x;
5086     ulonglong mask= x>>63;
5087     x ^= mask; // clear sign
5088     int y = x - (((x>>nbits)*invp)>>(nbits))*p;
5089     // int z=y;
5090     y ^= ((unsigned) mask);
5091     // if ((y-X)%p) CERR << "error" << x << '\n';
5092     // if (y<=-p || y>=p)
5093     //  CERR << "error " << y << " " << p << '\n';
5094     return y;
5095 #endif
5096   }
5097 
5098   // a <- (a+b*c) mod or smod p
pseudo_mod(int & a,int b,int c,int p,unsigned invp,unsigned nbits)5099   inline void pseudo_mod(int & a,int b,int c,int p,unsigned invp,unsigned nbits){
5100     a=pseudo_mod(a+((longlong)b)*c,p,invp,nbits);
5101   }
5102 
5103   // n==nbits, for |x|<=p^2, 2^n>=p>2^(n-1), returns |remainder|<=p
5104   // assumes invp=floor(2^(2n)/p)+1, 2^(2n)/p < invp <= 2^(2n)/p+1
5105   // for x>0, x/2^n-1 < floor(x/2^n) <= x/2^n hence we have
5106   // x/p-2^n/p < floor((x/2^n)*invp)/2^n <= x/p+x/2^(2n)
5107   // therefore -x*p/2^(2n) <= x-(floor((x/2^n)*invp)/2^n)*p < 2^n
5108   // the remainder is at most p*(2^n/p)< 2*p if x is positive
5109   // number of operations 5+4+4 (instead of 5 for pseudomod)
pseudo_mod_reduced(longlong x,int p,unsigned invp,unsigned nbits)5110   inline int pseudo_mod_reduced(longlong x,int p,unsigned invp,unsigned nbits){
5111     int y=x - (((x>>nbits)*invp)>>(nbits))*p;
5112     y -= ((y-p)>>31)*p;
5113     return y+((p-y)>>31)*p;
5114   }
5115 #endif // PSEUDO_MOD
double_mod(longlong x,int p,double invp)5116   inline int double_mod(longlong x,int p,double invp){
5117     longlong q=x*invp;
5118     return x-q*p;
5119   }
5120 
5121   // a <- (a+b*c) mod or smod p
double_mod(int & a,int b,int c,int p,double invp)5122   inline void double_mod(int & a,int b,int c,int p,double invp){
5123     a=double_mod(a+((longlong)b)*c,p,invp);
5124   }
5125 
5126 
5127   // v1 += c1*w % p, v2 += c2*w %p, v3 += c3*w % p, v4 += c4*w % p;
5128   // v1 += c1*w % p, v2 += c2*w %p, v3 += c3*w % p, v4 += c4*w % p;
int_multilinear_combination(std::vector<int> & v1,int c1,std::vector<int> & v2,int c2,std::vector<int> & v3,int c3,std::vector<int> & v4,int c4,const std::vector<int> & w,int p,int cstart,int cend)5129   void int_multilinear_combination(std::vector<int> & v1,int c1,std::vector<int> & v2,int c2,std::vector<int> & v3,int c3,std::vector<int> & v4,int c4,const std::vector<int> & w,int p,int cstart,int cend){
5130     c1 %=p; c2 %=p; c3 %=p; c4 %=p;
5131     int * it1=&*(v1.begin()+cstart),*it1end=&*(v1.end()),*it2=&*(v2.begin()+cstart),*it3=&*(v3.begin()+cstart),*it4=&*(v4.begin()+cstart),*it1_;
5132     if (cend && cend>=cstart && cend<it1end-&v1.front())
5133       it1end=&*(v1.begin()+cend);
5134     it1_=it1-4;
5135     const int * jt=&*(w.begin()+cstart);
5136 #ifdef PSEUDO_MOD
5137     if (p<(1<<29)
5138 	// && p>=(1<<16)
5139 	){
5140       int nbits=sizeinbase2(p);
5141       unsigned invp=((1ULL<<(2*nbits)))/p+1;
5142       for (;it1<=it1_;){
5143 	int tmp=*jt;
5144 	pseudo_mod(*it1,c1,tmp,p,invp,nbits);
5145 	pseudo_mod(*it2,c2,tmp,p,invp,nbits);
5146 	pseudo_mod(*it3,c3,tmp,p,invp,nbits);
5147 	pseudo_mod(*it4,c4,tmp,p,invp,nbits);
5148 	tmp=jt[1];
5149 	pseudo_mod(it1[1],c1,tmp,p,invp,nbits);
5150 	pseudo_mod(it2[1],c2,tmp,p,invp,nbits);
5151 	pseudo_mod(it3[1],c3,tmp,p,invp,nbits);
5152 	pseudo_mod(it4[1],c4,tmp,p,invp,nbits);
5153 	tmp=jt[2];
5154 	pseudo_mod(it1[2],c1,tmp,p,invp,nbits);
5155 	pseudo_mod(it2[2],c2,tmp,p,invp,nbits);
5156 	pseudo_mod(it3[2],c3,tmp,p,invp,nbits);
5157 	pseudo_mod(it4[2],c4,tmp,p,invp,nbits);
5158 	tmp=jt[3];
5159 	pseudo_mod(it1[3],c1,tmp,p,invp,nbits);
5160 	pseudo_mod(it2[3],c2,tmp,p,invp,nbits);
5161 	pseudo_mod(it3[3],c3,tmp,p,invp,nbits);
5162 	pseudo_mod(it4[3],c4,tmp,p,invp,nbits);
5163 	jt+=4;it4+=4;it3+=4;it2+=4;it1+=4;
5164       }
5165       for (;it1!=it1end;++jt,++it4,++it3,++it2,++it1){
5166 	int tmp=*jt;
5167 	pseudo_mod(*it1,c1,tmp,p,invp,nbits);
5168 	pseudo_mod(*it2,c2,tmp,p,invp,nbits);
5169 	pseudo_mod(*it3,c3,tmp,p,invp,nbits);
5170 	pseudo_mod(*it4,c4,tmp,p,invp,nbits);
5171       }
5172     }
5173     else
5174 #endif
5175 #if 0
5176       {
5177 	for (;it1<=it1_;){
5178 	  int tmp=*jt;
5179 	  *it1 = (*it1+longlong(c1)*tmp)%p;
5180 	  *it2 = (*it2+longlong(c2)*tmp)%p;
5181 	  *it3 = (*it3+longlong(c3)*tmp)%p;
5182 	  *it4 = (*it4+longlong(c4)*tmp)%p;
5183 	  ++jt;++it4;++it3;++it2;++it1;
5184 	  tmp=*jt;
5185 	  *it1 = (*it1+longlong(c1)*tmp)%p;
5186 	  *it2 = (*it2+longlong(c2)*tmp)%p;
5187 	  *it3 = (*it3+longlong(c3)*tmp)%p;
5188 	  *it4 = (*it4+longlong(c4)*tmp)%p;
5189 	  ++jt;++it4;++it3;++it2;++it1;
5190 	  tmp=*jt;
5191 	  *it1 = (*it1+longlong(c1)*tmp)%p;
5192 	  *it2 = (*it2+longlong(c2)*tmp)%p;
5193 	  *it3 = (*it3+longlong(c3)*tmp)%p;
5194 	  *it4 = (*it4+longlong(c4)*tmp)%p;
5195 	  ++jt;++it4;++it3;++it2;++it1;
5196 	  tmp=*jt;
5197 	  *it1 = (*it1+longlong(c1)*tmp)%p;
5198 	  *it2 = (*it2+longlong(c2)*tmp)%p;
5199 	  *it3 = (*it3+longlong(c3)*tmp)%p;
5200 	  *it4 = (*it4+longlong(c4)*tmp)%p;
5201 	  ++jt;++it4;++it3;++it2;++it1;
5202 	}
5203 	for (;it1!=it1end;++jt,++it4,++it3,++it2,++it1){
5204 	  int tmp=*jt;
5205 	  *it1 = (*it1+longlong(c1)*tmp)%p;
5206 	  *it2 = (*it2+longlong(c2)*tmp)%p;
5207 	  *it3 = (*it3+longlong(c3)*tmp)%p;
5208 	  *it4 = (*it4+longlong(c4)*tmp)%p;
5209 	}
5210       }
5211 #else
5212       {
5213 	double invp=1.0/p;
5214 	for (;it1<=it1_;){
5215 	  int tmp=*jt;
5216 	  double_mod(*it1,c1,tmp,p,invp);
5217 	  double_mod(*it2,c2,tmp,p,invp);
5218 	  double_mod(*it3,c3,tmp,p,invp);
5219 	  double_mod(*it4,c4,tmp,p,invp);
5220 	  tmp=jt[1];
5221 	  double_mod(it1[1],c1,tmp,p,invp);
5222 	  double_mod(it2[1],c2,tmp,p,invp);
5223 	  double_mod(it3[1],c3,tmp,p,invp);
5224 	  double_mod(it4[1],c4,tmp,p,invp);
5225 	  tmp=jt[2];
5226 	  double_mod(it1[2],c1,tmp,p,invp);
5227 	  double_mod(it2[2],c2,tmp,p,invp);
5228 	  double_mod(it3[2],c3,tmp,p,invp);
5229 	  double_mod(it4[2],c4,tmp,p,invp);
5230 	  tmp=jt[3];
5231 	  double_mod(it1[3],c1,tmp,p,invp);
5232 	  double_mod(it2[3],c2,tmp,p,invp);
5233 	  double_mod(it3[3],c3,tmp,p,invp);
5234 	  double_mod(it4[3],c4,tmp,p,invp);
5235 	  jt+=4;it4+=4;it3+=4;it2+=4;it1+=4;
5236 	}
5237 	for (;it1!=it1end;++jt,++it4,++it3,++it2,++it1){
5238 	  int tmp=*jt;
5239 	  double_mod(*it1,c1,tmp,p,invp);
5240 	  double_mod(*it2,c2,tmp,p,invp);
5241 	  double_mod(*it3,c3,tmp,p,invp);
5242 	  double_mod(*it4,c4,tmp,p,invp);
5243 	}
5244       }
5245 #endif
5246   }
5247 
LL_multilinear_combination(std::vector<longlong> & v1,int c1,std::vector<longlong> & v2,int c2,std::vector<longlong> & v3,int c3,std::vector<longlong> & v4,int c4,const std::vector<longlong> & w,int p,int cstart,int cend)5248   void LL_multilinear_combination(std::vector<longlong> & v1,int c1,std::vector<longlong> & v2,int c2,std::vector<longlong> & v3,int c3,std::vector<longlong> & v4,int c4,const std::vector<longlong> & w,int p,int cstart,int cend){
5249     c1 %=p; c2 %=p; c3 %=p; c4 %=p;
5250     longlong * it1=&*(v1.begin()+cstart),*it1end=&*(v1.end()),*it2=&*(v2.begin()+cstart),*it3=&*(v3.begin()+cstart),*it4=&*(v4.begin()+cstart),*it1_;
5251     if (cend && cend>=cstart && cend<it1end-&v1.front())
5252       it1end=&*(v1.begin()+cend);
5253     it1_=it1-4;
5254     const longlong * jt=&*(w.begin()+cstart);
5255     for (;it1<=it1_;it1+=4,it2+=4,it3+=4,it4+=4,jt+=4){
5256       longlong tmp=*jt;
5257       *it1 += c1*tmp;
5258       *it2 += c2*tmp;
5259       *it3 += c3*tmp;
5260       *it4 += c4*tmp;
5261       tmp=jt[1];
5262       it1[1] += c1*tmp;
5263       it2[1] += c2*tmp;
5264       it3[1] += c3*tmp;
5265       it4[1] += c4*tmp;
5266       tmp=jt[2];
5267       it1[2] += c1*tmp;
5268       it2[2] += c2*tmp;
5269       it3[2] += c3*tmp;
5270       it4[2] += c4*tmp;
5271       tmp=jt[3];
5272       it1[3] += c1*tmp;
5273       it2[3] += c2*tmp;
5274       it3[3] += c3*tmp;
5275       it4[3] += c4*tmp;
5276     }
5277     for (;it1!=it1end;++jt,++it4,++it3,++it2,++it1){
5278       longlong tmp=*jt;
5279       *it1 += c1*tmp;
5280       *it2 += c2*tmp;
5281       *it3 += c3*tmp;
5282       *it4 += c4*tmp;
5283     }
5284   }
5285 
find_multi_linear_combination(vector<vector<int>> & N,int l0,int & l1,int & l2,int & l3,int pivotcol,int lexcluded,int lmax)5286   bool find_multi_linear_combination(vector< vector<int> > & N,int l0,int & l1,int &l2,int &l3,int pivotcol,int lexcluded,int lmax){
5287     if (l0>=lmax-3)
5288       return false;
5289     l1=l0+1;
5290     for (;l1<lmax;++l1){
5291       if (l1!=lexcluded && !N[l1].empty() && N[l1][pivotcol])
5292 	break;
5293     }
5294     if (l1>=lmax-2)
5295       return false;
5296     l2=l1+1;
5297     for (;l2<lmax;++l2){
5298       if (l2!=lexcluded && !N[l2].empty() && N[l2][pivotcol])
5299 	break;
5300     }
5301     if (l2>=lmax-1)
5302       return false;
5303     l3=l2+1;
5304     for (;l3<lmax;++l3){
5305       if (l3!=lexcluded && !N[l3].empty() && N[l3][pivotcol])
5306 	break;
5307     }
5308     return l3<lmax;
5309   }
5310 
find_multi_linear_combination(vector<vector<longlong>> & N,int l0,int & l1,int & l2,int & l3,int pivotcol,int lexcluded,int lmax)5311   bool find_multi_linear_combination(vector< vector<longlong> > & N,int l0,int & l1,int &l2,int &l3,int pivotcol,int lexcluded,int lmax){
5312     if (l0>=lmax-3)
5313       return false;
5314     vector<longlong> * ptr;
5315     l1=l0+1;
5316     for (;l1<lmax;++l1){
5317       if (l1!=lexcluded && !(ptr=&N[l1])->empty() && (*ptr)[pivotcol])
5318 	break;
5319     }
5320     if (l1>=lmax-2)
5321       return false;
5322     l2=l1+1;
5323     for (;l2<lmax;++l2){
5324       if (l2!=lexcluded && !(ptr=&N[l2])->empty() && (*ptr)[pivotcol])
5325 	break;
5326     }
5327     if (l2>=lmax-1)
5328       return false;
5329     l3=l2+1;
5330     for (;l3<lmax;++l3){
5331       if (l3!=lexcluded && !(ptr=&N[l3])->empty() && (*ptr)[pivotcol])
5332 	break;
5333     }
5334     return l3<lmax;
5335   }
5336 
5337   struct thread_double_lu2inv_t {
5338     matrix_double * m;
5339     int i,end,n;
5340     vector<int> * startshift,*lastnon0posv;
5341   };
5342 
do_thread_double_linv(void * ptr)5343   void * do_thread_double_linv(void * ptr){
5344     thread_double_lu2inv_t * p = (thread_double_lu2inv_t *) ptr;
5345     matrix_double & m =*p->m;
5346     int i=p->i;
5347     int end=p->end;
5348     int n=p->n;
5349     vector<int> * startshift=p->startshift;
5350     // first step compute l^-1 this is done by the recurrence: l*a=y:
5351     // a1=y1, a2=y2-l_21*a1, ..., ak=yk-sum_{j=1..k-1}(l_kj*aj)
5352     // if y=(0,..,0,1,0,...0),
5353     // a0=..=a_{i-1}=0 and we start at equation k=i+1 and sum_{j=i...}
5354     // n^3/6 operations
5355     for (;i<=end-4;i+=4){
5356       giac_double * col0=&m[i][n],* col1=&m[i+1][n],* col2=&m[i+2][n],* col3=&m[i+3][n];
5357       for (int k=0;k<i+4;++k){
5358 	col0[k]=0.0;
5359 	col1[k]=0.0;
5360 	col2[k]=0.0;
5361 	col3[k]=0.0;
5362       }
5363       col0[i]=1.0;
5364       col0[i+1]=-m[i+1][i];
5365       col0[i+2]=-m[i+2][i]-col0[i+1]*m[i+2][i+1];
5366       col0[i+3]=-m[i+3][i]-col0[i+1]*m[i+3][i+1]-col0[i+2]*m[i+3][i+2];
5367       col1[i+1]=1.0;
5368       col1[i+2]=-m[i+2][i+1];
5369       col1[i+3]=-m[i+3][i+1]-col1[i+2]*m[i+3][i+2];
5370       col2[i+2]=1.0;
5371       col2[i+3]=-m[i+3][i+2];
5372       col3[i+3]=1.0;
5373       for (int k=i+4;k<n;++k){
5374 	giac_double res0=0.0,res1=0.0,res2=0.0,res3=0.0;
5375 	giac_double * mkj=&m[k][i],*col0j=col0+i,*col1j=col1+i,*col2j=col2+i,*col3j=col3+i,*col0end=col0+k;
5376 	// skip leading 0 in l rows
5377 	if (startshift){
5378 	  int shift=(*startshift)[k]-i;
5379 	  if (shift>0){
5380 	    mkj += shift;
5381 	    col0j += shift;
5382 	    col1j += shift;
5383 	    col2j += shift;
5384 	    col3j += shift;
5385 	  }
5386 	}
5387 	for (;col0j<col0end;++mkj,++col3j,++col2j,++col1j,++col0j){
5388 	  giac_double tmp=(*mkj);
5389 	  if (!tmp) continue;
5390 	  res0 -= tmp*(*col0j);
5391 	  res1 -= tmp*(*col1j);
5392 	  res2 -= tmp*(*col2j);
5393 	  res3 -= tmp*(*col3j);
5394 	}
5395 	*col0j=res0;
5396 	*col1j=res1;
5397 	*col2j=res2;
5398 	*col3j=res3;
5399       }
5400     }
5401     for (;i<end;++i){
5402       giac_double * col=&m[i][n];
5403       for (int k=0;k<i;++k)
5404 	col[k]=0.0;
5405       col[i]=1.0;
5406       for (int k=i+1;k<n;++k){
5407 	giac_double res=0.0;
5408 	giac_double * mkj=&m[k][i],*colj=col+i,*colend=col+k;
5409 	for (;colj<colend;++mkj,++colj)
5410 	  res -= (*mkj)*(*colj);
5411 	*colend=res;
5412       }
5413     }
5414     return ptr;
5415   }
5416 
5417   int invd_blocksize=170;
_invd_blocksize(const gen & g0,GIAC_CONTEXT)5418   gen _invd_blocksize(const gen & g0,GIAC_CONTEXT){
5419     if ( g0.type==_STRNG && g0.subtype==-1) return  g0;
5420     gen g=evalf_double(g0,1,contextptr);
5421     if (g.type!=_DOUBLE_)
5422       return invd_blocksize;
5423     return invd_blocksize=int(g._DOUBLE_val);
5424   }
5425   static const char _invd_blocksize_s []="invd_blocksize";
5426   static define_unary_function_eval (__invd_blocksize,&_invd_blocksize,_invd_blocksize_s);
5427   define_unary_function_ptr5( at_invd_blocksize ,alias_at_invd_blocksize,&__invd_blocksize,0,true);
5428 
5429 
5430     // second step, solve u*inverse=l^-1, columns of l^-1 are rows of m starting at col n
5431     // we compute a column of inverse by solving the system:
5432     // u*col(inverse)=corresponding row of l^-1, and overwrite the row of l^-1 by solution
5433     // u*[x0,..,xn-1]=[a0,...,an]
5434     // x_{n-1}=a_{n-1}/u_{n-1,n-1}
5435     // x_{n-2}=(a_{n-2}-u_{n-2,n-1}*x_{n-1})/u_{n-2,n-2}
5436     // ...
5437     // x_k=(a_{k}-sum_{j=k+1..n-1} u_{k,j}x_j)/u_{k,k}
5438     // n^3/2 operations
5439     // the first i loop is unrolling
do_thread_double_lu2inv(void * ptr)5440   void * do_thread_double_lu2inv(void * ptr){
5441     thread_double_lu2inv_t * p = (thread_double_lu2inv_t *) ptr;
5442     matrix_double & m =*p->m;
5443     int i=p->i;
5444     int end=p->end;
5445     int n=p->n;
5446     vector<int> * lastnon0posv=p->lastnon0posv;
5447     if (n<=200 || invd_blocksize<=1){
5448       for (;i<=end-6;i+=6){
5449 	giac_double * col0=&m[i][n],* col1=&m[i+1][n],* col2=&m[i+2][n],* col3=&m[i+3][n],* col4=&m[i+4][n],* col5=&m[i+5][n];
5450 	for (int k=n-1;k>=0;--k){
5451 	  giac_double res0=col0[k],res1=col1[k],res2=col2[k],res3=col3[k],res4=col4[k],res5=col5[k];
5452 	  int lastnon0pos=n-1;
5453 	  if (lastnon0posv)
5454 	    lastnon0pos=(*lastnon0posv)[k];
5455 	  giac_double * mkj=&m[k][lastnon0pos],*col0j=col0+lastnon0pos,*colend=col0+k,*col1j=col1+lastnon0pos,*col2j=col2+lastnon0pos,*col3j=col3+lastnon0pos,*col4j=col4+lastnon0pos,*col5j=col5+lastnon0pos;
5456 	  for (;col0j>colend;--mkj,--col5j,--col4j,--col3j,--col2j,--col1j,--col0j){
5457 	    giac_double tmp=*mkj;
5458 	    if (!tmp) continue;
5459 	    res0 -= tmp*(*col0j);
5460 	    res1 -= tmp*(*col1j);
5461 	    res2 -= tmp*(*col2j);
5462 	    res3 -= tmp*(*col3j);
5463 	    res4 -= tmp*(*col4j);
5464 	    res5 -= tmp*(*col5j);
5465 	  }
5466 	  giac_double tmp=*mkj;
5467 	  *col0j=res0/tmp;
5468 	  *col1j=res1/tmp;
5469 	  *col2j=res2/tmp;
5470 	  *col3j=res3/tmp;
5471 	  *col4j=res4/tmp;
5472 	  *col5j=res5/tmp;
5473 	}
5474       }
5475       for (;i<end;i++){
5476 	giac_double * col=&m[i][n];
5477 	for (int k=n-1;k>=0;--k){
5478 	  giac_double res=col[k];
5479 	  giac_double * mkj=&m[k][n-1],*colj=col+n-1,*colend=col+k;
5480 	  for (;colj>colend;--mkj,--colj){
5481 	    res -= (*mkj)*(*colj);
5482 	  }
5483 	  *colj=res/(*mkj);
5484 	}
5485       }
5486     }
5487     else { // invd_blocsize>1
5488       int istart=i,iend=end;
5489       int cstart=n-1,cend;
5490       for (;cstart>=0;cstart=cend-1){
5491 	cend=cstart-invd_blocksize+1;
5492 	if (cend<0) cend=0;
5493 	// solve unknowns from cstart to cend
5494 	i=istart;
5495 	for (;i<=iend-6;i+=6){
5496 	  giac_double * col0=&m[i][n],* col1=&m[i+1][n],* col2=&m[i+2][n],* col3=&m[i+3][n],* col4=&m[i+4][n],* col5=&m[i+5][n];
5497 	  for (int k=cstart;k>=cend;--k){
5498 	    giac_double res0=col0[k],res1=col1[k],res2=col2[k],res3=col3[k],res4=col4[k],res5=col5[k];
5499 	    int lastnon0pos=cstart;
5500 	    if (lastnon0posv)
5501 	      lastnon0pos=giacmin(cstart,(*lastnon0posv)[k]);
5502 	    giac_double * mkj=&m[k][lastnon0pos],*col0j=col0+lastnon0pos,*colend=col0+k,*col1j=col1+lastnon0pos,*col2j=col2+lastnon0pos,*col3j=col3+lastnon0pos,*col4j=col4+lastnon0pos,*col5j=col5+lastnon0pos;
5503 	    for (;col0j>colend;--mkj,--col5j,--col4j,--col3j,--col2j,--col1j,--col0j){
5504 	      giac_double tmp=*mkj;
5505 	      if (!tmp) continue;
5506 	      res0 -= tmp*(*col0j);
5507 	      res1 -= tmp*(*col1j);
5508 	      res2 -= tmp*(*col2j);
5509 	      res3 -= tmp*(*col3j);
5510 	      res4 -= tmp*(*col4j);
5511 	      res5 -= tmp*(*col5j);
5512 	    }
5513 	    *col0j=res0/(*mkj);
5514 	    *col1j=res1/(*mkj);
5515 	    *col2j=res2/(*mkj);
5516 	    *col3j=res3/(*mkj);
5517 	    *col4j=res4/(*mkj);
5518 	    *col5j=res5/(*mkj);
5519 	  }
5520 	}
5521 	for (;i<iend;i++){
5522 	  giac_double * col=&m[i][n];
5523 	  for (int k=cstart;k>=cend;--k){
5524 	    giac_double res=col[k];
5525 	    giac_double * mkj=&m[k][cstart],*colj=col+cstart,*colend=col+k;
5526 	    for (;colj>colend;--mkj,--colj){
5527 	      res -= (*mkj)*(*colj);
5528 	    }
5529 	    *colj=res/(*mkj);
5530 	  }
5531 	}
5532 	if (!cend) break;
5533 	// use computed values
5534 	int kstart=cend-1,kend;
5535 	for (;kstart>=0;kstart=kend-1){
5536 	  kend=kstart-invd_blocksize+1;
5537 	  if (kend<0) kend=0;
5538 	  i=istart;
5539 	  for (;i<=iend-6;i+=6){
5540 	    giac_double * col0=&m[i][n],* col1=&m[i+1][n],* col2=&m[i+2][n],* col3=&m[i+3][n],* col4=&m[i+4][n],* col5=&m[i+5][n];
5541 	    for (int k=kstart;k>=kend;--k){
5542 	      giac_double res0=col0[k],res1=col1[k],res2=col2[k],res3=col3[k],res4=col4[k],res5=col5[k];
5543 	      giac_double * mkj=&m[k][cstart],*col0j=col0+cstart,*colend=col0+cend,*col1j=col1+cstart,*col2j=col2+cstart,*col3j=col3+cstart,*col4j=col4+cstart,*col5j=col5+cstart;
5544 	      for (;col0j>=colend;--mkj,--col5j,--col4j,--col3j,--col2j,--col1j,--col0j){
5545 		giac_double tmp=*mkj;
5546 		if (!tmp) continue;
5547 		res0 -= tmp*(*col0j);
5548 		res1 -= tmp*(*col1j);
5549 		res2 -= tmp*(*col2j);
5550 		res3 -= tmp*(*col3j);
5551 		res4 -= tmp*(*col4j);
5552 		res5 -= tmp*(*col5j);
5553 	      }
5554 	      col0[k]=res0;
5555 	      col1[k]=res1;
5556 	      col2[k]=res2;
5557 	      col3[k]=res3;
5558 	      col4[k]=res4;
5559 	      col5[k]=res5;
5560 	    }
5561 	  }
5562 	  for (;i<iend;i++){
5563 	    giac_double * col=&m[i][n];
5564 	    for (int k=kstart;k>=kend;--k){
5565 	      giac_double res=col[k];
5566 	      giac_double * mkj=&m[k][cstart],*colj=col+cstart,*colend=col+cend;
5567 	      for (;colj>=colend;--mkj,--colj){
5568 		res -= (*mkj)*(*colj);
5569 	      }
5570 	      col[k]=res;
5571 	    }
5572 	  }
5573 	}
5574       } // cstart loop
5575     } // else invd_blocsize
5576     return ptr;
5577   }
5578 
5579   // if m is in lu form (first n columns), compute l^-1, then solve u*inverse=l^-1
double_lu2inv(matrix_double & m,const vector<int> & permu)5580   void double_lu2inv(matrix_double & m,const vector<int> & permu){
5581     int n=permu.size();
5582     vector<int> perm=perminv(permu);
5583     if (debug_infolevel)
5584       CERR << CLOCK()*1e-6 << " lu2inv begin n=" << n << '\n';
5585     bool done=false;
5586     // detect leading 0 in l part of m (speedup for band matrices)
5587     vector<int> startshiftv(n),lastnon0posv(n,n-1);
5588     for (int i=0;i<n;++i){
5589       int j=0;
5590       vector<double> & mi=m[i];
5591       for (;j<i;++j){
5592 	if (mi[j])
5593 	  break;
5594       }
5595       startshiftv[i]=j;
5596       j=n-1;
5597       for (;j>i;--j){
5598 	if (mi[j])
5599 	  break;
5600       }
5601       lastnon0posv[i]=j;
5602     }
5603 #ifdef HAVE_LIBPTHREAD
5604     int nthreads=threads_allowed?threads:1;
5605     if (nthreads>1 && n>40){
5606       pthread_t tab[nthreads-1];
5607       thread_double_lu2inv_t param[nthreads];
5608       int rstep=int(std::ceil(n/double(nthreads))),rstart=0,rend;
5609       for (int j=0;j<nthreads;++j){
5610 	rend=rstart+rstep;
5611 	if (rend>n) rend=n;
5612 	thread_double_lu2inv_t tmp={&m,rstart,rend,n,&startshiftv,0};
5613 	param[j]=tmp;
5614 	rstart=rend;
5615 	bool res=true;
5616 	if (j<nthreads-1)
5617 	  res=pthread_create(&tab[j],(pthread_attr_t *) NULL,do_thread_double_linv,(void *) &param[j]);
5618 	if (res)
5619 	  do_thread_double_linv((void *)&param[j]);
5620       }
5621       for (int j=0;j<nthreads;++j){
5622 	void * ptr=(void *)&nthreads; // non-zero initialisation
5623 	if (j<nthreads-1)
5624 	  pthread_join(tab[j],&ptr);
5625       }
5626       done=true;
5627     }
5628 #endif
5629     if (!done){
5630       thread_double_lu2inv_t tmp={&m,0,n,n,&startshiftv,0};
5631       do_thread_double_linv((void*)&tmp);
5632     }
5633     if (debug_infolevel)
5634       CERR << CLOCK()*1e-6 << " solving u*inv=l^-1" << '\n';
5635     done=false;
5636 #ifdef HAVE_LIBPTHREAD
5637     if (nthreads>1 && n>40){
5638       pthread_t tab[nthreads-1];
5639       thread_double_lu2inv_t param[nthreads];
5640       int rstep=int(std::ceil(n/double(nthreads))),rstart=0,rend;
5641       for (int j=0;j<nthreads;++j){
5642 	rend=rstart+rstep;
5643 	if (rend>n) rend=n;
5644 	thread_double_lu2inv_t tmp={&m,rstart,rend,n,0,&lastnon0posv};
5645 	param[j]=tmp;
5646 	rstart=rend;
5647 	bool res=true;
5648 	if (j<nthreads-1)
5649 	  res=pthread_create(&tab[j],(pthread_attr_t *) NULL,do_thread_double_lu2inv,(void *) &param[j]);
5650 	if (res)
5651 	  do_thread_double_lu2inv((void *)&param[j]);
5652       }
5653       for (int j=0;j<nthreads;++j){
5654 	void * ptr=(void *)&nthreads; // non-zero initialisation
5655 	if (j<nthreads-1)
5656 	  pthread_join(tab[j],&ptr);
5657       }
5658       done=true;
5659     }
5660 #endif
5661     if (!done){
5662       thread_double_lu2inv_t tmp={&m,0,n,n,0,&lastnon0posv};
5663       do_thread_double_lu2inv((void*)&tmp);
5664     }
5665     // transpose, copy to first part, clear second part
5666     int twon=2*n;
5667     for (int i=0;i<n;++i){
5668       vector<giac_double> & mi=m[i];
5669       for (int j=n+i;j<twon;++j){
5670 	swap_giac_double(mi[j],m[j-n][i+n]);
5671       }
5672       for (int j=0;j<n;++j)
5673 	mi[j]=mi[perm[j]+n];
5674       mi.erase(mi.begin()+n,mi.end());
5675     }
5676     if (debug_infolevel)
5677       CERR << CLOCK()*1e-6 << " end lu2inv" << '\n';
5678   }
5679 
5680   // int_linsolve_l and int_linsolve_u could be faster by solving simultaneously for
5681   // say 4 values of y
5682 
5683   // solve triangular system l*a=y where l is the lower part of a lu decomp in m[l..][c..]
int_linsolve_l(const vector<vector<int>> & m,int l,int c,const vector<int> & y,vector<int> & a,int p)5684   void int_linsolve_l(const vector< vector<int> > & m,int l,int c,const vector<int> & y,vector<int> & a,int p){
5685     // l*a=y: a1=y1, a2=y2-m_21*a1, ..., ak=yk-sum_{j=1..k-1}(m_kj*aj)
5686     int n=y.size();
5687     a.resize(n);
5688     int * astart=&a[0];
5689     *astart=y[0];
5690     for (int k=1;k<n;++k){
5691       const int * mkj=&m[k+l][c];
5692       int *aj=astart,*ak=astart+k;
5693       longlong res=y[k];
5694       for (;aj<ak;++mkj,++aj)
5695 	res -= longlong(*mkj)*(*aj);
5696       *ak=res % p;
5697     }
5698   }
5699 
5700   // solve triangular system l*a=y where l is the lower part of a lu decomp in m
int_linsolve_l4(const vector<vector<int>> & m,int l,int c,const vector<int> & y0,const vector<int> & y1,const vector<int> & y2,const vector<int> & y3,vector<int> & a0,vector<int> & a1,vector<int> & a2,vector<int> & a3,int p)5701   void int_linsolve_l4(const vector< vector<int> > & m,int l,int c,const vector<int> & y0,const vector<int> & y1,const vector<int> & y2,const vector<int> & y3,vector<int> & a0,vector<int> & a1,vector<int> & a2,vector<int> & a3,int p){
5702     int n=y0.size();
5703     a0.resize(n);
5704     a1.resize(n);
5705     a2.resize(n);
5706     a3.resize(n);
5707     int * a0start=&a0[0];
5708     *a0start=y0[0];
5709     int * a1start=&a1[0];
5710     *a1start=y1[0];
5711     int * a2start=&a2[0];
5712     *a2start=y2[0];
5713     int * a3start=&a3[0];
5714     *a3start=y3[0];
5715     for (int k=1;k<n;++k){
5716       const int * mkj=&m[k+l][c];
5717       int *a0j=a0start,*a0k=a0start+k;
5718       int *a1j=a1start,*a1k=a1start+k;;
5719       int *a2j=a2start,*a2k=a2start+k;;
5720       int *a3j=a3start,*a3k=a3start+k;;
5721       longlong res0=y0[k];
5722       longlong res1=y1[k];
5723       longlong res2=y2[k];
5724       longlong res3=y3[k];
5725       for (;a0j<a0k;++mkj,++a0j,++a1j,++a2j,++a3j){
5726 	longlong tmp=*mkj;
5727 	if (!tmp) continue;
5728 	res0 -= tmp*(*a0j);
5729 	res1 -= tmp*(*a1j);
5730 	res2 -= tmp*(*a2j);
5731 	res3 -= tmp*(*a3j);
5732       }
5733       *a0k=res0 % p;
5734       *a1k=res1 % p;
5735       *a2k=res2 % p;
5736       *a3k=res3 % p;
5737     }
5738   }
5739 
5740   // solve triangular system l*a=y where l is the lower part of a lu decomp in m[l..][c..]
double_linsolve_l(const matrix_double & m,int l,int c,const vector<double> & y,vector<double> & a)5741   void double_linsolve_l(const matrix_double & m,int l,int c,const vector<double> & y,vector<double> & a){
5742     // l*a=y: a1=y1, a2=y2-m_21*a1, ..., ak=yk-sum_{j=1..k-1}(m_kj*aj)
5743     int n=y.size();
5744     a.resize(n);
5745     double * astart=&a[0];
5746     *astart=y[0];
5747     for (int k=1;k<n;++k){
5748       const double * mkj=&m[k+l][c];
5749       double *aj=astart,*ak=astart+k;
5750       double res=y[k];
5751       for (;aj<ak;++mkj,++aj)
5752 	res -= (*mkj)*(*aj);
5753       *ak=res;
5754     }
5755   }
5756 
5757   // solve triangular system l*a=y where l is the lower part of a lu decomp in m
double_linsolve_l4(const matrix_double & m,int l,int c,const vector<double> & y0,const vector<double> & y1,const vector<double> & y2,const vector<double> & y3,vector<double> & a0,vector<double> & a1,vector<double> & a2,vector<double> & a3)5758   void double_linsolve_l4(const matrix_double & m,int l,int c,const vector<double> & y0,const vector<double> & y1,const vector<double> & y2,const vector<double> & y3,vector<double> & a0,vector<double> & a1,vector<double> & a2,vector<double> & a3){
5759     int n=y0.size();
5760     a0.resize(n);
5761     a1.resize(n);
5762     a2.resize(n);
5763     a3.resize(n);
5764     double * a0start=&a0[0];
5765     *a0start=y0[0];
5766     double * a1start=&a1[0];
5767     *a1start=y1[0];
5768     double * a2start=&a2[0];
5769     *a2start=y2[0];
5770     double * a3start=&a3[0];
5771     *a3start=y3[0];
5772     for (int k=1;k<n;++k){
5773       const double * mkj=&m[k+l][c];
5774       double *a0j=a0start,*a0k=a0start+k;
5775       double *a1j=a1start,*a1k=a1start+k;;
5776       double *a2j=a2start,*a2k=a2start+k;;
5777       double *a3j=a3start,*a3k=a3start+k;;
5778       double res0=y0[k];
5779       double res1=y1[k];
5780       double res2=y2[k];
5781       double res3=y3[k];
5782       for (;a0j<a0k;++mkj,++a0j,++a1j,++a2j,++a3j){
5783 	double tmp=*mkj;
5784 	if (!tmp) continue;
5785 	res0 -= tmp*(*a0j);
5786 	res1 -= tmp*(*a1j);
5787 	res2 -= tmp*(*a2j);
5788 	res3 -= tmp*(*a3j);
5789       }
5790       *a0k=res0 ;
5791       *a1k=res1 ;
5792       *a2k=res2 ;
5793       *a3k=res3 ;
5794     }
5795   }
5796 
5797   /*
5798   // solve triangular system L*A=Y where L is the lower part of a lu decomp in m[m_l..][m_c..]
5799   // Y are the columns of y[y_l..y_l+n-1,y_c...y_c+n-1]
5800   // A is written to a[a_l...a_l+n-1,a_c...a_c+n-1]
5801   // size of system is n, number of systems is s
5802   // &y may be equal to &a
5803   void int_linsolve_l(const vector< vector<int> > & m,int m_l,int m_c,const vector< vector<int> > & y,int y_l,int y_c,vector< vector<int> > & a,int a_l,int a_c,int s,int n,int p){
5804     if (n<60 || s<60 || s<n/2+30){ // vector by vector call
5805       vector<int> y0,y1,y2,y3,a0,a1,a2,a3;
5806       int i=0;
5807       for (;i<n-4;i+=4){
5808 	// solve 4 systems
5809       }
5810       for (;i<n;++i){
5811 	// solve remaining systems
5812       }
5813       return;
5814     }
5815     if (&y!=&a){ // first copy portion of y (Y3,Y4) to portion of a (A3,A4)
5816       // a=y;
5817     }
5818     vector< vector<int> > tmp;
5819     // bloc solve L=[[L1,0],[L2,L3]], A=[[A1,A2],[A3,A4]]
5820     // L*A=[[L1*A1,L1*A2],[L3*A3+L2*A1,L3*A4+L2*A2]]==[[Y1,Y2],[Y3,Y4]]
5821     // hence A1 and A2 are computed by recursive call L1*A1=Y1, L1*A2=Y2
5822     // then L3*A3=Y3-L2*A1, L3*A4=Y4-L2*A2
5823     // the intermediate Y3-L2*A1 and Y4-L2*A2 will be written in A3 and A4
5824     int n2=n/2,n3=n-n2,s3=s-n2;
5825     int_linsolve_l(m,m_l,m_c,a,a_l,a_c,a,a_l,a_c,n2,n2,p); // find A1
5826     int_linsolve_l(m,m_l,m_c,a,a_l+n2,a_c,a,a_l+n2,a_c,s3,n2,p); // find A2
5827     // transpose A1 to tmp
5828     // A3 -= L2*A1
5829     in_mmult_mod(m,tmp,a,a_l+n2,a_c,p,m_l+n2,m_l+n,m_c,m_c+n2,false);
5830     // find A3
5831     int_linsolve_l(m,m_l+n2,m_c+n2,a,a_l+n2,a_c,a,a_l+n2,a_c,n2,n3,p);
5832     // transpose A2 to tmp
5833     // A4 -= L2*A2
5834     in_mmult_mod(m,tmp,a,a_l+n2,a_c+n2,p,m_l+n2,m_l+n,m_c,m_c+n2,false);
5835     // find A4
5836     int_linsolve_l(m,m_l+n2,m_c+n2,a,a_l+n2,a_c+n2,a,a_l+n2,a_c+n2,s3,n3,p);
5837   }
5838   */
5839 
5840   // solve triangular system a*u=y where u is the upper part of a lu decomp in m
5841   // (like int_linsolve_l with transposed u)
5842   // the answer is temporarily stored in a vector<longlong> that should be coerced
5843   // to a vector<int> and put at the right place
int_linsolve_u(const vector<vector<int>> & m,int l,int c,const vector<int> & y,vector<longlong> & a,int p)5844   void int_linsolve_u(const vector< vector<int> > & m,int l,int c,const vector<int> & y,vector<longlong> & a,int p){
5845     // a_1=y_1/m_11, a_2=(y_2-m_12*a_1)/m_22, , ak=(yk-sum_{j<k} m_jk*aj)/m_kk
5846     int n=y.size();
5847     // initialize a to y
5848     longlong * astart=&a[0], * aend=astart+n;
5849     for (int i=0;i<n;++i)
5850       a[i]=y[i];
5851     for (int j=0;j<n;++j){
5852       // at step j, aj is known
5853       longlong * ak =astart+j; // it's aj
5854       longlong & aj=*ak;
5855       const int * mjk=&m[j+l][j+c];
5856       aj = ((aj % p) * invmod(*mjk,p)) %p;
5857       // aj is now computed, substract m_jk*aj from ak for all k>j
5858       for (++mjk,++ak;ak<aend;++mjk,++ak){
5859 	*ak -= *mjk*aj;
5860       }
5861     }
5862   }
5863 
int_linsolve_u4(const vector<vector<int>> & m,int l,int c,const vector<int> & y0,const vector<int> & y1,const vector<int> & y2,const vector<int> & y3,vector<longlong> & a0,vector<longlong> & a1,vector<longlong> & a2,vector<longlong> & a3,int p)5864   void int_linsolve_u4(const vector< vector<int> > & m,int l,int c,const vector<int> & y0,const vector<int> & y1,const vector<int> & y2,const vector<int> & y3,vector<longlong> & a0,vector<longlong> & a1,vector<longlong> & a2,vector<longlong> & a3,int p){
5865     // a_1=y_1/m_11, a_2=(y_2-m_12*a_1)/m_22, , ak=(yk-sum_{j<k} m_jk*aj)/m_kk
5866     int n=y0.size();
5867     // initialize a to y
5868     longlong * a0start=&a0[0], * a0end=a0start+n;
5869     longlong * a1start=&a1[0];//, * a1end=a1start+n;
5870     longlong * a2start=&a2[0];//, * a2end=a2start+n;
5871     longlong * a3start=&a3[0];//, * a3end=a3start+n;
5872     for (int i=0;i<n;++i){
5873       a0[i]=y0[i];
5874       a1[i]=y1[i];
5875       a2[i]=y2[i];
5876       a3[i]=y3[i];
5877     }
5878     for (int j=0;j<n;++j){
5879       // at step j, aj is known
5880       longlong * a0k =a0start+j; // it's aj
5881       longlong & a0j=*a0k;
5882       longlong * a1k =a1start+j; // it's aj
5883       longlong & a1j=*a1k;
5884       longlong * a2k =a2start+j; // it's aj
5885       longlong & a2j=*a2k;
5886       longlong * a3k =a3start+j; // it's aj
5887       longlong & a3j=*a3k;
5888       const int * mjk=&m[j+l][j+c];
5889       int tmp=invmod(*mjk,p);
5890       a0j = ((a0j % p) * tmp) %p;
5891       a1j = ((a1j % p) * tmp) %p;
5892       a2j = ((a2j % p) * tmp) %p;
5893       a3j = ((a3j % p) * tmp) %p;
5894       // aj is now computed, substract m_jk*aj from ak for all k>j
5895       for (++mjk,++a0k,++a1k,++a2k,++a3k;a0k<a0end;++mjk,++a0k,++a1k,++a2k,++a3k){
5896 	tmp=*mjk;
5897 	if (!tmp) continue;
5898 	*a0k -= tmp*a0j;
5899 	*a1k -= tmp*a1j;
5900 	*a2k -= tmp*a2j;
5901 	*a3k -= tmp*a3j;
5902       }
5903     }
5904   }
5905 
double_linsolve_u(const matrix_double & m,int l,int c,const vector<double> & y,vector<double> & a)5906   void double_linsolve_u(const matrix_double & m,int l,int c,const vector<double> & y,vector<double> & a){
5907     // a_1=y_1/m_11, a_2=(y_2-m_12*a_1)/m_22, , ak=(yk-sum_{j<k} m_jk*aj)/m_kk
5908     int n=y.size();
5909     // initialize a to y
5910     double * astart=&a[0], * aend=astart+n;
5911     for (int i=0;i<n;++i)
5912       a[i]=y[i];
5913     for (int j=0;j<n;++j){
5914       // at step j, aj is known
5915       double * ak =astart+j; // it's aj
5916       double & aj=*ak;
5917       const double * mjk=&m[j+l][j+c];
5918       aj = (aj) / (*mjk);
5919       // aj is now computed, substract m_jk*aj from ak for all k>j
5920       for (++mjk,++ak;ak<aend;++mjk,++ak){
5921 	*ak -= *mjk*aj;
5922       }
5923     }
5924   }
5925 
double_linsolve_u4(const matrix_double & m,int l,int c,const vector<double> & y0,const vector<double> & y1,const vector<double> & y2,const vector<double> & y3,vector<double> & a0,vector<double> & a1,vector<double> & a2,vector<double> & a3)5926   void double_linsolve_u4(const matrix_double & m,int l,int c,const vector<double> & y0,const vector<double> & y1,const vector<double> & y2,const vector<double> & y3,vector<double> & a0,vector<double> & a1,vector<double> & a2,vector<double> & a3){
5927     // a_1=y_1/m_11, a_2=(y_2-m_12*a_1)/m_22, , ak=(yk-sum_{j<k} m_jk*aj)/m_kk
5928     int n=y0.size();
5929     // initialize a to y
5930     double * a0start=&a0[0], * a0end=a0start+n;
5931     double * a1start=&a1[0];//, * a1end=a1start+n;
5932     double * a2start=&a2[0];//, * a2end=a2start+n;
5933     double * a3start=&a3[0];//, * a3end=a3start+n;
5934     for (int i=0;i<n;++i){
5935       a0[i]=y0[i];
5936       a1[i]=y1[i];
5937       a2[i]=y2[i];
5938       a3[i]=y3[i];
5939     }
5940     for (int j=0;j<n;++j){
5941       // at step j, aj is known
5942       double * a0k =a0start+j; // it's aj
5943       double & a0j=*a0k;
5944       double * a1k =a1start+j; // it's aj
5945       double & a1j=*a1k;
5946       double * a2k =a2start+j; // it's aj
5947       double & a2j=*a2k;
5948       double * a3k =a3start+j; // it's aj
5949       double & a3j=*a3k;
5950       const double * mjk=&m[j+l][j+c];
5951       double tmp=1/(*mjk);
5952       a0j = ((a0j) * tmp) ;
5953       a1j = ((a1j) * tmp) ;
5954       a2j = ((a2j) * tmp) ;
5955       a3j = ((a3j) * tmp) ;
5956       // aj is now computed, substract m_jk*aj from ak for all k>j
5957       for (++mjk,++a0k,++a1k,++a2k,++a3k;a0k<a0end;++mjk,++a0k,++a1k,++a2k,++a3k){
5958 	tmp=*mjk;
5959 	if (!tmp) continue;
5960 	*a0k -= tmp*a0j;
5961 	*a1k -= tmp*a1j;
5962 	*a2k -= tmp*a2j;
5963 	*a3k -= tmp*a3j;
5964       }
5965     }
5966   }
5967 
5968   // if m is in lu form (first n columns), compute l^-1 mod p, then solve u*inverse=l^-1
int_lu2inv(vector<vector<int>> & m,int p,const vector<int> & permu)5969   void int_lu2inv(vector< vector<int> > & m,int p,const vector<int> & permu){
5970     int n=permu.size();
5971 #if defined( VISUALC ) || defined( BESTA_OS )
5972     int * perm=(int *)alloca(n*sizeof(int)); // perminv(permu);
5973 #else
5974     int perm[n];
5975 #endif
5976     for (int j=0;j<n;j++){
5977       perm[permu[j]]=j;
5978     }
5979     if (debug_infolevel)
5980       CERR << CLOCK()*1e-6 << " lu2inv begin n=" << n << '\n';
5981     // first step compute l^-1 this is done by the recurrence: l*a=y:
5982     // a1=y1, a2=y2-l_21*a1, ..., ak=yk-sum_{j=1..k-1}(l_kj*aj)
5983     // if y=(0,..,0,1,0,...0),
5984     // a0=..=a_{i-1}=0 and we start at equation k=i+1 and sum_{j=i...}
5985     // n^3/6 operations
5986     int i=0;
5987     for (;i<=n-4;i+=4){
5988       int * col0=&m[i][n],* col1=&m[i+1][n],* col2=&m[i+2][n],* col3=&m[i+3][n];
5989       for (int k=0;k<i+4;++k){
5990 	col0[k]=0;
5991 	col1[k]=0;
5992 	col2[k]=0;
5993 	col3[k]=0;
5994       }
5995       col0[i]=1;
5996       col0[i+1]=-m[i+1][i];
5997       col0[i+2]=(-m[i+2][i]-longlong(col0[i+1])*m[i+2][i+1])%p;
5998       col0[i+3]=(-m[i+3][i]-longlong(col0[i+1])*m[i+3][i+1]-longlong(col0[i+2])*m[i+3][i+2])%p;
5999       col1[i+1]=1;
6000       col1[i+2]=-m[i+2][i+1];
6001       col1[i+3]=(-m[i+3][i+1]-longlong(col1[i+2])*m[i+3][i+2])%p;
6002       col2[i+2]=1;
6003       col2[i+3]=-m[i+3][i+2];
6004       col3[i+3]=1;
6005       for (int k=i+4;k<n;++k){
6006 	longlong res0=0,res1=0,res2=0,res3=0;
6007 	int * mkj=&m[k][i],*col0j=col0+i,*col1j=col1+i,*col2j=col2+i,*col3j=col3+i,*col0end=col0+k;
6008 	for (;col0j<col0end;++mkj,++col3j,++col2j,++col1j,++col0j){
6009 	  longlong tmp=(*mkj);
6010 	  if (!tmp) continue;
6011 	  res0 -= tmp*(*col0j);
6012 	  res1 -= tmp*(*col1j);
6013 	  res2 -= tmp*(*col2j);
6014 	  res3 -= tmp*(*col3j);
6015 	}
6016 	*col0j=res0 % p;
6017 	*col1j=res1 % p;
6018 	*col2j=res2 % p;
6019 	*col3j=res3 % p;
6020       }
6021     }
6022     for (;i<n;++i){
6023       int * col=&m[i][n];
6024       for (int k=0;k<i;++k)
6025 	col[k]=0;
6026       col[i]=1;
6027       for (int k=i+1;k<n;++k){
6028 	longlong res=0;
6029 	int * mkj=&m[k][i],*colj=col+i,*colend=col+k;
6030 	for (;colj<colend;++mkj,++colj)
6031 	  res -= longlong(*mkj)*(*colj);
6032 	*colend=res % p;
6033       }
6034     }
6035     if (debug_infolevel)
6036       CERR << CLOCK()*1e-6 << " solving u*inv=l^-1" << '\n';
6037     // second step, solve u*inverse=l^-1, columns of l^-1 are rows of m starting at col n
6038     // we compute a column of inverse by solving the system:
6039     // u*col(inverse)=corresponding row of l^-1, and overwrite the row of l^-1 by solution
6040     // u*[x0,..,xn-1]=[a0,...,an]
6041     // x_{n-1}=a_{n-1}/u_{n-1,n-1}
6042     // x_{n-2}=(a_{n-2}-u_{n-2,n-1}*x_{n-1})/u_{n-2,n-2}
6043     // ...
6044     // x_k=(a_{k}-sum_{j=k+1..n-1} u_{k,j}x_j)/u_{k,k}
6045     // n^3/2 operations
6046     // the first i loop is unrolling
6047     i=0;
6048     for (;i<=n-4;i+=4){
6049       int * col0=&m[i][n],* col1=&m[i+1][n],* col2=&m[i+2][n],* col3=&m[i+3][n];
6050       for (int k=n-1;k>=0;--k){
6051 	longlong res0=col0[k],res1=col1[k],res2=col2[k],res3=col3[k];
6052 	int * mkj=&m[k][n-1],*col0j=col0+n-1,*colend=col0+k,*col1j=col1+n-1,*col2j=col2+n-1,*col3j=col3+n-1;
6053 	for (;col0j>colend;--mkj,--col3j,--col2j,--col1j,--col0j){
6054 	  longlong tmp=*mkj;
6055 	  if (!tmp) continue;
6056 	  res0 -= tmp*(*col0j);
6057 	  res1 -= tmp*(*col1j);
6058 	  res2 -= tmp*(*col2j);
6059 	  res3 -= tmp*(*col3j);
6060 	}
6061 	int tmp=invmod(*mkj,p);
6062 	*col0j=((res0%p)*tmp)%p;
6063 	*col1j=((res1%p)*tmp)%p;
6064 	*col2j=((res2%p)*tmp)%p;
6065 	*col3j=((res3%p)*tmp)%p;
6066       }
6067     }
6068     for (;i<n;i++){
6069       int * col=&m[i][n];
6070       for (int k=n-1;k>=0;--k){
6071 	longlong res=col[k];
6072 	int * mkj=&m[k][n-1],*colj=col+n-1,*colend=col+k;
6073 	for (;colj>colend;--mkj,--colj){
6074 	  res -= longlong(*mkj)*(*colj);
6075 	}
6076 	*colj=((res % p)*invmod(*mkj,p))%p;
6077       }
6078     }
6079     // transpose, copy to first part, clear second part
6080     int twon=2*n;
6081     for (int i=0;i<n;++i){
6082       vector<int> & mi=m[i];
6083       for (int j=n+i;j<twon;++j){
6084 	swapint(mi[j],m[j-n][i+n]);
6085       }
6086       for (int j=0;j<n;++j)
6087 	mi[j]=mi[perm[j]+n];
6088       mi.erase(mi.begin()+n,mi.end());
6089     }
6090     if (debug_infolevel)
6091       CERR << CLOCK()*1e-6 << " end lu2inv" << '\n';
6092   }
6093 
6094 #endif // GIAC_HAS_STO_38
6095 
6096 
dotvecteur(const vecteur & a,const vecteur & b,int modulo)6097   int dotvecteur(const vecteur & a,const vecteur & b,int modulo){
6098     vecteur::const_iterator ita=a.begin(), itaend=a.end();
6099     vecteur::const_iterator itb=b.begin();
6100     int res=0;
6101     for (;ita!=itaend;++ita,++itb){
6102 #ifdef _I386_
6103       mod(res,ita->val,itb->val,modulo);
6104 #else
6105       res = (res + longlong(ita->val)*itb->val) % modulo;
6106 #endif
6107     }
6108     return res;
6109   }
6110 
multmatvecteur(const matrice & a,const vecteur & b,vecteur & res,int modulo)6111   void multmatvecteur(const matrice & a,const vecteur & b,vecteur & res,int modulo){
6112     vecteur::const_iterator ita=a.begin(), itaend=a.end();
6113     res.clear();
6114     res.reserve(itaend-ita);
6115     for (;ita!=itaend;++ita)
6116       res.push_back(dotvecteur(*(ita->_VECTptr),b,modulo));
6117   }
6118 
6119   // v1=v1+c2*v2 smod modulo
modlinear_combination(vector<int> & v1,int c2,const vector<int> & v2,int modulo,int cstart,int cend,bool pseudo)6120   void modlinear_combination(vector<int> & v1,int c2,
6121 			     const vector<int> & v2,int modulo,int cstart,int cend,bool pseudo){
6122     if (c2){
6123       vector<int>::iterator it1=v1.begin()+cstart,it1end=v1.end(),it1_;
6124       if (cend && cend>=cstart && cend<it1end-v1.begin())
6125 	it1end=v1.begin()+cend;
6126       it1_=it1end-4;
6127       vector<int>::const_iterator it2=v2.begin()+cstart;
6128 #if defined(PSEUDO_MOD) && !(defined(VISUALC) || defined (BESTA_OS) || defined(OSX) || defined(OSXIOS) || defined(FIR_LINUX) || defined(FIR_ANDROID) || defined(ANDROID))
6129       c2 %= modulo;
6130       if (pseudo && (modulo<(1<<29)
6131 		     // && modulo>=(1<<16)
6132 		     )){
6133 	int nbits=sizeinbase2(modulo);
6134 	unsigned invmodulo=((1ULL<<(2*nbits)))/modulo+1;
6135 	for (;it1!=it1end;++it1,++it2)
6136 	  pseudo_mod(*it1,c2,*it2,modulo,invmodulo,nbits);
6137       }
6138       else
6139 #endif // PSEUDO_MOD
6140 	{
6141 	  //longlong C2=c2;
6142 	  for (;it1<it1_;){
6143 #ifdef _I386_
6144 	    // *it1=( (*it1) + (longlong) c2*(*it2)) % modulo ; // replace smod
6145 	    mod(*it1,c2,*it2,modulo);
6146 	    ++it1;
6147 	    ++it2;
6148 	    mod(*it1,c2,*it2,modulo);
6149 	    ++it1;
6150 	    ++it2;
6151 	    mod(*it1,c2,*it2,modulo);
6152 	    ++it1;
6153 	    ++it2;
6154 	    mod(*it1,c2,*it2,modulo);
6155 	    ++it1;
6156 	    ++it2;
6157 #else
6158 	    *it1=( (*it1) + longlong(c2)*(*it2)) % modulo ; // replace smod
6159 	    ++it1;
6160 	    ++it2;
6161 	    *it1=( (*it1) + longlong(c2)*(*it2)) % modulo ;
6162 	    ++it1;
6163 	    ++it2;
6164 	    *it1=( (*it1) + longlong(c2)*(*it2)) % modulo ;
6165 	    ++it1;
6166 	    ++it2;
6167 	    *it1=( (*it1) + longlong(c2)*(*it2)) % modulo ;
6168 	    ++it1;
6169 	    ++it2;
6170 #endif
6171 	  }
6172 	  for (;it1!=it1end;++it1,++it2){
6173 #ifdef _I386_
6174 	    // *it1=( (*it1) + (longlong) c2*(*it2)) % modulo ; // replace smod
6175 	    mod(*it1,c2,*it2,modulo);
6176 #else
6177 	    *it1=( (*it1) + longlong(c2)*(*it2)) % modulo ; // replace smod
6178 #endif
6179 	  }
6180 	}
6181     }
6182   }
6183 
6184   // v1=v1+c2*v2
modlinear_combination(vector<longlong> & v1,int c2,const vector<longlong> & v2,int modulo,int cstart,int cend)6185   void modlinear_combination(vector<longlong> & v1,int c2,const vector<longlong> & v2,int modulo,int cstart,int cend){
6186     if (c2){
6187       longlong * it1=&v1.front()+cstart,*it1end=&v1.front()+v1.size(),*it1_;
6188       if (cend && cend>=cstart && cend<it1end-&v1.front())
6189 	it1end=&v1.front()+cend;
6190       it1_=it1end-4;
6191       const longlong * it2=&v2.front()+cstart;
6192       for (;it1<=it1_;it1+=4,it2+=4){
6193 	*it1 += c2*(*it2);
6194 	it1[1] += c2*it2[1];
6195 	it1[2] += c2*it2[2];
6196 	it1[3] += c2*it2[3];
6197       }
6198       for (;it1!=it1end;++it1,++it2){
6199 	*it1 += c2*(*it2);
6200       }
6201     }
6202   }
6203 
matrice2std_matrix_gen(const matrice & m,std_matrix<gen> & M)6204   void matrice2std_matrix_gen(const matrice & m,std_matrix<gen> & M){
6205     int n=int(m.size());
6206     M.clear();
6207     M.reserve(n);
6208     for (int i=0;i<n;++i)
6209       M.push_back(*m[i]._VECTptr);
6210   }
6211 
std_matrix_gen2matrice(const std_matrix<gen> & M,matrice & m)6212   void std_matrix_gen2matrice(const std_matrix<gen> & M,matrice & m){
6213     int n=int(M.size());
6214     m.clear();
6215     m.reserve(n);
6216     for (int i=0;i<n;++i)
6217       m.push_back(M[i]);
6218   }
6219 
vecteur2index(const vecteur & v,index_t & i)6220   bool vecteur2index(const vecteur & v,index_t & i){
6221     i.clear();
6222     const_iterateur it=v.begin(),itend=v.end();
6223     for (;it!=itend;++it){
6224       if (it->type!=_INT_)
6225 	return false;
6226       i.push_back(it->val);
6227     }
6228     return true;
6229   }
6230 
print_debug_info(const gen & pivot)6231   static void print_debug_info(const gen & pivot){
6232     if ( (pivot.type==_POLY) && !pivot._POLYptr->coord.empty())
6233       CERR << "poly(" << sum_degree(pivot._POLYptr->coord.front().index) << "," << pivot._POLYptr->coord.size() << ") ";
6234     else
6235       CERR << pivot << " ";
6236   }
6237 
is_mod_vecteur(const vecteur & m,vector<int> & v,int & p)6238   bool is_mod_vecteur(const vecteur & m,vector<int> & v,int & p){
6239     v.clear();
6240     v.reserve(m.size());
6241     const_iterateur it=m.begin(),itend=m.end();
6242     for (;it!=itend;++it){
6243       if (it->type==_MOD){
6244 	if (!p)
6245 	  p=(it->_MODptr+1)->val;
6246 	if (*(it->_MODptr+1)!=p)
6247 	  return false;
6248 	v.push_back(it->_MODptr->val);
6249 	continue;
6250       }
6251       if (it->is_symb_of_sommet(at_normalmod)){
6252 	const gen & f=it->_SYMBptr->feuille;
6253 	if (f.type!=_VECT || f._VECTptr->size()!=2 || f._VECTptr->front().type!=_INT_ || f._VECTptr->back().type!=_INT_)
6254 	  return false;
6255 	if (!p)
6256 	  p=f._VECTptr->back().val;
6257 	if (f._VECTptr->back().val!=p)
6258 	  return false;
6259 	v.push_back(f._VECTptr->front().val);
6260 	continue;
6261       }
6262       if (it->type!=_INT_) return false;
6263       v.push_back(it->val);
6264     }
6265     return true;
6266   }
6267 
is_mod_matrice(const matrice & m,vector<vector<int>> & M,int & p)6268   bool is_mod_matrice(const matrice & m,vector< vector<int> > & M,int & p){
6269     const_iterateur it=m.begin(),itend=m.end();
6270     M.clear();
6271     M.reserve(m.size());
6272     for (;it!=itend;++it){
6273       M.push_back(vector<int>(0));
6274       if (it->type!=_VECT || !is_mod_vecteur(*it->_VECTptr,M.back(),p))
6275 	return false;
6276     }
6277     return true;
6278   }
6279 
is_integer_vecteur(const vecteur & m,bool intonly)6280   bool is_integer_vecteur(const vecteur & m,bool intonly){
6281     const_iterateur it=m.begin(),itend=m.end();
6282     for (;it!=itend;++it){
6283       if (it->type==_INT_) continue;
6284       if (intonly) return false;
6285       if (it->type==_ZINT) continue;
6286       if (it->type==_CPLX && is_integer(*it->_CPLXptr) && is_exactly_zero(*(it->_CPLXptr+1))) continue;
6287       return false;
6288       // if (!is_integer(*it)) return false;
6289     }
6290     return true;
6291   }
6292 
is_integer_matrice(const matrice & m,bool intonly)6293   bool is_integer_matrice(const matrice & m,bool intonly){
6294     const_iterateur it=m.begin(),itend=m.end();
6295     for (;it!=itend;++it)
6296       if (it->type!=_VECT || !is_integer_vecteur(*it->_VECTptr,intonly)) return false;
6297     return true;
6298   }
6299 
is_fraction_vecteur(const vecteur & m)6300   bool is_fraction_vecteur(const vecteur & m){
6301     const_iterateur it=m.begin(),itend=m.end();
6302     for (;it!=itend;++it)
6303       if (it->type!=_FRAC && !is_integer(*it)) return false;
6304     return true;
6305   }
6306 
is_fraction_matrice(const matrice & m)6307   bool is_fraction_matrice(const matrice & m){
6308     const_iterateur it=m.begin(),itend=m.end();
6309     for (;it!=itend;++it)
6310       if (it->type!=_VECT || !is_fraction_vecteur(*it->_VECTptr)) return false;
6311     return true;
6312   }
6313 
modproduct(const vecteur & v,const gen & modulo)6314   gen modproduct(const vecteur & v, const gen & modulo){
6315     const_iterateur it=v.begin(),itend=v.end();
6316     gen res(1);
6317     for (;it!=itend;++it){
6318       res = smod(res * (*it),modulo);
6319     }
6320     return res;
6321   }
6322 
untrunc1(const gen & g)6323   static gen untrunc1(const gen & g){
6324     if (g.type==_FRAC)
6325       return fraction(untrunc1(g._FRACptr->num),untrunc1(g._FRACptr->den));
6326     return g.type==_POLY?g._POLYptr->untrunc1():g;
6327   }
6328 
fracmod(const vecteur & v,const gen & modulo,gen * den,int prealloc)6329   vecteur fracmod(const vecteur & v,const gen & modulo,gen * den,int prealloc){
6330     mpz_t u,d,u1,d1,absd1,sqrtm,q,ur,r,tmp;
6331     mpz_init2(u,prealloc);
6332     mpz_init2(d,prealloc);
6333     mpz_init2(u1,prealloc);
6334     mpz_init(d1);
6335     mpz_init(absd1);
6336     mpz_init(sqrtm);
6337     mpz_init(q);
6338     mpz_init2(ur,prealloc);
6339     mpz_init2(r,prealloc);
6340     mpz_init2(tmp,prealloc);
6341     gen g;
6342     const_iterateur it=v.begin(),itend=v.end();
6343     vecteur res;
6344     res.reserve(itend-it);
6345     int s=sizeinbase2(modulo);
6346     for (;it!=itend;++it){
6347       if (it->type==_VECT)
6348 	res.push_back(fracmod(*it->_VECTptr,modulo,den,prealloc));
6349       else {
6350 	if (den){
6351 	  g=smod(*den**it,modulo);
6352 	  if (2*sizeinbase2(g)<s){
6353 	    res.push_back(g/ *den);
6354 	    continue;
6355 	  }
6356 	}
6357 	bool b=alloc_fracmod(*it,modulo,g,d,d1,absd1,u,u1,ur,q,r,sqrtm,tmp);
6358 	res.push_back(g);
6359 	if (den && g.type==_FRAC)
6360 	  *den=lcm(*den,g._FRACptr->den);
6361       }
6362     }
6363     mpz_clear(d);
6364     mpz_clear(u);
6365     mpz_clear(u1);
6366     mpz_clear(d1);
6367     mpz_clear(absd1);
6368     mpz_clear(sqrtm);
6369     mpz_clear(q);
6370     mpz_clear(ur);
6371     mpz_clear(r);
6372     mpz_clear(tmp);
6373     return res;
6374   }
6375 
6376   // Find next prime not dividing primewith
nextp(const gen & p0,const gen & primewith)6377   gen nextp(const gen &p0,const gen & primewith){
6378     for (gen p=p0;;){
6379       p=nextprime(p+1);
6380       if (is_one(gcd(primewith,p))) // keep p prime with invariant factor (divisor of det)
6381 	return p;
6382     }
6383   }
6384 
6385   struct thread_modrref_t {
6386     const matrice * aptr;
6387     vector< vector<int> > * Nptr;
6388     matrice * resptr;
6389     vecteur * pivotsptr;
6390     smallmodrref_temp_t * workptr;
6391     gen det,mult_by_det_mod_p;
6392     int l,lmax,c,cmax,fullreduction,dont_swap_below,Modulo,carac,rref_or_det_or_lu;
6393     bool inverting,no_initial_mod,success;
6394   };
6395 
thread_modrref(void * ptr_)6396   void * thread_modrref(void * ptr_){
6397     thread_modrref_t * ptr = (thread_modrref_t *)(ptr_);
6398     ptr->success=in_modrref(*ptr->aptr, *ptr->Nptr,*ptr->resptr, *ptr->pivotsptr, ptr->det,ptr->l, ptr->lmax, ptr->c,ptr->cmax,ptr->fullreduction,ptr->dont_swap_below,ptr->Modulo,ptr->carac,ptr->rref_or_det_or_lu,ptr->mult_by_det_mod_p,ptr->inverting,ptr->no_initial_mod,ptr->workptr);
6399     return ptr;
6400   }
6401 
6402 #ifndef CLOCKS_PER_SEC
6403 #define CLOCKS_PER_SEC 1e6
6404 #endif
6405 
6406 #ifndef GIAC_HAS_STO_38
mrref_int(const matrice & a,matrice & res,vecteur & pivots,gen & det,int l,int lmax,int c,int cmax,int fullreduction,int dont_swap_below,bool convert_internal,int algorithm,int rref_or_det_or_lu,int modular,vector<int> & permutation,GIAC_CONTEXT)6407   static int mrref_int(const matrice & a, matrice & res, vecteur & pivots, gen & det,int l, int lmax, int c,int cmax,
6408 			int fullreduction,int dont_swap_below,bool convert_internal,int algorithm,int rref_or_det_or_lu,
6409 			int modular,vector<int> & permutation,
6410 			GIAC_CONTEXT){
6411     gen linfa=linfnorm(a,contextptr);
6412     unsigned as=a.size();//,a0s=a.front()._VECTptr->size();
6413     res.clear(); // insure that res will be build properly
6414     // Modular algorithm for matrix integer reduction
6415     // Find Hadamard bound
6416     if (debug_infolevel>1)
6417       CERR << "rref padic/modular " << CLOCK()*1e-6 << '\n';
6418     bool inverting=fullreduction==2;
6419     gen h2=4*square_hadamard_bound(a),h20=h2;
6420     if (debug_infolevel>1)
6421       CERR << "rref padic hadamard done " << CLOCK()*1e-6 << '\n';
6422     gen p,det_mod_p,pi_p;
6423     int done=0;
6424     bool failure=false;
6425     gen factdet(1); // find a divisor of the determinant
6426     // by solving a random linear system having a as matrix
6427     // using a p-adic method
6428 #if 1 // def _I386_
6429     double p0=3037000500./std::sqrt(double(as))/5.; // so that p0^2*rows(a)<2^63
6430 #else
6431     double p0=46340./std::sqrt(double(as))/5.; // so that p0^2*rows(a)<2^31
6432 #endif
6433     gen ainf=linfnorm(a,context0);
6434     if (is_zero(ainf)){
6435       res=a; det=0; return 1;
6436     }
6437     if (ainf.type==_INT_){ // insure that ||a||_inf*p*rows(a)<2^63
6438       double p1=((((ulonglong) 1)<<63)/ainf.val)/as;
6439       if (p1<p0)
6440 	p0=p1*0.99; // since we make a nextprime...
6441     }
6442     else { // insure that p^2*rows(a)*(2+ln(||a||_inf)/ln(p))<2^63
6443       double n=std::ceil(mpz_sizeinbase(*ainf._ZINTptr,2)/21.); // assumes p>2^21
6444       double p1=std::sqrt((1ULL << 62)/(n+2)/as);
6445       if (p1<(1<<21))
6446 	failure=true;
6447       if (p1<p0)
6448 	p0=p1*.9;
6449     }
6450     p=nextprime(int(p0));
6451     vector< vector<int> > N;
6452     if (!failure && modular==2){ // rref is like linsolve
6453       matrice A(mtran(a));
6454       vecteur b=*A.back()._VECTptr,x;
6455       A.pop_back();
6456       A=mtran(A);
6457       int done=padic_linsolve(A,b,x,p,det,h2);
6458       if (done>0){
6459 	res=midn(as);
6460 	res.push_back(x);
6461 	res=mtran(res);
6462 	return 1;
6463       }
6464       failure=true;
6465     }
6466     if (!failure && (as>=GIAC_PADIC || algorithm==RREF_PADIC)){
6467       vecteur b(vranm(as,8,contextptr)),resb;
6468       // reconstruct (at most) 12 components of res for lcm
6469       // this should give the last invariant factor (estimated proba 0.998)
6470       if ( (done=padic_linsolve(a,b,resb,p,det,h2,inverting?12:6)) ){
6471 	if (done==-1){
6472 	  det=0;
6473 	  return 1;
6474 	}
6475 	lcmdeno(resb,factdet,contextptr);
6476 	if (debug_infolevel>2)
6477 	  CERR << "lif=" << factdet << '\n';
6478 	h2=iquo(h2,factdet*factdet)+1;
6479 	det=smod(det*invmod(factdet,p),p);
6480 	pi_p=p;
6481       }
6482     }
6483 #ifdef GIAC_DETBLOCK
6484     p=nextp(int(536870923./std::sqrt(double(mmult_int_blocksize))),factdet);
6485 #else
6486     p=nextp(536870923,factdet);
6487 #endif
6488 #ifdef HAVE_LIBPTHREAD
6489     // initialize/alloc nthreads-1 copies of N, res, pivots
6490     int nthreads=threads_allowed?threads:1;
6491     pthread_t tab[nthreads-1];
6492 #ifdef __clang__
6493     vector< vector<int> > *Nptr = (vector< vector<int> > *)alloca((nthreads-1)*sizeof(vector< vector<int> >));
6494     matrice *resptr = (matrice *)alloca((nthreads-1)*sizeof(matrice));
6495     vecteur *pivotsptr = (vecteur *)alloca((nthreads-1)*sizeof(vecteur));
6496     smallmodrref_temp_t *work = (smallmodrref_temp_t *)alloca(nthreads*sizeof(smallmodrref_temp_t));
6497 #else
6498     vector< vector<int> > Nptr[nthreads-1];
6499     matrice resptr[nthreads-1];
6500     vecteur pivotsptr[nthreads-1];
6501     smallmodrref_temp_t work[nthreads];
6502 #endif
6503     for (int i=0;i<nthreads;++i){
6504 #ifdef __clang__
6505       new (&work[i]) smallmodrref_temp_t();
6506 #endif
6507       work[i].Ainv=vector< vector<int> >(mmult_int_blocksize,vector<int>(2*mmult_int_blocksize));
6508       work[i].Ainvtran=vector< vector<int> >(mmult_int_blocksize,vector<int>(mmult_int_blocksize));
6509       work[i].CAinv=vector< vector<int> >(mmult_int_blocksize,vector<int>(mmult_int_blocksize));
6510       work[i].pivblock.reserve(mmult_int_blocksize+1);
6511     }
6512 #ifdef __clang__
6513     thread_modrref_t *modrrefparam = (thread_modrref_t *)alloca((nthreads-1)*sizeof(thread_modrref_t));
6514 #else
6515     thread_modrref_t modrrefparam[nthreads-1];
6516 #endif
6517     for (int i=0;i<nthreads-1;++i){
6518       Nptr[i]=vector< vector<int> >(a.size(),vector<int>(cmax));
6519       resptr[i]=matrice(a.size());
6520       for (unsigned j=0;j<a.size();j++)
6521 	resptr[i][j]=vecteur(cmax);
6522       pivotsptr[i]=pivots;
6523       pivotsptr[i].reserve(a.size());
6524       thread_modrref_t tmp={&a,&Nptr[i],&resptr[i],&pivotsptr[i],&work[i],0,1,l,lmax,c,cmax,fullreduction,dont_swap_below,0,-1,rref_or_det_or_lu,inverting,false,false};
6525       modrrefparam[i]=tmp;
6526     }
6527 #endif
6528     if (!failure){
6529       double proba=1.0;
6530       if (!done){
6531 	pi_p=p;
6532 	if (!in_modrref(a,N,res,pivots,det,l,lmax,c,cmax,
6533 			0 /* fullreduction */,dont_swap_below,p.val,-1/* carac*/,1 /* det */,1 /* mult by 1*/,false/* inverting */,true/* no initial mod */,
6534 #ifdef HAVE_LIBPTHREAD
6535 			&work[nthreads-1]
6536 #else
6537 			0
6538 #endif
6539 			)
6540 	    )
6541 	  return 0;
6542       }
6543       // First find det to avoid bad primes
6544       int initial_clock=CLOCK();
6545       int dbglevel=debug_infolevel;
6546       for (;is_strictly_greater(h2,pi_p*pi_p,contextptr);){
6547 #ifdef HAVE_LIBPTHREAD
6548 	for (int j=0;j<nthreads-1;j++){
6549 	  p=nextp(p+1,factdet);
6550 	  modrrefparam[j].cmax=cmax;
6551 	  modrrefparam[j].Modulo=p.val;
6552 	  modrrefparam[j].fullreduction=0;
6553 	  modrrefparam[j].rref_or_det_or_lu=1;
6554 	  modrrefparam[j].inverting=false;
6555 	  modrrefparam[j].no_initial_mod=true;
6556 	  modrrefparam[j].mult_by_det_mod_p=1;
6557 	  bool res=pthread_create(&tab[j],(pthread_attr_t *) NULL,thread_modrref,(void *) &modrrefparam[j]);
6558 	  if (res)
6559 	    thread_modrref((void *)&modrrefparam[j]);
6560 	}
6561 #endif
6562 	p=nextp(p+1,factdet);
6563 	gen current_estimate=evalf_double(_evalf(gen(makevecteur(200*ln(pi_p,contextptr)/ln(h2,contextptr),20),_SEQ__VECT),contextptr),1,contextptr);
6564 	if (as>10 && dbglevel<2 && CLOCK()-initial_clock>min_proba_time*CLOCKS_PER_SEC)
6565 	  dbglevel=2;
6566 	if (as>10 && dbglevel>1){
6567 	  CERR << CLOCK()*1e-6 << " detrref, % done " << current_estimate << ", prime " << p << (proba<1e-10?" stable":" unstable");
6568 	  if (dbglevel>3)
6569 	    CERR << ", det/lif=" << det ;
6570 	  CERR << '\n';
6571 	}
6572 	if (!in_modrref(a,N,res,pivots,det_mod_p,l,lmax,c,cmax,
6573 			0 /* fullreduction */,dont_swap_below,p.val,-1/*carac*/,1 /* det */,1 /* mult by 1*/,false /* inverting */,true/* no initial mod */,
6574 #ifdef HAVE_LIBPTHREAD
6575 			&work[nthreads-1]
6576 #else
6577 			0
6578 #endif
6579 			)){
6580 	  // FIXME clean launched threads
6581 	  return 0;
6582 	}
6583 	if (dbglevel>2)
6584 	  CERR << CLOCK()*1e-6 << " end rref " << '\n';
6585 #ifdef HAVE_LIBPTHREAD
6586 	// get back launched mod det
6587 	for (int j=0;j<nthreads-1;++j){
6588 	  void * ptr;
6589 	  pthread_join(tab[j],&ptr);
6590 	  if (ptr && modrrefparam[j].success){
6591 	    gen tmpp=modrrefparam[j].Modulo;
6592 	    gen tmpdet_mod_p=smod(modrrefparam[j].det*invmod(factdet,tmpp),tmpp);
6593 	    gen old_det=det;
6594 	    det=ichinrem(det,tmpdet_mod_p,pi_p,tmpp);
6595 	    pi_p=pi_p*tmpp;
6596 	    if (old_det==det)
6597 	      proba=proba/evalf_double(p,1,contextptr)._DOUBLE_val;
6598 	    else
6599 	      proba=1.0;
6600 	  }
6601 	}
6602 #endif
6603 	det_mod_p=smod(det_mod_p*invmod(factdet,p),p);
6604 	gen old_det=det;
6605 	det=ichinrem(det,det_mod_p,pi_p,p);
6606 	pi_p=pi_p*p;
6607 	if (old_det==det)
6608 	  proba=proba/evalf_double(p,1,contextptr)._DOUBLE_val;
6609 	else
6610 	  proba=1.0;
6611 	if (proba<proba_epsilon(contextptr) && is_greater(70,current_estimate,contextptr) && CLOCK()-initial_clock>min_proba_time*CLOCKS_PER_SEC)
6612 	  break;
6613       } // end loop h2>pi_p^2
6614       det=smod(det,pi_p)*factdet;
6615       if (rref_or_det_or_lu==1){
6616 	if (is_strictly_greater(h2,pi_p*pi_p,contextptr))
6617 	  *logptr(contextptr) << gettext("Probabilistic algorithm for determinant\n(run proba_epsilon:=0 for a deterministic answer, this is slower).\nError probability is less than ") << proba << '\n';
6618 	return 1;
6619       }
6620       h2=h20;
6621       if (is_zero(det,contextptr))
6622 	failure=true;
6623     }
6624     if (!failure){
6625       // Improve: currently permutation should always be the idn for lu
6626       // instead of by det (det works for rref)
6627       if (rref_or_det_or_lu==2){
6628 	rref_or_det_or_lu=3;
6629 	h2=h2*h2; // need to square for LU decomp (rational reconstruction)
6630       }
6631       if (inverting){
6632 	fullreduction=0;
6633 	rref_or_det_or_lu=2;
6634 	cmax=lmax;
6635 	p=nextprime(p+1);
6636       }
6637       else {
6638 	// Now do the reduction again, avoiding bad primes
6639 #if 1
6640 	p=536870923;
6641 #else
6642 	p=36007;
6643 #endif
6644       }
6645       gen q;
6646       while (is_zero(irem(det,p,q),contextptr))
6647 	p=nextprime(p+1);
6648       pi_p=p;
6649       gen det1;
6650       if (!in_modrref(a,N,res,pivots,det1,l,lmax,c,cmax,
6651 		      fullreduction,dont_swap_below,p.val,-1/*carac*/,rref_or_det_or_lu,(inverting || rref_or_det_or_lu==0)?det:1,true /* inverting */,true/* no initial mod */,0/*workptr*/))
6652 	return 0;
6653 #if 1
6654       // uncoerce elements of res and prealloc size of integers
6655       // might perhaps improve chinese remaindering by divide and conquer?
6656       unsigned prealloc=h2.type==_ZINT?mpz_sizeinbase(*h2._ZINTptr,2)/2:128;
6657       for (unsigned i=0;i<res.size();++i){
6658 	iterateur it=res[i]._VECTptr->begin(),itend=res[i]._VECTptr->end();
6659 	for (;it!=itend;++it)
6660 	  uncoerce(*it,prealloc);
6661       }
6662 #endif
6663       // Multiply res by product of pivots in order to have the det
6664       // as initial non-zero element of each line after the reduction
6665       // if (rref_or_det_or_lu==0) res=smod(multvecteur(det,res),p);
6666       matrice res_mod_p,pivots_mod_p;
6667       for (;is_strictly_greater(h2,pi_p*pi_p,contextptr);){
6668 #ifdef HAVE_LIBPTHREAD
6669 	for (int j=0;j<nthreads-1;j++){
6670 	  p=nextprime(p+1);
6671 	  while (is_zero(irem(det,p,q),contextptr))
6672 	    p=nextprime(p+1);
6673 	  if (p.type!=_INT_)
6674 	    break;
6675 	  modrrefparam[j].cmax=cmax;
6676 	  modrrefparam[j].Modulo=p.val;
6677 	  modrrefparam[j].fullreduction=fullreduction;
6678 	  modrrefparam[j].rref_or_det_or_lu=rref_or_det_or_lu;
6679 	  modrrefparam[j].inverting=true;
6680 	  modrrefparam[j].no_initial_mod=true;
6681 	  gen tmp=(inverting || rref_or_det_or_lu==0)?det:1;
6682 	  modrrefparam[j].mult_by_det_mod_p=tmp;
6683 	  bool res=pthread_create(&tab[j],(pthread_attr_t *) NULL,thread_modrref,(void *) &modrrefparam[j]);
6684 	  if (res)
6685 	    thread_modrref((void *)&modrrefparam[j]);
6686 	}
6687 #endif
6688 	p=nextprime(p+1);
6689 	while (is_zero(irem(det,p,q),contextptr))
6690 	  p=nextprime(p+1);
6691 	if (p.type!=_INT_)
6692 	  break;
6693 	if (!in_modrref(a,N,res_mod_p,pivots_mod_p,det_mod_p,l,lmax,c,cmax,
6694 			fullreduction,dont_swap_below,p.val,-1/*carac*/,rref_or_det_or_lu,(inverting || rref_or_det_or_lu==0)?det:1,true /* inverting */,true/* no initial mod */,0/*workptr*/))
6695 	  return 0;
6696 #ifdef HAVE_LIBPTHREAD
6697 	// get back launched mod det
6698 	for (int j=0;j<nthreads-1;++j){
6699 	  void * ptr;
6700 	  pthread_join(tab[j],&ptr);
6701 	  if (ptr && modrrefparam[j].success){
6702 	    if (rref_or_det_or_lu==3 && is_zero(det_mod_p,contextptr)){
6703 	      continue;
6704 	    }
6705 	    gen tmpp=modrrefparam[j].Modulo;
6706 	    ichinrem_inplace(res,*modrrefparam[j].resptr,pi_p,tmpp.val,fullreduction);
6707 	    if (fullreduction!=2 && !inverting)
6708 	      pivots=*ichinrem(gen(pivots),gen(*modrrefparam[j].pivotsptr),pi_p,tmpp)._VECTptr;
6709 	    pi_p=pi_p*tmpp;
6710 	  }
6711 	}
6712 #endif
6713 	if (as>10 && debug_infolevel>1)
6714 	  CERR << CLOCK()*1e-6 << " modrref, % done " << evalf_double(_evalf(gen(makevecteur(200*ln(pi_p,contextptr)/ln(h2,contextptr),20),_SEQ__VECT),contextptr),1,contextptr)<< ", prime " << p << '\n';
6715 	if (rref_or_det_or_lu==3){
6716 	  if (is_zero(det_mod_p,contextptr))
6717 	    continue;
6718 	}
6719 	/*
6720 	  else {
6721 	  multvecteur(smod(det,p),res_mod_p,res_mod_p);
6722 	  smod(res_mod_p,p,res_mod_p);
6723 	  // res_mod_p=smod(multvecteur(smod(det,p),res_mod_p),p);
6724 	  }
6725 	*/
6726 #if 0
6727 	res=*ichinrem(gen(res),gen(res_mod_p),pi_p,p)._VECTptr;
6728 #else
6729 	ichinrem_inplace(res,res_mod_p,pi_p,p.val,fullreduction);
6730 #endif
6731 	if (fullreduction!=2 && !inverting)
6732 	  pivots=*ichinrem(gen(pivots),gen(pivots_mod_p),pi_p,p)._VECTptr;
6733 	pi_p=pi_p*p;
6734 	if (inverting){
6735 	  // early termination if abs(det*2)<pi_p and linfnorm(res)*linfnorm(original_matrix)*size*2<pi_p
6736 	  // smod_inplace(res,pi_p);
6737 	  if (is_greater(pi_p,2*abs(det,contextptr),contextptr) && is_greater(pi_p,2*linfnorm(res,contextptr)*linfa,contextptr)){
6738 	    if (debug_infolevel>2)
6739 	      *logptr(contextptr) << CLOCK()*1e-6 << gettext(" Early termination") << '\n';
6740 	    break;
6741 	  }
6742 	}
6743       } // end for loop on primes
6744       if (p.type==_INT_){
6745 	// there is a bug in libtommath when multiplying a _ZINT by an int
6746 	// because used memory might grow by 2, not only by 1
6747 	// in bn_mp_mul_d.c
6748 	smod_inplace(res,pi_p);
6749 	if (inverting){
6750 	  // This step could perhaps be a little faster if we keep
6751 	  // the last invariant factor (as computed by the p-adic algorihtm)
6752 	  // since the denominator is likely (about 6/pi^2) to be the lif
6753 	  // therefore we could compute divisor=det/lif and test divisibility
6754 	  // of res by divisor
6755 	  if (debug_infolevel>2)
6756 	    *logptr(contextptr) << CLOCK()*1e-6 << gettext(" dividing by determinant") << '\n';
6757 	  divvecteur(res,det,res);
6758 	  if (debug_infolevel>2)
6759 	    *logptr(contextptr) << CLOCK()*1e-6 << gettext(" end dividing by determinant") << '\n';
6760 	}
6761 	else
6762 	  pivots=smod(pivots,pi_p);
6763 	if (rref_or_det_or_lu==3) // rational reconstruction
6764 	  res=fracmod(res,pi_p);
6765 	if (rref_or_det_or_lu==2 || rref_or_det_or_lu == 3){
6766 	  vecteur P;
6767 	  vector_int2vecteur(permutation,P);
6768 	  pivots.push_back(P);
6769 	}
6770 	return inverting?2:1;
6771       } // end if p.type==_INT_
6772     } // end if !failure
6773     return -1;
6774   } // end modular/padic algorithm
6775 #endif // GIAC_HAS_STO_38
6776 
6777   // find lvar after doing halftan/tsimplify
alg_lvar_halftan_tsimplify(vecteur & res,vecteur & lv,GIAC_CONTEXT)6778   void alg_lvar_halftan_tsimplify(vecteur & res,vecteur & lv,GIAC_CONTEXT){
6779     lv=alg_lvar(res);
6780     if (!lv.empty() && lv.front().type==_VECT && lv.front()._VECTptr->size()>1){
6781       vecteur lw=*halftan(lv.front(),contextptr)._VECTptr;
6782       if (lvar(lw).size()<lv.front()._VECTptr->size()){
6783 	res=*subst(gen(res),lv.front(),lw,false,contextptr)._VECTptr;
6784 	lv=alg_lvar(res);
6785       }
6786       if (!lv.empty() && lv.front().type==_VECT && lv.front()._VECTptr->size()>1){
6787 	lw=*tsimplify(lv.front(),contextptr)._VECTptr;
6788 	if (lvar(lw).size()<lv.front()._VECTptr->size()){
6789 	  res=*subst(gen(res),lv.front(),lw,false,contextptr)._VECTptr;
6790 	  lv=alg_lvar(res);
6791 	}
6792       }
6793     }
6794   }
6795 
betterpivot(const gen & a,const gen & b,bool num_mat,GIAC_CONTEXT)6796   bool betterpivot(const gen & a,const gen &b,bool num_mat,GIAC_CONTEXT){
6797     if (num_mat && a.type<=_CPLX && b.type<=_CPLX){
6798       gen A=evalf_double(a,1,contextptr),B=evalf_double(b,1,contextptr);
6799       if ( (A.type==_DOUBLE_ || A.type==_CPLX) && (B.type==_DOUBLE_ || B.type==_CPLX))
6800 	return is_strictly_greater(abs(A),abs(B),contextptr);
6801     }
6802     return a.islesscomplexthan(b);
6803   }
6804 
rref_reduce(std_matrix<gen> & M,vecteur & pivots,vector<int> & permutation,gen & det,gen & detnum,int algorithm,int l,int lmax,int c,int cmax,int dont_swap_below,int rref_or_det_or_lu,int fullreduction,double eps,bool step_rref,const vecteur & lv,bool convert_internal,bool num_mat,GIAC_CONTEXT)6805   int rref_reduce(std_matrix<gen> &M,vecteur & pivots,vector<int> & permutation,gen & det,gen &detnum,int algorithm,int l,int lmax,int c,int cmax,int dont_swap_below,int rref_or_det_or_lu,int fullreduction,double eps,bool step_rref,const vecteur &lv,bool convert_internal,bool num_mat,GIAC_CONTEXT){
6806     int linit=l;
6807     gen bareiss (1),invbareiss(1),pivot,temp;
6808     int pivotline,pivotcol;
6809     matrice res;
6810     int status=2;
6811     for (;(l<lmax) && (c<cmax);){
6812 #ifdef TIMEOUT
6813       control_c();
6814 #endif
6815       if (ctrl_c || interrupted)
6816 	return 0;
6817       if ( (!fullreduction) && (l==lmax-1) )
6818 	break;
6819       if (debug_infolevel>2)
6820 	CERR <<  "// mrref line " << l << ":" << CLOCK()*1e-6 <<'\n';
6821       pivot=M[l][c];
6822       if (debug_infolevel>2){
6823 	CERR << "// ";
6824 	print_debug_info(pivot);
6825       }
6826       pivotline=l;
6827       pivotcol=c;
6828       if (l<dont_swap_below){ // scan current line for the best pivot available
6829 	for (int ctemp=c+1;ctemp<cmax;++ctemp){
6830 	  temp=M[l][ctemp];
6831 	  if (debug_infolevel>2)
6832 	    print_debug_info(temp);
6833 	  if (!is_exactly_zero(temp) && betterpivot(temp,pivot,num_mat,contextptr)){
6834 	    pivot=temp;
6835 	    pivotcol=ctemp;
6836 	  }
6837 	}
6838       }
6839       else {      // scan M current column for the best pivot available
6840 	if (rref_or_det_or_lu == 3){ // LU without line permutation
6841 	  if (is_zero(pivot,contextptr)){
6842 	    det = 0;
6843 	    vecteur P;
6844 	    vector_int2vecteur(permutation,P);
6845 	    pivots.push_back(P);
6846 	    return 1;
6847 	  }
6848 	}
6849 	else {
6850 	  for (int ltemp=l+1;ltemp<lmax;++ltemp){
6851 	    temp=M[ltemp][c];
6852 	    if (debug_infolevel>2)
6853 	      print_debug_info(temp);
6854 	    if (!is_exactly_zero(temp) && (is_exactly_zero(pivot) || betterpivot(temp,pivot,num_mat,contextptr)) ){
6855 	      pivot=temp;
6856 	      pivotline=ltemp;
6857 	    }
6858 	  }
6859 	}
6860       }
6861       if (debug_infolevel>2)
6862 	CERR << '\n';
6863       //COUT << "line " << l << " pivot " << pivot << '\n';
6864       // check changed here and in remove_identity for m:=[[0.0005,0,0,-0.0005,0,0,0,1],[0,9.69696969697E-4+0.00125*i,0,-0.00125*i,-6.66666666667E-4,-3.0303030303E-4,0,0],[0,0,3.57142857143E-4-0.0025*i,0,0.0025*i,0,-3.57142857143E-4,0],[-0.0005,-0.00125*i,0,0.0005+0.00125*i,0,0,0,0],[0,-6.66666666667E-4,0.0025*i,0,6.66666666667E-4-0.0025*i,0,0,0],[0,-3.0303030303E-4,0,0,0,3.0303030303E-4-1.66666666667E-3*i,0,0],[0,0,-3.57142857143E-4,0,0,0,3.57142857143E-4+0.005*i,0],[1,0,0,0,0,0,0,0]] ; inv(m);
6865       if (!is_exactly_zero(pivot)
6866 	  //!is_zero(pivot,contextptr)
6867 	  ){
6868 	if (step_rref){
6869 	  std_matrix_gen2matrice(M,res);
6870 	  gen pivot1=pivot;
6871 	  if (convert_internal){
6872 	    res = *r2sym(res,lv,contextptr)._VECTptr;
6873 	    pivot1 = r2sym(pivot1,lv,contextptr);
6874 	  }
6875 	  gprintf(step_rrefpivot,gettext("%gen\nReduce column %gen with pivot %gen at row %gen"),makevecteur(res,c+1,pivot1,pivotline+1),contextptr);
6876 	}
6877 	// exchange lines if needed
6878 	if (l!=pivotline){
6879 	  if (step_rref){
6880 	    std_matrix_gen2matrice(M,res);
6881 	    if (convert_internal)
6882 	      res = *r2sym(res,lv,contextptr)._VECTptr;
6883 	    gprintf(step_rrefexchange,gettext("Exchange row %gen and row %gen"),makevecteur(l+1,pivotline+1),contextptr);
6884 	  }
6885 	  swap(M[l],M[pivotline]);
6886 	  swap(permutation[l],permutation[pivotline]);
6887 	  // temp = M[l];
6888 	  // M[l] = M[pivotline];
6889 	  // M[pivotline] = temp;
6890 	  detnum = -detnum;
6891 	}
6892 	// make the reduction
6893 	if (fullreduction){ // should be done after for efficiency
6894 	  for (int ltemp=linit;ltemp<lmax;++ltemp){
6895 	    if (debug_infolevel>=2)
6896 	      CERR << "// " << l << "," << ltemp << " "<< '\n';
6897 	    if (step_rref && l!=ltemp){
6898 	      std_matrix_gen2matrice(M,res);
6899 	      gen coeff1=pivot,coeff2=M[ltemp][pivotcol];
6900 	      if (algorithm==RREF_GAUSS_JORDAN){
6901 		coeff1=1; coeff2=coeff2/pivot;
6902 	      }
6903 	      if (convert_internal){
6904 		res = *r2sym(res,lv,contextptr)._VECTptr;
6905 		coeff1=r2sym(coeff1,lv,contextptr);
6906 		coeff2=r2sym(coeff2,lv,contextptr);
6907 	      }
6908 	      gprintf(step_rrefpivot0,gettext("L%gen <- (%gen)*L%gen-(%gen)*L%gen on %gen"),makevecteur(ltemp+1,coeff1,ltemp+1,coeff2,l+1,res),contextptr);
6909 	    }
6910 	    if (ltemp!=l){
6911 	      if (algorithm!=RREF_GAUSS_JORDAN) // M[ltemp] = rdiv( pivot * M[ltemp] - M[ltemp][pivotcol]* M[l], bareiss);
6912 		linear_combination(pivot,M[ltemp],-M[ltemp][pivotcol],M[l],bareiss,invbareiss,M[ltemp],eps,0);
6913 	      else // M[ltemp]=M[ltemp]-rdiv(M[ltemp][pivotcol],pivot)*M[l];
6914 		linear_combination(plus_one,M[ltemp],-rdiv(M[ltemp][pivotcol],pivot,contextptr),M[l],plus_one,plus_one,M[ltemp],eps,0);
6915 	    }
6916 	  }
6917 	}
6918 	else { // subdiagonal reduction
6919 	  for (int ltemp=l+1;ltemp<lmax;++ltemp){
6920 	    if (debug_infolevel>=2)
6921 	      CERR << "// " << l << "," << ltemp << " "<< '\n';
6922 	    if (step_rref){
6923 	      std_matrix_gen2matrice(M,res);
6924 	      gen coeff1=pivot,coeff2=M[ltemp][pivotcol];
6925 	      if (algorithm==RREF_GAUSS_JORDAN){
6926 		coeff1=1; coeff2=coeff2/pivot;
6927 	      }
6928 	      if (convert_internal){
6929 		res = *r2sym(res,lv,contextptr)._VECTptr;
6930 		coeff1=r2sym(coeff1,lv,contextptr);
6931 		coeff2=r2sym(coeff2,lv,contextptr);
6932 	      }
6933 	      gprintf(step_rrefpivot0,gettext("L%gen <- (%gen)*L%gen-(%gen)*L%gen on %gen"),makevecteur(ltemp+1,coeff1,ltemp+1,coeff2,l+1,res),contextptr);
6934 	    }
6935 	    if (algorithm!=RREF_GAUSS_JORDAN)
6936 	      linear_combination(pivot,M[ltemp],-M[ltemp][pivotcol],M[l],bareiss,invbareiss,M[ltemp],eps,(c+1)*(rref_or_det_or_lu>0));
6937 	    else {
6938 	      gen coeff=M[ltemp][pivotcol]/pivot;
6939 	      linear_combination(plus_one,M[ltemp],-coeff,M[l],plus_one,plus_one,M[ltemp],eps,(c+1)*(rref_or_det_or_lu>0));
6940 	      if (rref_or_det_or_lu==2 || rref_or_det_or_lu == 3){
6941 		M[ltemp][pivotcol]=0;
6942 		M[ltemp][l]=coeff; // pivotcol replaced by l
6943 	      }
6944 	    }
6945 	  }
6946 	  if (rref_or_det_or_lu==1 && algorithm!=RREF_GAUSS_JORDAN) {
6947 	    if (debug_infolevel>2)
6948 	      CERR << "//mrref clear line " << l << '\n';
6949 	    // clear pivot line to save memory
6950 	    M[l].clear();
6951 	  }
6952 	} // end else
6953 	// COUT << M << '\n';
6954 	// increment column number if swap was allowed
6955 	if (l>=dont_swap_below)
6956 	  ++c;
6957 	// increment line number since reduction has been done
6958 	++l;
6959 	// multiply det
6960 	// set new bareiss for next reduction round
6961 	if (algorithm!=RREF_GAUSS_JORDAN){
6962 	  bareiss=pivot;
6963 	  if (bareiss.type==_EXT || bareiss.type==_USER)
6964 	    invbareiss=inv(bareiss,contextptr);
6965 	  else
6966 	    invbareiss=1;
6967 	}
6968 	// save pivot for annulation test purposes
6969 	if (rref_or_det_or_lu!=1){
6970 	  if (convert_internal)
6971 	    pivots.push_back(r2sym(pivot,lv,contextptr));
6972 	  else
6973 	    pivots.push_back(pivot);
6974 	  if (debug_infolevel>2)
6975 	    CERR << pivots.back() << '\n';
6976 	}
6977       }
6978       else { // if pivot is 0 increment either the line or the col
6979 	status=3;
6980 	if (rref_or_det_or_lu==1){
6981 	  det=0;
6982 	  return 1;
6983 	}
6984 	if (l>=dont_swap_below)
6985 	  c++;
6986 	else
6987 	  l++;
6988       }
6989     } // end for reduction loop
6990     return status;
6991   }
6992 
remove_identity(matrice & res,GIAC_CONTEXT)6993   bool remove_identity(matrice & res,GIAC_CONTEXT){
6994     int s=int(res.size());
6995     // "shrink" res
6996     for (int i=0;i<s;++i){
6997       vecteur v = *res[i]._VECTptr;
6998       if (
6999 	  is_exactly_zero(v[i])
7000 	  //is_zero(v[i],context0)
7001 	  )
7002 	return false;
7003       gen tmp=new ref_vecteur(v.begin()+s,v.end());
7004       divvecteur(*tmp._VECTptr,v[i],*tmp._VECTptr);
7005       res[i] = normal(tmp,contextptr);
7006     }
7007     return true;
7008   }
7009 
7010   // row reduction from line l and column c to line lmax and column cmax
7011   // lmax and cmax are not included
7012   // line are numbered starting from 0
7013   // if fullreduction is false, reduction occurs under the diagonal only
7014   // if dont_swap_below !=0, for line numers < dont_swap_below
7015   // the pivot is searched in the line instead of the column
7016   // hence no line swap occur
7017   // convert_internal=false if we do not want conversion to rational fractions
7018   // algorithm=0 Gauss-Jordan, 1 guess, 2 Bareiss, 3 modular, 4 p-adic, 5 interp
7019   // rref_or_det_or_lu = 0 for rref, 1 for det, 2 for lu,
7020   // 3 for lu without pemutation
mrref(const matrice & a,matrice & res,vecteur & pivots,gen & det,int l,int lmax,int c,int cmax,int fullreduction_,int dont_swap_below,bool convert_internal,int algorithm_,int rref_or_det_or_lu,GIAC_CONTEXT)7021   int mrref(const matrice & a, matrice & res, vecteur & pivots, gen & det,int l, int lmax, int c,int cmax,
7022 	    int fullreduction_,int dont_swap_below,bool convert_internal,int algorithm_,int rref_or_det_or_lu,
7023 	    GIAC_CONTEXT){
7024     if (!ckmatrix(a))
7025       return 0;
7026     double eps=epsilon(contextptr);
7027     unsigned as=unsigned(a.size()),a0s=unsigned(a.front()._VECTptr->size());
7028     bool step_rref=false;
7029     int algorithm=algorithm_;
7030     bool rm_idn_after=absint(fullreduction_)>=256;
7031     if (rm_idn_after)
7032       fullreduction_/=256;
7033     int fullreduction=fullreduction_;
7034     if (fullreduction<0)
7035       fullreduction=-fullreduction_;
7036     if (algorithm==RREF_GUESS && step_infolevel(contextptr) && as<5 && a0s<7){
7037       algorithm=RREF_GAUSS_JORDAN;
7038       step_rref=true;
7039     }
7040     int modular=(algorithm==RREF_MODULAR || algorithm==RREF_PADIC);
7041     // NOTE for integer matrices
7042     // p-adic is in n^3*log(nA)^2 where ||a||<=A
7043     // multi-modular is in n^3*(n+log(nA))*log(nA)
7044     // Bareiss is in n^3*M(n*log(nA)) where M is multiplication time
7045     // => for small A and large n p-adic,
7046     // but for large A and small n, Bareiss is faster
7047     if (fullreduction_>=0 && algorithm==RREF_GUESS && rref_or_det_or_lu==0 && as>10 && as==a0s-1 && int(as)==lmax && int(a0s)==cmax)
7048       modular=2;
7049     if (algorithm==RREF_GUESS && rref_or_det_or_lu<0){
7050       modular=1;
7051       rref_or_det_or_lu=-rref_or_det_or_lu;
7052     }
7053     if (rref_or_det_or_lu==2 || rref_or_det_or_lu == 3){ // LU decomposition
7054       algorithm=RREF_GAUSS_JORDAN;
7055       dont_swap_below=0;
7056       convert_internal=false;
7057       fullreduction=0;
7058     }
7059     vector<int> permutation(lmax);
7060     for (int i=0;i<lmax;++i)
7061       permutation[i]=i;
7062 #ifndef GIAC_HAS_STO_38
7063     // modular algorithm
7064     if ( ( (algorithm==RREF_GUESS && (
7065 				      fullreduction==2 ||
7066 				      rref_or_det_or_lu==1)) || modular ) && is_integer_matrice(a) && as<=a0s && as>=20){
7067       int Res=mrref_int(a,res,pivots,det,l,lmax,c,cmax,fullreduction,dont_swap_below,convert_internal,algorithm,rref_or_det_or_lu,modular,permutation,contextptr);
7068       if (Res>=0)
7069 	return Res;
7070     }
7071 #if 1 // modular algo not fast enough and p-adic already used
7072     if ( as>=GIAC_PADIC && (rref_or_det_or_lu==1 || fullreduction==2) && (algorithm==RREF_GUESS || modular ) && is_fraction_matrice(a)){
7073       res=a;
7074       gen detden=1;
7075       vecteur lcms(as);
7076       for (unsigned i=0;i<as;++i){
7077 	gen lcm_deno=common_deno(*res[i]._VECTptr);
7078 	res[i]=lcm_deno*res[i];
7079 	detden=detden*lcm_deno;
7080 	lcms[i]=lcm_deno;
7081       }
7082       matrice res_;
7083       int ok=mrref(res,res_,pivots,det,l,lmax,c,cmax,fullreduction,dont_swap_below,convert_internal,algorithm,rref_or_det_or_lu,contextptr);
7084       det=det/detden;
7085       swap(res,res_);
7086       if (ok==2){
7087 	// res*diag(lcms)*N=identity, hence N^-1=res*diag(lcms), adjust columns of res
7088 	for (unsigned i=0;i<as;++i){
7089 	  vecteur & resi=*res[i]._VECTptr;
7090 	  for (unsigned j=0;j<as;++j){
7091 	    resi[j] = resi[j]*lcms[j];
7092 	  }
7093 	}
7094 	return ok;
7095       }
7096       if (rref_or_det_or_lu!=2)
7097 	return ok;
7098       // adjust denominators for lu decomposition
7099     }
7100 #endif // modular algo for matrices with coeff in Q
7101 #endif // GIAC_HAS_STO_38
7102     gen tmp=a.front();
7103     if (lidnt(a).empty() && tmp.type==_VECT && !tmp._VECTptr->empty()){
7104       tmp=tmp._VECTptr->front();
7105       if (tmp.type==_MOD){
7106 	gen modulo=*(tmp._MODptr+1);
7107 	vecteur unmoda=*unmod(a)._VECTptr;
7108 	if (!modrref(unmoda,res,pivots,det,l,lmax,c,cmax,
7109 		     fullreduction,dont_swap_below,modulo,true/*ckprime*/,rref_or_det_or_lu)){
7110 	  if (!mrref(unmoda,res,pivots,det,l,lmax,c,cmax,
7111 		     fullreduction,dont_swap_below,convert_internal,algorithm,rref_or_det_or_lu,contextptr))
7112 	    return 0;
7113 	}
7114 	res=*makemod(res,modulo)._VECTptr;
7115 	// keep the permutation without makemod
7116 	if (!pivots.empty()){
7117 	  gen last=pivots.back();
7118 	  pivots.pop_back();
7119 	  pivots=*makemod(pivots,modulo)._VECTptr;
7120 	  pivots.push_back(last);
7121 	}
7122 	det=makemod(det,modulo);
7123 	return 1;
7124       }
7125     }
7126     int linit=l;//,previous_l=l;
7127     vecteur lv;
7128     bool num_mat=has_num_coeff(a),num_mat_=num_mat;
7129     if (num_mat){
7130       if (is_fully_numeric(a))
7131 	res=a;
7132       else {
7133 	res=*evalf_VECT(a,0,1,contextptr)._VECTptr;
7134 	num_mat=is_fully_numeric(res);
7135 	if (!num_mat){
7136 	  *logptr(contextptr) << "Converting to exact approx symbolic matrix\n" ;
7137 	  res=*exact(a,contextptr)._VECTptr;
7138 	}
7139       }
7140     }
7141     else {
7142 #if 1
7143       std::vector< std::vector<int> > M; gen x; std::vector<int> maxrankcols;
7144       int minpoly=gf_char2_matrice2vectorvectorint(a,M,x);
7145       if (minpoly>0 && gf_char2_rref(M,x,minpoly,pivots,permutation,maxrankcols,det,l,lmax,c,cmax,fullreduction,dont_swap_below,rref_or_det_or_lu)){
7146 	gf_char2_vectorvectorint2mat(M,res,minpoly,x);
7147 	return 1;
7148       }
7149 #endif
7150     }
7151     if (num_mat){
7152       if (algorithm==RREF_GUESS)
7153 	algorithm=RREF_LAGRANGE;
7154 #if 1 // ndef BCD
7155       matrix_double N;
7156       if (eps>=1e-16 && num_mat && matrice2std_matrix_double(res,N,true)){
7157 	// specialization for double
7158 	double ddet;
7159 	vector<int> maxrankcols;
7160 	doublerref(N,pivots,permutation,maxrankcols,ddet,l,lmax,c,cmax,fullreduction,dont_swap_below,rref_or_det_or_lu,eps);
7161 	if (rref_or_det_or_lu!=1){
7162 	  std_matrix<gen> RES;
7163 	  std_matrix_giac_double2std_matrix_gen(N,RES);
7164 	  std_matrix_gen2matrice_destroy(RES,res);
7165 	}
7166 	det=ddet;
7167 	if (rref_or_det_or_lu==2 || rref_or_det_or_lu == 3){
7168 	  vecteur P;
7169 	  vector_int2vecteur(permutation,P);
7170 	  pivots.push_back(P);
7171 	}
7172 #ifdef GIAC_HAS_STO_38
7173 	return 1;
7174 #else
7175 	return fullreduction==2?2:1;
7176 #endif
7177       }
7178 #endif
7179     }
7180     else {
7181       if (!num_mat_)
7182 	res=a;
7183     }
7184     //if (debug_infolevel) CERR << CLOCK()*1e-6 << " convert internal" << '\n';
7185     if (convert_internal){
7186       // convert a to internal form
7187       alg_lvar_halftan_tsimplify(res,lv,contextptr);
7188       res = *(e2r(res,lv,contextptr)._VECTptr);
7189       if (lv.size()==1 && lv.front().type==_VECT && lv.front()._VECTptr->empty()){
7190 	// cleanup res
7191 	int i=0;
7192 	for (;i<res.size();++i){
7193 	  if (res[i].type==_VECT && res[i].ref_count()==1){
7194 	    vecteur & resi=*res[i]._VECTptr;
7195 	    int j=0;
7196 	    for (;j<resi.size();++j){
7197 	      gen resij=resi[j];
7198 	      if (resij.type<_POLY)
7199 		continue;
7200 	      if (resij.type==_FRAC && resij._FRACptr->den.type<=_ZINT)
7201 		resij=resij._FRACptr->num;
7202 	      if (resij.type==_POLY && resij._POLYptr->dim==0 && resij._POLYptr->coord.size()==1){
7203 		gen tmp=resij._POLYptr->coord.front().value;
7204 		if (tmp.type<_POLY)
7205 		  continue;
7206 		if (tmp.type==_EXT && tmp._EXTptr->type==_VECT && (tmp._EXTptr+1)->type==_VECT && is_integer_vecteur(*tmp._EXTptr->_VECTptr) && is_integer_vecteur(*(tmp._EXTptr+1)->_VECTptr))
7207 		  continue;
7208 	      }
7209 	      break;
7210 	    }
7211 	    if (j!=resi.size())
7212 	      break;
7213 	  }
7214 	  else break;
7215 	}
7216 	if (i==res.size()){
7217 	  for (i=0;i<res.size();++i){
7218 	    if (res[i].type==_VECT && res[i].ref_count()==1){
7219 	      vecteur & resi=*res[i]._VECTptr;
7220 	      for (int j=0;j<resi.size();++j){
7221 		gen & resij=resi[j];
7222 		if (resij.type==_FRAC && resij._FRACptr->den.type<=_ZINT){
7223 		  gen tmp=resij._FRACptr->num;
7224 		  if (tmp.type==_POLY && tmp._POLYptr->dim==0 && tmp._POLYptr->coord.size()==1)
7225 		    resij=fraction(tmp._POLYptr->coord.front().value,resij._FRACptr->den);
7226 		}
7227 		if (resij.type==_POLY && resij._POLYptr->dim==0 && resij._POLYptr->coord.size()==1)
7228 		  resij=resij._POLYptr->coord.front().value;
7229 	      }
7230 	    }
7231 	  }
7232 	}
7233       }
7234     }
7235     //if (debug_infolevel) CERR << CLOCK()*1e-6 << " end convert internal" << '\n';
7236     int lvs=int(lv.size());
7237     // COUT << res << '\n';
7238     gen lcm_deno,gcd_num;
7239     gen detnum = plus_one;
7240     gen detden = plus_one;
7241     if (algorithm!=RREF_GAUSS_JORDAN){
7242       // remove common denominator of each line (fraction-free elim)
7243       iterateur it=res.begin(),itend=res.end();
7244       for (;it!=itend;++it){
7245 	if (num_mat){ // divide each line by max coeff in abs value
7246 	  lcm_deno=linfnorm(*it,contextptr);
7247 	  detnum=lcm_deno*detnum;
7248 	  multvecteur(inv(lcm_deno,contextptr),*it->_VECTptr,*it->_VECTptr);
7249 	}
7250 	else { // non num mat
7251 	  lcm_deno=common_deno(*it->_VECTptr);
7252 	  if (!is_one(lcm_deno)){
7253 	    iterateur jt=it->_VECTptr->begin(),jtend=it->_VECTptr->end();
7254 	    for (;jt!=jtend;++jt){
7255 	      if (jt->type==_FRAC){
7256 		gen nm(jt->_FRACptr->num);
7257 		gen dn(jt->_FRACptr->den);
7258 		// *jt -> lcmdeno* (nm/dn) = nm * tmp/dn
7259 		gen tmp(lcm_deno);
7260 		simplify(tmp,dn);
7261 		if (dn.type<=_CPLX){
7262 		  *jt=nm*tmp/dn;
7263 		  continue;
7264 		}
7265 		if (dn.type==_POLY){
7266 		  *jt=nm*tmp/dn._POLYptr->coord.front().value;
7267 		  continue;
7268 		}
7269 		return 0; // settypeerr();
7270 	      }
7271 	      else
7272 		*jt=(*jt) * lcm_deno;
7273 	    }
7274 	    detden = detden * lcm_deno;
7275 	  }
7276 	  gcd_num=common_num(*it->_VECTptr);
7277 	  if (!is_zero(gcd_num,contextptr))
7278 	    *it=rdiv(*it,gcd_num,contextptr);
7279 	  detnum=detnum*gcd_num;
7280 	} // end else (non num mat)
7281       } // end for (;it!=itend;)
7282       // check if res is integer or polynomial
7283       if (lvs==1 && lv.front().type==_VECT && lv.front()._VECTptr->empty() && (rref_or_det_or_lu==1 || modular ) && is_integer_matrice(res) && as<=a0s){
7284 	matrice res1;
7285 	if (!mrref(res,res1,pivots,det,l,lmax,c,cmax,fullreduction,dont_swap_below,false,algorithm,rref_or_det_or_lu,contextptr))
7286 	  return 0;
7287 	res=res1;
7288 	det=detnum*det/detden;
7289 	if (convert_internal)
7290 	  det=r2sym(det,lv,contextptr);
7291 	if (rref_or_det_or_lu==2 || rref_or_det_or_lu == 3){
7292 	  vecteur P;
7293 	  vector_int2vecteur(permutation,P);
7294 	  pivots.push_back(P);
7295 	}
7296 	return 1;
7297       }
7298       bool fullreductionafter=rref_or_det_or_lu==0 && dont_swap_below==0 && c==0 && linit==0 && cmax>=lmax && step_infolevel(contextptr)==0 && fullreduction && algorithm!=RREF_GAUSS_JORDAN; // insure all pivots are normalized to be = to the determinant
7299       if ( ( (rref_or_det_or_lu==1 && as==a0s ) || fullreductionafter)
7300 	   && as>4
7301 	   && algorithm==RREF_GUESS && ( (convert_internal && lvs==1 && lv.front().type==_VECT) || res.front()._VECTptr->front().type==_POLY) ){
7302 	// guess if Bareiss or Lagrange interpolation is faster
7303 	// Bareiss depends on the total degree, Lagrange on partial degrees
7304 	// gather line/columns statistics
7305 	int polydim=res.front()._VECTptr->front().type==_POLY?res.front()._VECTptr->front()._POLYptr->dim:int(lv.front()._VECTptr->size());
7306 	index_t col_totaldeg(as);
7307 	vector< index_t > col_partialdeg(as,index_t(polydim));
7308 	int maxtotaldeg=0,summaxtotaldeg=0;
7309 	if (polydim){
7310 	  index_t summaxdeg(polydim);
7311 	  for (unsigned int i=0;i<as;++i){
7312 	    index_t maxdeg(polydim);
7313 	    for (unsigned int j=0;j<as;++j){
7314 	      const gen & tmp = (*res[i]._VECTptr)[j];
7315 	      if (tmp.type==_POLY){
7316 		const index_t & degij=tmp._POLYptr->degree();
7317 		maxdeg=index_lcm(degij,maxdeg);
7318 		col_partialdeg[j]=index_lcm(degij,col_partialdeg[j]);
7319 		int totaldeg=tmp._POLYptr->total_degree();
7320 		if (maxtotaldeg<totaldeg)
7321 		  maxtotaldeg=totaldeg;
7322 		if (col_totaldeg[j]<totaldeg)
7323 		  col_totaldeg[j]=totaldeg;
7324 	      }
7325 	    }
7326 	    summaxtotaldeg += maxtotaldeg;
7327 	    summaxdeg=summaxdeg+maxdeg;
7328 	  }
7329 	  maxtotaldeg=std::min(summaxtotaldeg,int(total_degree(col_totaldeg)));
7330 	  index_t col_sumpartialdeg(polydim);
7331 	  for (unsigned int j=0;j<as;++j)
7332 	    col_sumpartialdeg = col_sumpartialdeg+col_partialdeg[j];
7333 	  for (int i=0;i<polydim;++i){
7334 	    summaxdeg[i]=std::min(summaxdeg[i],col_sumpartialdeg[i]);
7335 	  }
7336 	  if (debug_infolevel>2)
7337 	    CERR << "Total degree " << maxtotaldeg << ", partial degrees " << summaxdeg << '\n';
7338 	  // Now modify algorithm to RREF_LAGRANGE if it's faster
7339 	  double lagrange_time=std::pow(double(as),2)*(as*10+160);
7340 	  // coeffs of as*.+. are guess
7341 	  for (int j=0;j<polydim;j++){
7342 	    lagrange_time *= (summaxdeg[j]+1);
7343 	  }
7344 	  double bareiss_time=0;
7345 	  // time is almost proportionnal to sum( comb(maxtotaldeg*j/as+polydim,polydim)^2, j=1..as-1)
7346 	  for (unsigned int j=1;j<as;++j){
7347 	    int tmpdeg=int(double(maxtotaldeg*j)/as+.5);
7348 	    double tmp = evalf_double(comb(tmpdeg+polydim,polydim),1,contextptr)._DOUBLE_val;
7349 	    tmp = tmp*tmp*std::log(tmp)*(as-j);
7350 	    bareiss_time += 4*tmp; // 1 for *, 1 for /
7351 	  }
7352 	  bareiss_time *= as; // take account of the size of the coefficients
7353 	  if (debug_infolevel>2)
7354 	    CERR << "lagrange " << lagrange_time << " bareiss " << bareiss_time << '\n';
7355 	  if (lagrange_time<bareiss_time){
7356 	    algorithm=RREF_LAGRANGE;
7357 	  }
7358 	} // end if (polydim)
7359       }
7360       if ( algorithm==RREF_LAGRANGE && ( (rref_or_det_or_lu==1 && as==a0s) || fullreductionafter ) ){
7361 	vecteur lva=lvar(a);
7362 	if ( (!convert_internal && lva.empty()) || (lvs==1 && lv.front()==lva) ){
7363 	  // find degrees wrt main variable
7364 	  int polydim=0;
7365 	  int totaldeg=0;
7366 	  gen coeffp; int tt=0;
7367 	  vector<int> maxdegj(a0s);
7368 	  for (unsigned int i=0;i<as;++i){
7369 	    int maxdegi=0;
7370 	    for (unsigned int j=0;j<a0s;++j){
7371 	      gen & tmp = (*res[i]._VECTptr)[j];
7372 	      if (tmp.type==_POLY){
7373 		if (tt!=_USER)
7374 		  tt=coefftype(*tmp._POLYptr,coeffp);
7375 		polydim=tmp._POLYptr->dim;
7376 		const int & curdeg=tmp._POLYptr->lexsorted_degree();
7377 		if (curdeg>maxdegi)
7378 		  maxdegi=tmp._POLYptr->lexsorted_degree();
7379 		if (curdeg>maxdegj[j])
7380 		  maxdegj[j]=curdeg;
7381 		tmp=polynome2poly1(tmp,1);
7382 	      }
7383 	    }
7384 	    totaldeg+=maxdegi;
7385 	  }
7386 	  if (polydim){
7387 	    if (debug_infolevel)
7388 	      CERR << CLOCK()*1e-6 << " det: begin interp" << '\n';
7389 	    totaldeg=std::min(totaldeg,total_degree(maxdegj));
7390 	    if (!interpolable(totaldeg+1,coeffp,true,contextptr))
7391 	      return 0;
7392 	    int shift=coeffp.type?0:totaldeg/2;
7393 	    proba_epsilon(contextptr) /= totaldeg;
7394 	    vecteur X(totaldeg+1),Y(totaldeg+1),Z(totaldeg+1);
7395 	    int x=0;
7396 	    for (;x<=totaldeg;++x){
7397 	      gen realx=interpolate_xi(x-shift,coeffp);
7398 	      X[x]=realx;
7399 	      vecteur resx;
7400 	      resx.reserve(totaldeg+1);
7401 	      if (debug_infolevel)
7402 		CERR << CLOCK()*1e-6 << " det: begin horner" << '\n';
7403 	      for (unsigned int i=0;i<as;++i){
7404 		vecteur resxi;
7405 		resxi.reserve(a0s); // was (totaldeg+1);
7406 		for (unsigned int j=0;j<a0s;++j){
7407 		  const gen & tmp = (*res[i]._VECTptr)[j];
7408 		  resxi.push_back(horner(tmp,realx));
7409 		}
7410 		resx.push_back(resxi);
7411 	      }
7412 	      if (debug_infolevel)
7413 		CERR << CLOCK()*1e-6 << " det: end horner" << '\n';
7414 	      matrice res1;
7415 	      if (!mrref(resx,res1,pivots,det,l,lmax,c,cmax,-fullreduction,dont_swap_below,false,algorithm_,rref_or_det_or_lu,contextptr))
7416 		return 0;
7417 	      Y[x]=det;
7418 	      if (fullreduction){
7419 		if (is_zero(det) )
7420 		  break;
7421 		// check diagonal coefficients of res1, they must be == det
7422 		for (int i=0;i<res1.size();++i){
7423 		  vecteur & res1i=*res1[i]._VECTptr;
7424 		  if (res1i[i]==det)
7425 		    continue;
7426 		  if (res1i[i]==-det)
7427 		    res1[i]=-res1[i];
7428 		  else
7429 		    res1[i]=(det/res1i[i])*res1[i];
7430 		}
7431 		// extract right submatrix
7432 		res1=mtran(res1);
7433 		Z[x]=vecteur(res1.begin()+lmax,res1.end());
7434 	      } // if (fullreduction)
7435 	    } // end for x
7436 	    if (x==totaldeg+1){
7437 	      proba_epsilon(contextptr) *= totaldeg;
7438 	      if (debug_infolevel)
7439 		CERR << CLOCK()*1e-6 << " det: divided diff" << '\n';
7440 	      // Lagrange interpolation
7441 	      vecteur L=divided_differences(X,Y);
7442 	      if (debug_infolevel)
7443 		CERR << CLOCK()*1e-6 << " det: end divided diff" << '\n';
7444 	      det=untrunc1(L[totaldeg]);
7445 	      monomial<gen> mtmp(1,1,polydim);
7446 	      gen xpoly=polynome(mtmp);
7447 	      for (int i=totaldeg-1;i>=0;--i){
7448 		det = det*(xpoly-untrunc1(X[i]))+untrunc1(L[i]);
7449 	      }
7450 	      det=det*detnum/detden;
7451 	      if (convert_internal)
7452 		det=r2sym(det,lva,contextptr);
7453 	      if (debug_infolevel)
7454 		CERR << CLOCK()*1e-6 << " det: end interp" << '\n';
7455 	      if (fullreduction){
7456 		vecteur R,RR;
7457 		interpolate(X,Z,R,0);
7458 		polymat2matpoly(R,RR);
7459 		// apply poly12polynome in elements of R
7460 		for (int i=0;i<RR.size();++i){
7461 		  if (RR[i].type!=_VECT)
7462 		    continue;
7463 		  vecteur & w=*RR[i]._VECTptr;
7464 		  for (int j=0;j<w.size();++j){
7465 		    if (w[j].type==_VECT){
7466 		      w[j]=poly12polynome(*w[j]._VECTptr,1,polydim);
7467 		    }
7468 		    if (convert_internal)
7469 		      w[j]=r2sym(w[j],lva,contextptr);
7470 		  }
7471 		}
7472 		vecteur R0=midn(lmax);
7473 		for (int i=0;i<R0.size();++i){
7474 		  (*R0[i]._VECTptr)[i]=det;
7475 		}
7476 		R=mergevecteur(R0,RR);
7477 		res=mtran(R);
7478 	      }
7479 	      return 1;
7480 	    } // if interpolation ok (x==totaldeg+1)
7481 	    else { // back convert from poly1 to polynome
7482 	      for (unsigned int i=0;i<as;++i){
7483 		for (unsigned int j=0;j<a0s;++j){
7484 		  gen & tmp = (*res[i]._VECTptr)[j];
7485 		  if (tmp.type==_VECT){
7486 		    tmp=poly12polynome(*tmp._VECTptr,1,polydim);
7487 		  }
7488 		}
7489 	      }
7490 	    }
7491 	  } // end if polydim
7492 	}
7493       }
7494     }
7495 
7496     std_matrix<gen> M;
7497     matrice2std_matrix_gen(res,M);
7498     // vecteur vtemp;
7499     pivots.clear();
7500     pivots.reserve(cmax-c);
7501     bool fullreductionafter=rref_or_det_or_lu==0 && dont_swap_below==0 && cmax-c>=lmax-linit && step_infolevel(contextptr)==0 && fullreduction && algorithm!=RREF_GAUSS_JORDAN;
7502     gen detnumsave=detnum;
7503     int status=rref_reduce(M,pivots,permutation,det,detnum,algorithm,l,lmax,c,cmax,dont_swap_below,rref_or_det_or_lu,(fullreductionafter?0:fullreduction),eps,step_rref,lv,convert_internal,num_mat,contextptr);
7504     if (status!=2 && status!=3)
7505       return status;
7506     if (fullreductionafter){
7507       det=M[lmax-1][c-linit+lmax-1];
7508       if (status==3 || is_exactly_zero(det)){
7509       //if (status==3 || is_zero(det,contextptr) ){
7510 	// not Cramer like, re-reduce,
7511 	pivots.clear();
7512 	matrice2std_matrix_gen(res,M); det=detnum=detnumsave;// this should be commented but some outputs are more complicated
7513 	rref_reduce(M,pivots,permutation,det,detnum,algorithm,l,lmax,c,cmax,dont_swap_below,rref_or_det_or_lu,fullreduction,eps,step_rref,lv,convert_internal,num_mat,contextptr);
7514       }
7515       else {
7516 	// back row reduction to echelon form for Cramer like system
7517 	vecteur & Mlast=M[lmax-1];
7518 	int shift=c-linit;
7519 	gen d=Mlast[shift+lmax-1];
7520 	for (l=lmax-2;l>=linit;--l){
7521 	  vecteur Mlcopy(M[l]);
7522 	  vecteur & Ml=M[l];
7523 	  // Ll <- a_{n-1,n-1}*Ll-(a_{l,n-1}*L_{n-1}-a_{l,n-2}*L_{n-2}...)
7524 	  // multvecteur(d,Ml,Ml); // should be done from shift+lmax
7525 	  for (int j=shift+lmax;j<cmax;++j){
7526 	    gen & Mlj=Ml[j];
7527 	    Mlj = d*Mlj;
7528 	  }
7529 	  for (int j=lmax-1;j>=l+1;--j){
7530 	    linear_combination(plus_one,Ml,-Mlcopy[shift+j],M[j],plus_one,1,Ml,eps,shift+lmax);
7531 	  }
7532 	  for (int j=shift+l+1;j<shift+lmax;++j)
7533 	    Ml[j]=0;
7534 	  Ml[shift+l]=d;
7535 	  for (int j=shift+lmax;j<cmax;++j){
7536 	    Ml[j]=exact_div(Ml[j],Mlcopy[shift+l]);
7537 	  }
7538 	}
7539       }
7540     } // end if fullreductionafter
7541     if (debug_infolevel>2)
7542       CERR << "// mrref reduction end:" << CLOCK()*1e-6 << '\n';
7543     if (step_rref){
7544       std_matrix_gen2matrice(M,res);
7545       if (convert_internal)
7546 	res = *r2sym(res,lv,contextptr)._VECTptr;
7547       gprintf(step_rrefend,gettext("End reduction %gen"),makevecteur(res),contextptr);
7548     }
7549     if (algorithm!=RREF_GAUSS_JORDAN){
7550       int last=giacmin(lmax,cmax);
7551       det=M[last-1][last-1];
7552       if ( (debug_infolevel>2) && (det.type==_POLY) )
7553 	CERR << "// polynomial size " << det._POLYptr->coord.size() << '\n';
7554       if (rref_or_det_or_lu==1) // erase last line of the matrix
7555 	M[lmax-1].clear();
7556       det=rdiv(det*detnum,detden,contextptr);
7557       if (convert_internal)
7558 	det=r2sym(det,lv,contextptr);
7559       // CERR << det << '\n';
7560     }
7561     else {
7562       // adjust determinant by multiplication by all diagonal coeffs
7563       for (int i=linit;i<lmax && i<cmax;++i)
7564 	detnum = detnum * M[i][i];
7565       det = rdiv(detnum,detden,contextptr);
7566       if (convert_internal)
7567 	det = r2sym(det,lv,contextptr);
7568     }
7569     std_matrix_gen2matrice_destroy(M,res);
7570     int ok=1;
7571     if (convert_internal){
7572       if (rm_idn_after){
7573 	if (!remove_identity(res,contextptr))
7574 	  return 0;
7575 	res = *(r2sym (res,lv,contextptr)._VECTptr);
7576 	res =*normal(res,contextptr)._VECTptr;
7577 	ok=2;
7578       }
7579       else
7580 	res = *(r2sym (res,lv,contextptr)._VECTptr);
7581     }
7582     if (rref_or_det_or_lu==2 || rref_or_det_or_lu == 3){
7583       vecteur P;
7584       vector_int2vecteur(permutation,P);
7585       pivots.push_back(P);
7586     }
7587     if (debug_infolevel>2)
7588       CERR << "// mrref end:" << CLOCK()*1e-6 << " " << M << '\n';
7589     return ok;
7590   }
7591 
7592   // convert a to vector< vector<int> > with modular reduction (if modulo!=0)
vect_vecteur_2_vect_vector_int(const std_matrix<gen> & M,int modulo,vector<vector<int>> & N)7593   void vect_vecteur_2_vect_vector_int(const std_matrix<gen> & M,int modulo,vector< vector<int> > & N){
7594     int Msize=int(M.size());
7595     N.clear();
7596     N.reserve(Msize);
7597     for (int k=0;k<Msize;k++){
7598       const vecteur & v = M[k];
7599       const_iterateur it=v.begin(),itend=v.end();
7600       vector<int> vi(itend-it);
7601       vector<int>::iterator jt=vi.begin();
7602       for (;it!=itend;++jt,++it){
7603 	if (!modulo)
7604 	  *jt=it->val;
7605 	else
7606 	  *jt=smod(*it,modulo).val;
7607       }
7608       N.push_back(vi);
7609     }
7610   }
7611 
vect_vector_int_2_vect_vecteur(const vector<vector<int>> & N,std_matrix<gen> & M)7612   void vect_vector_int_2_vect_vecteur(const vector< vector<int> > & N,std_matrix<gen> & M){
7613     // Back convert N to M
7614     int Msize=int(N.size());
7615     M = std_matrix<gen>(Msize);
7616     for (int k=0;k<Msize;k++){
7617       const vector<int> & v = N[k];
7618       vector<int>::const_iterator it=v.begin(),itend=v.end();
7619       vecteur vi(itend-it);
7620       iterateur jt=vi.begin();
7621       for (;it!=itend;++jt,++it){
7622 	*jt=*it;
7623       }
7624       M[k]=vi;
7625     }
7626   }
7627 
7628   //transforme un vecteur en vector<int>
vecteur2vector_int(const vecteur & v,int m,vector<int> & res)7629   void vecteur2vector_int(const vecteur & v,int m,vector<int> & res){
7630     vecteur::const_iterator it=v.begin(),itend=v.end();
7631     res.clear();
7632     if (m==0) {
7633       res.resize(itend-it);
7634       int * jt=res.empty()?0:&res.front();
7635       for (;it!=itend;++it,++jt){
7636 	int t=it->type;
7637 	if (t==0)
7638 	  *jt=it->val;
7639 	else {
7640 	  if (t==_MOD)
7641 	    *jt=it->_MODptr->val;
7642 	  else
7643 	    *jt=it->to_int();
7644 	}
7645       }
7646       return;
7647     }
7648     res.reserve(itend-it);
7649     if (m<0)
7650       m=-m;
7651     for (;it!=itend;++it){
7652       if (it->type==_MOD)
7653 	res.push_back(it->_MODptr->val);
7654       else {
7655 	int r=it->type==_ZINT?modulo(*it->_ZINTptr,m):(it->val % m);
7656 	r += (unsigned(r)>>31)*m; // make positive
7657 	r -= (unsigned((m>>1)-r)>>31)*m;
7658 	res.push_back(r);// res.push_back(smod((*it),m).val);
7659       }
7660     }
7661   }
7662 
vecteur2vectvector_int(const vecteur & v,int modulo,vector<vector<int>> & res)7663   bool vecteur2vectvector_int(const vecteur & v,int modulo,vector< vector<int> > & res){
7664     vecteur::const_iterator it=v.begin(),itend=v.end();
7665     res.resize(itend-it);
7666     for (int i=0;it!=itend;++i,++it){
7667       if (it->type!=_VECT)
7668 	return false;
7669       vecteur2vector_int(*it->_VECTptr,modulo,res[i]);
7670     }
7671     return true;
7672   }
7673 
vector_int2vecteur(const vector<int> & v,vecteur & res)7674   void vector_int2vecteur(const vector<int> & v,vecteur & res){
7675     //transforme un vector<int> en vecteur
7676     vector<int>::const_iterator it=v.begin(),itend=v.end();
7677     res.resize(itend-it);
7678     for (iterateur jt=res.begin();it!=itend;++jt,++it)
7679       *jt=*it;
7680   }
7681 
vectvector_int2vecteur(const vector<vector<int>> & v,vecteur & res)7682   void vectvector_int2vecteur(const vector< vector<int> > & v,vecteur & res){
7683     //transforme un vector< vector<int> > en vecteur
7684     int s=int(v.size());
7685     res.resize(s);
7686     for (int i=0;i<s;++i){
7687       if (res[i].type!=_VECT)
7688 	res[i]=new ref_vecteur;
7689       vector_int2vecteur(v[i],*res[i]._VECTptr);
7690     }
7691   }
7692 
dotvector_int(const vector<int> & v,const vector<int> & w,int modulo)7693   int dotvector_int(const vector<int> & v,const vector<int> & w,int modulo){
7694     vector<int>::const_iterator it=v.begin(),itend=v.end(),it1,jt=w.begin();
7695     unsigned n=unsigned(itend-it);
7696     if ( ((longlong(modulo)*modulo)/RAND_MAX)*n>RAND_MAX){
7697       int res=0;
7698       for (;it!=itend;++jt,++it){
7699 #ifdef _I386_
7700 	mod(res,*it,*jt,modulo);
7701 #else
7702 	res = (res + longlong(*it)*(*jt))% modulo;
7703 #endif
7704       }
7705       return smod(res,modulo) ;
7706     }
7707     longlong res=0;
7708     it1 = it + ((n>>2) <<2);
7709     for (;it!=it1;){
7710       res += (longlong (*it))*(*jt);
7711       ++jt; ++it;
7712       res += (longlong (*it))*(*jt);
7713       ++jt; ++it;
7714       res += (longlong (*it))*(*jt);
7715       ++jt; ++it;
7716       res += (longlong (*it))*(*jt);
7717       ++jt; ++it;
7718     }
7719     for (;it!=itend;++jt,++it){
7720       res += (longlong (*it))*(*jt);
7721     }
7722     return smod(res,modulo) ;
7723   }
7724 
dotvector_int(const vector<int> & v0,const vector<int> & v1,const vector<int> & v2,const vector<int> & v3,const vector<int> & w,longlong & res0,longlong & res1,longlong & res2,longlong & res3)7725   void dotvector_int(const vector<int> & v0,const vector<int> & v1,const vector<int> & v2,const vector<int> & v3,const vector<int> & w,longlong &res0,longlong & res1,longlong & res2,longlong & res3){
7726     vector<int>::const_iterator it=w.begin(),itend=w.end(),it1,jt0=v0.begin(),jt1=v1.begin(),jt2=v2.begin(),jt3=v3.begin();
7727     unsigned n=unsigned(itend-it);
7728     res0=res1=res2=res3=0;
7729     it1 = itend -4;
7730     for (;it<=it1;jt0+=4,jt1+=4,jt2+=4,jt3+=4,it+=4){
7731       longlong tmp0=it[0],tmp1=it[1],tmp2=it[2],tmp3=it[3];
7732       res0 += tmp0*jt0[0]+tmp1*jt0[1]+tmp2*jt0[2]+tmp3*jt0[3];
7733       res1 += tmp0*jt1[0]+tmp1*jt1[1]+tmp2*jt1[2]+tmp3*jt1[3];
7734       res2 += tmp0*jt2[0]+tmp1*jt2[1]+tmp2*jt2[2]+tmp3*jt2[3];
7735       res3 += tmp0*jt3[0]+tmp1*jt3[1]+tmp2*jt3[2]+tmp3*jt3[3];
7736     }
7737     for (;it!=itend;++jt0,++jt1,++jt2,++jt3,++it){
7738       longlong tmp=*it;
7739       res0 += tmp*(*jt0);
7740       res1 += tmp*(*jt1);
7741       res2 += tmp*(*jt2);
7742       res3 += tmp*(*jt3);
7743     }
7744   }
7745 
multvectvector_int_vector_int(const vector<vector<int>> & M,const vector<int> & v,int modulo,vector<int> & Mv)7746   bool multvectvector_int_vector_int(const vector< vector<int> > & M,const vector<int> & v,int modulo,vector<int> & Mv){
7747     unsigned n=unsigned(M.size());
7748     Mv.clear();
7749     if (!n)
7750       return true;
7751     if (M.front().size()!=v.size())
7752       return false;
7753     Mv.reserve(n);
7754     vector< vector<int> >::const_iterator it=M.begin(),itend=M.end();
7755 #if 1
7756     if ( ((longlong(modulo)*modulo)/RAND_MAX)*n<=RAND_MAX){
7757       itend-=4;
7758       longlong l0,l1,l2,l3;
7759       for (;it<=itend;it+=4){
7760 	dotvector_int(it[0],it[1],it[2],it[3],v,l0,l1,l2,l3);
7761 	Mv.push_back(smod(l0,modulo));
7762 	Mv.push_back(smod(l1,modulo));
7763 	Mv.push_back(smod(l2,modulo));
7764 	Mv.push_back(smod(l3,modulo));
7765       }
7766       itend+=4;
7767     }
7768 #endif
7769     for (;it!=itend;++it){
7770       Mv.push_back(dotvector_int(*it,v,modulo));
7771     }
7772     return true;
7773   }
7774 
tran_vect_vector_int(const vector<vector<int>> & N,vector<vector<int>> & tN)7775   void tran_vect_vector_int(const vector< vector<int> > & N,vector< vector<int> > & tN){
7776     tN.clear();
7777     unsigned r=unsigned(N.size());
7778     if (!r)
7779       return;
7780     unsigned c=unsigned(N.front().size());
7781     tN.reserve(c);
7782     for (unsigned int i=0;i<c;++i){
7783       vector<int> current;
7784       current.reserve(r);
7785       for (unsigned int j=0;j<r;++j){
7786 	current.push_back(N[j][i]);
7787       }
7788       tN.push_back(current);
7789     }
7790   }
7791 
apply_permutation(const vector<int> & permutation,const vector<int> & x,vector<int> & y)7792   void apply_permutation(const vector<int> & permutation,const vector<int> &x,vector<int> & y){
7793     unsigned n=unsigned(x.size());
7794     y.clear();
7795     y.reserve(n);
7796     for (unsigned int i=0;i<n;++i)
7797       y.push_back(x[permutation[i]]);
7798   }
7799 
7800   /*
7801   vector<int> perminv(const vector<int> & p);
7802   // solve LU x= b (permutation P)
7803   void smallsolvelu(const vector< vector<int> > & LU,const vector<int> & P,const vector<int> & b,vector<int> & x,int modulo){
7804     unsigned n=P.size();
7805     vector<int> bp(n),y(n);
7806     apply_permutation(P,b,bp);
7807     // solve U y=bp
7808     for (int i=n-1;i>=0;--i){
7809       // y[i]=LU[i,i]^(-1)*(bp[i]-sum(j>i)LU[i,j]*y[j])
7810       int res=0;
7811       const vector<int> & li=LU[i];
7812       for (int j=i+1;j<n;++j)
7813 	mod(res,li[j],y[j],modulo);
7814       y[i]=(invmod(li[i],modulo)*longlong(bp[i]-res))%modulo;
7815     }
7816     // solve L bp = y
7817     for (int i=0;i<n;++i){
7818       // bp[i]=(y[i]-sum(j<i)LU[i,j]*bp[j])
7819       int res=0;
7820       const vector<int> & li=LU[i];
7821       for (int j=0;j<i;++j)
7822 	mod(res,li[j],y[j],modulo);
7823       y[i]=longlong(bp[i]-res)%modulo;
7824     }
7825     // reorder bp
7826     apply_permutation(perminv(P),bp,x);
7827   }
7828   */
7829 
makepositive(vector<vector<int>> & N,int l,int lmax,int c,int cmax,int modulo)7830   void makepositive(vector< vector<int> > & N,int l,int lmax,int c,int cmax,int modulo){
7831     for (int L=l;L<lmax;++L){
7832       vector<int> & NL=N[L];
7833       if (NL.empty()) continue;
7834       for (int C=c+(L-l);C<cmax;++C){
7835 	int & i=NL[C];
7836 	i -= (i>>31)*modulo;
7837       }
7838     }
7839   }
7840 
7841 #if 1
smallmodrref_lower(vector<vector<int>> & N,int lstart,int l,int lmax,int c,int cmax,const vector<int> & pivots,int modulo,bool debuginfo)7842   void smallmodrref_lower(vector< vector<int> > & N,int lstart,int l,int lmax,int c,int cmax,const vector<int> & pivots,int modulo,bool debuginfo){
7843     int ps=int(pivots.size());
7844     longlong modulo2=longlong(modulo)*modulo;
7845     bool convertpos= double(modulo2)*ps >= 9.22e18;
7846     if (convertpos)
7847       makepositive(N,lstart,lmax,c,cmax,modulo);
7848     vector<longlong> buffer(cmax);
7849     for (int L=l;L<lmax;++L){
7850       if (debuginfo){
7851 	if (L%10==9){ CERR << "+"; CERR.flush();}
7852 	if (L%500==499){ CERR << CLOCK()*1e-6 << " remaining " << lmax-L << '\n'; }
7853       }
7854       // copy line to 64 bits buffer
7855       vector<int> & NL=N[L];
7856       if (NL.empty()) continue;
7857       for (int C=c;C<cmax;++C)
7858 	buffer[C]=NL[C];
7859       // substract lines in pivots[k].first from column pivots[k].second to cmax
7860       for (int line=lstart;line<lstart+ps;++line){
7861 	int col=pivots[line-lstart];
7862 	if (col<0) continue;
7863 	vector<int> & Nline=N[line];
7864 	if (Nline.empty()){
7865 	  CERR << "rref_lower Bad matrix "<< lmax << "x" << cmax << " l" << line << " c" << col << '\n';
7866 	  continue;
7867 	}
7868 	if (Nline[col]!=1){
7869 	  Nline[col] %= modulo;
7870 	  if (Nline[col]!=1){
7871 	    CERR << "rref_lower Bad matrix "<< lmax << "x" << cmax << " l" << line << " c" << col << " " << Nline[col] << '\n';
7872 	    continue;
7873 	  }
7874 	}
7875 	longlong coeff=buffer[col];
7876 	if (!coeff) continue;
7877 	coeff %= modulo;
7878 	if (!coeff) continue;
7879 	buffer[col]=0;
7880 	if (convertpos){
7881 	  int C=col+1;
7882 	  longlong * buf=&buffer[C];
7883 	  longlong * bufend=&buffer[cmax]-8;
7884 	  const int * nline=&Nline[C];
7885 	  for (;buf<=bufend;buf+=8,nline+=8){
7886 	    longlong x,y;
7887 	    x=buf[0]; x -= coeff*nline[0]; x -= (x>>63)*modulo2; buf[0]=x;
7888 	    y=buf[1]; y -= coeff*nline[1]; y -= (y>>63)*modulo2; buf[1]=y;
7889 	    x=buf[2]; x -= coeff*nline[2]; x -= (x>>63)*modulo2; buf[2]=x;
7890 	    y=buf[3]; y -= coeff*nline[3]; y -= (y>>63)*modulo2; buf[3]=y;
7891 	    x=buf[4]; x -= coeff*nline[4]; x -= (x>>63)*modulo2; buf[4]=x;
7892 	    y=buf[5]; y -= coeff*nline[5]; y -= (y>>63)*modulo2; buf[5]=y;
7893 	    x=buf[6]; x -= coeff*nline[6]; x -= (x>>63)*modulo2; buf[6]=x;
7894 	    y=buf[7]; y -= coeff*nline[7]; y -= (y>>63)*modulo2; buf[7]=y;
7895 	  }
7896 	  for (C+=int(buf-&buffer[C]);C<cmax;++C){
7897 	    longlong & b=buffer[C] ;
7898 	    longlong x = b;
7899 	    x -= coeff*Nline[C];
7900 	    x -= (x>>63)*modulo2;
7901 	    b=x;
7902 	  }
7903 	}
7904 	else {
7905 	  int C=col+1;
7906 	  longlong * buf=&buffer[C];
7907 	  longlong * bufend=&buffer[cmax]-8;
7908 	  const int * nline=&Nline[C];
7909 	  for (;buf<=bufend;buf+=8,nline+=8){
7910 	    buf[0] -= coeff*nline[0];
7911 	    buf[1] -= coeff*nline[1];
7912 	    buf[2] -= coeff*nline[2];
7913 	    buf[3] -= coeff*nline[3];
7914 	    buf[4] -= coeff*nline[4];
7915 	    buf[5] -= coeff*nline[5];
7916 	    buf[6] -= coeff*nline[6];
7917 	    buf[7] -= coeff*nline[7];
7918 	  }
7919 	  for (C+=int(buf-&buffer[C]);C<cmax;++C){
7920 	    buffer[C] -= coeff*Nline[C];
7921 	  }
7922 	}
7923       }
7924       // copy back buffer to N[l]
7925       for (int C=c;C<cmax;++C){
7926 	longlong x=buffer[C];
7927 	if (x)
7928 	  NL[C]=x % modulo;
7929 	else
7930 	  NL[C]=0;
7931       }
7932     } // end loop on L
7933   }
7934 
7935 #else
7936   // lower row reduction of N from l to lmax using already reduced lines
7937   // with column slicing, not kept seems slower
smallmodrref_lower(vector<vector<int>> & N,int lstart,int l,int lmax,int c,int cmax,const vector<int> & pivots,int modulo,bool debuginfo)7938   void smallmodrref_lower(vector< vector<int> > & N,int lstart,int l,int lmax,int c,int cmax,const vector<int> & pivots,int modulo,bool debuginfo){
7939     int ps=int(pivots.size());
7940     if (!ps) return;
7941     longlong modulo2=longlong(modulo)*modulo;
7942     bool convertpos= double(modulo2)*ps >= 9.22e18;
7943     if (convertpos)
7944       makepositive(N,lstart,lmax,c,cmax,modulo);
7945     vector<longlong> buffer(cmax);
7946     // slice in columns
7947     // this requires a first pass with effcmax=pivot.back()+1 (last col)
7948     // where linear combination coefficients are stored (in N)
7949     // then linear combinations are done using stored coefficients
7950     int effcmin,effcmax=giacmin(pivots.back()+1,cmax);
7951     if (cmax-effcmax<16)
7952       effcmax=cmax;
7953     for (int L=l;L<lmax;++L){
7954       // copy line to 64 bits buffer
7955       vector<int> & NL=N[L];
7956       if (NL.empty()) continue;
7957       for (int C=c;C<effcmax;++C)
7958 	buffer[C]=NL[C];
7959       // substract lines in pivots[k].first from column pivots[k].second to cmax
7960       for (int line=lstart;line<lstart+ps;++line){
7961 	int col=pivots[line-lstart];
7962 	if (col<0) continue;
7963 	vector<int> & Nline=N[line];
7964 	if (Nline.empty()){
7965 	  CERR << "rref_lower Bad matrix "<< lmax << "x" << cmax << " l" << line << " c" << col << '\n';
7966 	  continue;
7967 	}
7968 	if (Nline[col]!=1){
7969 	  Nline[col] %= modulo;
7970 	  if (Nline[col]!=1){
7971 	    CERR << "rref_lower Bad matrix "<< lmax << "x" << cmax << " l" << line << " c" << col << " " << Nline[col] << '\n';
7972 	    continue;
7973 	  }
7974 	}
7975 	longlong coeff=buffer[col];
7976 	if (coeff)
7977 	  coeff %= modulo;
7978 	buffer[col]=coeff;
7979 	if (!coeff) continue;
7980 	if (convertpos){
7981 	  int C=col+1;
7982 	  for (;C<effcmax;++C){
7983 	    longlong & b=buffer[C] ;
7984 	    longlong x = b;
7985 	    x -= coeff*Nline[C];
7986 	    x -= (x>>63)*modulo2;
7987 	    b=x;
7988 	  }
7989 	}
7990 	else {
7991 	  int C=col+1;
7992 	  for (;C<effcmax;++C){
7993 	    buffer[C] -= coeff*Nline[C];
7994 	  }
7995 	}
7996       }
7997       // copy back buffer to N[l]
7998       for (int C=c;C<effcmax;++C){
7999 	longlong x=buffer[C];
8000 	if (x)
8001 	  NL[C]=x % modulo;
8002 	else
8003 	  NL[C]=0;
8004       }
8005     }
8006     // slice: second pass for remaining columns
8007     effcmin=effcmax;
8008     int nslice=std::ceil(ps*double(cmax-effcmin)*sizeof(int)/32768); // lower matrix size/L1 cache size
8009     if (nslice<=0) nslice=1;
8010     int slicestep=std::ceil((cmax-effcmin)/nslice);
8011     if (slicestep<16) slicestep=16;
8012     for (;effcmin<cmax;effcmin=effcmax){
8013       effcmax=giacmin(effcmin+slicestep,cmax);
8014       for (int L=l;L<lmax;++L){
8015 	vector<int> & NL=N[L];
8016 	if (NL.empty()) continue;
8017 	for (int C=effcmin;C<effcmax;++C)
8018 	  buffer[C]=NL[C];
8019 	for (int line=lstart;line<lstart+ps;++line){
8020 	  int col=pivots[line-lstart];
8021 	  if (col<0) continue;
8022 	  vector<int> & Nline=N[line];
8023 	  longlong coeff=NL[col];
8024 	  if (!coeff) continue;
8025 	  if (convertpos){
8026 	    for (int C=effcmin;C<effcmax;++C){
8027 	      longlong & b=buffer[C] ;
8028 	      longlong x = b;
8029 	      x -= coeff*Nline[C];
8030 	      x -= (x>>63)*modulo2;
8031 	      b=x;
8032 	    }
8033 	  }
8034 	  else {
8035 	    for (int C=effcmin;C<effcmax;++C){
8036 	      buffer[C] -= coeff*Nline[C];
8037 	    }
8038 	  }
8039 	} // end loop on l
8040 	// copy back buffer to N[l]
8041 	for (int C=effcmin;C<effcmax;++C){
8042 	  longlong x=buffer[C];
8043 	  if (x)
8044 	    NL[C]=x % modulo;
8045 	  else
8046 	    NL[C]=0;
8047 	}
8048       } // end loop on L
8049     } // end slicing
8050     // reset stored linear combination coeffs to 0
8051     for (int L=l;L<lmax;++L){
8052       vector<int> & NL=N[L];
8053       if (NL.empty()) continue;
8054       for (int i=0;i<pivots.size();++i){
8055 	int c=pivots[i];
8056 	if (c<0) continue;
8057 	NL[c]=0;
8058       }
8059     }
8060   }
8061 #endif
8062 
8063   // find pivot columns in submatrix N[l..lmax-1,c..cmax-1]
smallmodrref_lower_pivots(vector<vector<int>> & N,int l,int lmax,int c,int cmax,vector<int> & pivots,int modulo)8064   void smallmodrref_lower_pivots(vector< vector<int> > & N,int l,int lmax,int c,int cmax,vector<int> & pivots,int modulo){
8065     pivots.clear();
8066     int L=l,C=c,k;
8067     for (;L<lmax && C<cmax;){
8068       // N is assumed to be already partially reduced
8069       vector<int> & NL=N[L];
8070       if (NL.empty()){
8071 	pivots.push_back(-1);
8072 	++L;
8073 	continue;
8074       }
8075       for (k=C;k<cmax;++k){
8076 	if (NL[k]){
8077 	  pivots.push_back(k);
8078 	  ++L; ++C;
8079 	  break;
8080 	}
8081       }
8082       if (k==cmax){
8083 	pivots.push_back(-1); ++L;
8084       }
8085     }
8086     while (!pivots.empty() && pivots.back()==-1)
8087       pivots.pop_back();
8088   }
8089 
free_null_lines(vector<vector<int>> & N,int l,int lmax,int c,int cmax)8090   void free_null_lines(vector< vector<int> > & N,int l,int lmax,int c,int cmax){
8091     if (c==0){
8092       for (int L=lmax-1;L>=l;--L){
8093 	vector<int> & NL=N[L];
8094 	if (NL.empty()) continue;
8095 	if (NL.size()!=cmax) break;
8096 	int C;
8097 	for (C=cmax-1;C>=c;--C){
8098 	  if (NL[C]) break;
8099 	}
8100 	if (C>=c) break;
8101 	NL.clear();
8102       }
8103     }
8104   }
8105 
8106   // finish full row reduction to echelon form if N is upper triangular
8107   // this is done from lmax-1 to l
smallmodrref_upper(vector<vector<int>> & N,int l,int lmax,int c,int cmax,int modulo)8108   void smallmodrref_upper(vector< vector<int> > & N,int l,int lmax,int c,int cmax,int modulo){
8109     // desalloc null lines
8110     free_null_lines(N,l,lmax,c,cmax);
8111     longlong modulo2=longlong(modulo)*modulo;
8112     bool convertpos= double(modulo2)*(lmax-l) >= 9.22e18;
8113     if (convertpos){
8114       makepositive(N,l,lmax,c,cmax,modulo);
8115     }
8116     vector< pair<int,int> > pivots;
8117     vector<longlong> buffer(cmax);
8118     for (int L=lmax-1;L>=l;--L){
8119       vector<int> & NL=N[L];
8120       if (NL.empty()) continue;
8121       if (debug_infolevel>1){
8122 	if (L%10==9){ CERR << "+"; CERR.flush();}
8123 	if (L%500==499){ CERR << CLOCK()*1e-6 << " remaining " << l-L << '\n'; }
8124       }
8125       if (!pivots.empty()){
8126 	// reduce line N[L]
8127 	// copy line to a 64 bits buffer
8128 	for (int C=c;C<cmax;++C)
8129 	  buffer[C]=NL[C];
8130 	// substract lines in pivots[k].first from column pivots[k].second to cmax
8131 	int ps=int(pivots.size());
8132 	for (int k=0;k<ps;++k){
8133 	  int line=pivots[k].first;
8134 	  const vector<int> & Nline=N[line];
8135 	  int col=pivots[k].second;
8136 	  longlong coeff=NL[col]; // or buffer[col]
8137 	  if (!coeff) continue;
8138 	  buffer[col]=0;
8139 	  // we could skip pivots columns here, but if they are not contiguous
8140 	  // this would take too much time
8141 	  if (convertpos){
8142 #if 0
8143 	    longlong * ptr=&buffer.front()+col+1, *ptrend=&buffer.front()+cmax,*ptrend_=ptrend-4;
8144 	    const int *nptr=&Nline.front()+col+1;
8145 	    for (;ptr<ptrend;++ptr,++nptr){
8146 	      longlong x=*ptr ;
8147 	      x -= coeff*(*nptr);
8148 	      x -= (x>>63)*modulo2;
8149 	      *ptr=x;
8150 	    }
8151 #else
8152 	    int C=col+1;
8153 	    for (;C<cmax;++C){
8154 	      longlong & b=buffer[C] ;
8155 	      longlong x = b;
8156 	      x -= coeff*Nline[C];
8157 	      x -= (x>>63)*modulo2;
8158 	      b=x;
8159 	    }
8160 #endif
8161 	  }
8162 	  else {
8163 	    int C=col+1;
8164 	    for (;C<cmax;++C){
8165 	      buffer[C] -= coeff*Nline[C];
8166 	    }
8167 	  }
8168 	}
8169 	// copy back buffer to N[l]
8170 	for (int C=c;C<cmax;++C){
8171 	  longlong x=buffer[C];
8172 	  if (x)
8173 	    NL[C]=x % modulo;
8174 	  else
8175 	    NL[C]=0;
8176 	}
8177       } // end if pivots.empty()
8178       // search pivot in N[L] starting column c+L-l to cmax
8179       for (int C=c+(L-l);C<cmax;++C){
8180 	if (NL[C]){
8181 	  if (NL[C]!=1)
8182 	    CERR << "rref_upper Bad matrix "<< lmax << "x" << cmax << '\n';
8183 	  pivots.push_back(pair<int,int>(L,C));
8184 	  break;
8185 	}
8186       }
8187     }
8188 #if 0
8189     for (int L=l;L<lmax;++L){
8190       vector<int> & NL=N[L];
8191       for (int C=c+(L-l);C<cmax;++C){
8192 	int & i=NL[C];
8193 	i = smod(i,modulo);
8194       }
8195     }
8196 #endif
8197   }
8198 
smallmodrref_lastpivotcol(const vector<vector<int>> & K,int lmax)8199   int smallmodrref_lastpivotcol(const vector< vector<int> > & K,int lmax){
8200     // first find the column of the last pivot
8201     int pivotcol=-1;
8202     for (int i=lmax-1;i>=0;--i){
8203       const vector<int> & Ki=K[i];
8204       for (int j=0;j<Ki.size();++j){
8205 	if (Ki[j]){
8206 	  return j;
8207 	}
8208       }
8209     }
8210     return -1;
8211   }
8212 
8213   struct smallmodrref_upper_t {
8214     vector< vector<int> > * N;
8215     int l,lpivot,lmax,c,cmax,modulo;
8216   };
8217 
do_thread_smallmodrref_upper(void * ptr_)8218   void * do_thread_smallmodrref_upper(void * ptr_){
8219     smallmodrref_upper_t * ptr=(smallmodrref_upper_t *)ptr_;
8220     in_thread_smallmodrref_upper(*ptr->N,ptr->l,ptr->lpivot,ptr->lmax,ptr->c,ptr->cmax,ptr->modulo,1);
8221     return ptr;
8222   }
8223 
8224   // finish full row reduction to echelon form if N is upper triangular
8225   // threaded version assuming the whole matrix N is reduced
8226   // pivots are searched starting at column 0 from lmax-1 to lpivot
8227   // but only colmuns c to cmax are reduced
8228   // beware if parallel!=1 that c>to the last pivot column
in_thread_smallmodrref_upper(vector<vector<int>> & N,int l,int lpivot,int lmax,int c,int cmax,int modulo,int parallel)8229   void in_thread_smallmodrref_upper(vector< vector<int> > & N,int l,int lpivot,int lmax,int c,int cmax,int modulo,int parallel){
8230 #ifdef HAVE_LIBPTHREAD
8231     if (parallel!=1) {
8232       pthread_t tab[parallel];
8233       smallmodrref_upper_t upperparam[parallel];
8234       int kstep=int(std::ceil((cmax-c)/double(parallel))),ccur=c;
8235       for (int j=0;j<parallel;++j){
8236 	int cnext=giacmin(cmax,ccur+kstep);
8237 	smallmodrref_upper_t tmp={&N,l,lpivot,lmax,ccur,cnext,modulo};
8238 	upperparam[j]=tmp;
8239 	ccur=cnext;
8240       }
8241       for (int j=0;j<parallel;++j){
8242 	bool res=true;
8243 	if (j<parallel-1)
8244 	  res=pthread_create(&tab[j],(pthread_attr_t *) NULL,do_thread_smallmodrref_upper,(void *) &upperparam[j]);
8245 	if (res)
8246 	  do_thread_smallmodrref_upper((void *)&upperparam[j]);
8247       }
8248       for (int j=0;j<parallel;++j){
8249 	void * ptr=(void *)&parallel; // non-zero initialisation
8250 	if (j<parallel-1)
8251 	  pthread_join(tab[j],&ptr);
8252       }
8253       return ;
8254     }
8255 #endif
8256     // free_null_lines(N,l,lmax,c,cmax); // already done
8257     longlong modulo2=longlong(modulo)*modulo;
8258     bool convertpos= double(modulo2)*(lmax-l) >= 9.22e18;
8259     if (convertpos){
8260       makepositive(N,l,lmax,c,cmax,modulo);
8261     }
8262     vector< pair<int,int> > pivots;
8263     vector<longlong> buffer(cmax);
8264     for (int L=lmax-1;L>=l;--L){
8265       vector<int> & NL=N[L];
8266       if (NL.empty()) continue;
8267       if (!pivots.empty()){
8268 	// reduce line N[L]
8269 	// copy line to a 64 bits buffer
8270 	for (int C=c;C<cmax;++C)
8271 	  buffer[C]=NL[C];
8272 	// substract lines in pivots[k].first from column pivots[k].second to cmax
8273 	int ps=int(pivots.size());
8274 	for (int k=0;k<ps;++k){
8275 	  int line=pivots[k].first;
8276 	  const vector<int> & Nline=N[line];
8277 	  int col=pivots[k].second;
8278 	  longlong coeff=NL[col];
8279 	  if (!coeff) continue;
8280 	  buffer[col]=0;
8281 	  int C=giacmax(c,col+1);
8282 	  if (convertpos){
8283 	    if (coeff<0)
8284 	      coeff += modulo;
8285 	    longlong * b=&buffer[C] ;
8286 	    const int * Nlineptr=&Nline[C],*Nlineend=&Nline[cmax]-4;
8287 	    for (;Nlineptr<Nlineend;){
8288 	      longlong x;
8289 	      x = *b-coeff* *Nlineptr;
8290 	      x -= (x>>63)*modulo2;
8291 	      *b=x;
8292  	      ++b; ++Nlineptr;
8293 	      x = *b-coeff* *Nlineptr;
8294 	      x -= (x>>63)*modulo2;
8295 	      *b=x;
8296  	      ++b; ++Nlineptr;
8297 	      x = *b-coeff* *Nlineptr;
8298 	      x -= (x>>63)*modulo2;
8299 	      *b=x;
8300  	      ++b; ++Nlineptr;
8301 	      x = *b-coeff* *Nlineptr;
8302 	      x -= (x>>63)*modulo2;
8303 	      *b=x;
8304  	      ++b; ++Nlineptr;
8305 	    }
8306 	    for (Nlineend+=4;Nlineptr<Nlineend;){
8307 	      longlong x;
8308 	      x = *b-coeff* *Nlineptr;
8309 	      x -= (x>>63)*modulo2;
8310 	      *b=x;
8311  	      ++b; ++Nlineptr;
8312 	    }
8313 	  }
8314 	  else {
8315 	    for (;C<cmax-4;C+=4){
8316 	      buffer[C] -= coeff*Nline[C];
8317 	      buffer[C+1] -= coeff*Nline[C+1];
8318 	      buffer[C+2] -= coeff*Nline[C+2];
8319 	      buffer[C+3] -= coeff*Nline[C+3];
8320 	    }
8321 	    for (;C<cmax;++C){
8322 	      buffer[C] -= coeff*Nline[C];
8323 	    }
8324 	  }
8325 	}
8326 	// copy back buffer to N[l]
8327 	for (int C=c;C<cmax;++C){
8328 	  longlong x=buffer[C];
8329 	  if (x)
8330 	    NL[C]=x % modulo;
8331 	  else
8332 	    NL[C]=0;
8333 	}
8334       } // end if pivots.empty()
8335       if (L>=lpivot){
8336 	// search pivot in N[L] starting column L-l to cmax
8337 	for (int C=(L-l);C<cmax;++C){
8338 	  if (NL[C]){
8339 	    if (NL[C]!=1)
8340 	      CERR << "rref_upper Bad matrix "<< lmax << "x" << cmax << '\n';
8341 	    pivots.push_back(pair<int,int>(L,C));
8342 	    break;
8343 	  }
8344 	}
8345       }
8346     }
8347   }
8348 
thread_smallmodrref_upper(vector<vector<int>> & K,int l,int lmax,int c,int cmax,int modulo,int parallel)8349   void thread_smallmodrref_upper(vector< vector<int> > & K,int l,int lmax,int c,int cmax,int modulo,int parallel){
8350     free_null_lines(K,l,lmax,c,cmax);
8351     // effective lmax computation
8352     while (lmax>=1 && K[lmax-1].empty())
8353       --lmax;
8354     // parallelize upper rref
8355     int pivotcol=smallmodrref_lastpivotcol(K,lmax);
8356     if (cmax-pivotcol<16*parallel)
8357       smallmodrref_upper(K,l,lmax,c,cmax,modulo);
8358     else {
8359       // columns pivotcol+1 to cmax can be reduced in parallel
8360       in_thread_smallmodrref_upper(K,l,l,lmax,pivotcol+1,cmax,modulo,parallel);
8361       if (debug_infolevel>1)
8362 	CERR << CLOCK()*1e-6 << " rref_upper " << lmax << "*" << pivotcol+1 << "," << cmax-pivotcol-1 << '\n';
8363       int l1=(l+lmax)/2;
8364       int pc=smallmodrref_lastpivotcol(K,l1);
8365       if (cmax-pc <16*parallel
8366 	  || lmax-l<16
8367 	  )
8368 	// this part of the reduction must be done at the end
8369 	// otherwise we would loose the coefficients of the linear combinations
8370 	in_thread_smallmodrref_upper(K,l,l,lmax,c,pivotcol+1,modulo,1/*parallel*/);
8371       else {
8372 	// reduce right part with respect to the lower part first
8373 	in_thread_smallmodrref_upper(K,l,l1,lmax,pc+1,pivotcol+1,modulo,1/*parallel*/);
8374 	// parallel reduce upper right part
8375         if (debug_infolevel>1)
8376           CERR << CLOCK()*1e-6 << " rref_upper_parallel " << l1-l << "*" << pivotcol-pc <<"/" << pivotcol-c << '\n';
8377 	in_thread_smallmodrref_upper(K,l,l,l1,pc+1,pivotcol+1,modulo,parallel);
8378         if (debug_infolevel>1)
8379           CERR << CLOCK()*1e-6 << " rref_upper_parallel end" << '\n';
8380 	// reduce left part
8381 	in_thread_smallmodrref_upper(K,l,l,l1,c,pc+1,modulo,1/*parallel*/);
8382       }
8383     }
8384   }
8385 
do_modular_reduction(vector<vector<int>> & N,int l,int pivotcol,int pivotval,int linit,int lmax,int c,int effcmax,int rref_or_det_or_lu,int modulo)8386   void do_modular_reduction(vector< vector<int> > & N,int l,int pivotcol,int pivotval,int linit,int lmax,int c,int effcmax,int rref_or_det_or_lu,int modulo){
8387 #ifndef GIAC_HAS_STO_38
8388     int l1,l2,l3;
8389 #endif
8390     bool ludecomp=rref_or_det_or_lu>=2;
8391     for (int ltemp=linit;ltemp<lmax;++ltemp){
8392       if (ltemp==l || N[ltemp].empty() || !N[ltemp][pivotcol])
8393 	continue;
8394 #ifndef GIAC_HAS_STO_38
8395       if (!ludecomp && find_multi_linear_combination(N,ltemp,l1,l2,l3,pivotcol,l,lmax)){
8396 	int_multilinear_combination(N[ltemp],-N[ltemp][pivotcol],N[l1],-N[l1][pivotcol],N[l2],-N[l2][pivotcol],N[l3],-N[l3][pivotcol],N[l],modulo,c,effcmax);
8397 	ltemp = l3;
8398 	continue;
8399       }
8400       if (ludecomp && ltemp<=lmax-4 && !N[ltemp+1].empty() && N[ltemp+1][pivotcol] && !N[ltemp+2].empty() && N[ltemp+2][pivotcol] && !N[ltemp+3].empty() && N[ltemp+3][pivotcol]){
8401 
8402 	N[ltemp][pivotcol]= (N[ltemp][pivotcol]*longlong(pivotval)) % modulo;
8403 	N[ltemp+1][pivotcol]= (N[ltemp+1][pivotcol]*longlong(pivotval)) % modulo;
8404 	N[ltemp+2][pivotcol]= (N[ltemp+2][pivotcol]*longlong(pivotval)) % modulo;
8405 	N[ltemp+3][pivotcol]= (N[ltemp+3][pivotcol]*longlong(pivotval)) % modulo;
8406 	int_multilinear_combination(N[ltemp],-N[ltemp][pivotcol],N[ltemp+1],-N[ltemp+1][pivotcol],N[ltemp+2],-N[ltemp+2][pivotcol],N[ltemp+3],-N[ltemp+3][pivotcol],N[l],modulo,(rref_or_det_or_lu>0)?(c+1):c,effcmax);
8407 	ltemp+= (4-1);
8408 	continue;
8409       }
8410 #endif
8411       if (ludecomp)
8412 	N[ltemp][pivotcol]= (N[ltemp][pivotcol]*longlong(pivotval)) % modulo;
8413       modlinear_combination(N[ltemp],-N[ltemp][pivotcol],N[l],modulo,(rref_or_det_or_lu>0)?(c+1):c,effcmax,true /* pseudomod */);
8414     }
8415   }
8416 
LL_modular_reduction(vector<vector<longlong>> & N,int l,int pivotcol,int pivotval,int linit,int lmax,int c,int effcmax,int rref_or_det_or_lu,int modulo)8417   void LL_modular_reduction(vector< vector<longlong> > & N,int l,int pivotcol,int pivotval,int linit,int lmax,int c,int effcmax,int rref_or_det_or_lu,int modulo){
8418 #ifndef GIAC_HAS_STO_38
8419     int l1,l2,l3;
8420 #endif
8421     bool ludecomp=rref_or_det_or_lu>=2;
8422     for (int ltemp=linit;ltemp<lmax;++ltemp){
8423       if (ltemp==l || N[ltemp].empty() || !N[ltemp][pivotcol])
8424 	continue;
8425 #ifndef GIAC_HAS_STO_38
8426       if (!ludecomp && find_multi_linear_combination(N,ltemp,l1,l2,l3,pivotcol,l,lmax)){
8427 	int coeff0=(N[ltemp][pivotcol] %= modulo);
8428 	int coeff1=(N[l1][pivotcol] %= modulo);
8429 	int coeff2=(N[l2][pivotcol] %= modulo);
8430 	int coeff3=(N[l3][pivotcol] %= modulo);
8431 	if (rref_or_det_or_lu==1){
8432 	  coeff0 = (coeff0*longlong(pivotval)) % modulo;
8433 	  coeff1 = (coeff1*longlong(pivotval)) % modulo;
8434 	  coeff2 = (coeff2*longlong(pivotval)) % modulo;
8435 	  coeff3 = (coeff3*longlong(pivotval)) % modulo;
8436 	}
8437 	LL_multilinear_combination(N[ltemp],-coeff0,N[l1],-coeff1,N[l2],-coeff2,N[l3],-coeff3,N[l],modulo,c,effcmax);
8438 	ltemp = l3;
8439 	continue;
8440       }
8441 #endif
8442       int coeff;
8443       if (ludecomp) {
8444 	int tmp=N[ltemp][pivotcol] % modulo;
8445 	coeff = int(N[ltemp][pivotcol] = (longlong(tmp)*pivotval) % modulo);
8446       }
8447       else {
8448 	coeff = (N[ltemp][pivotcol] %= modulo);
8449 	if (rref_or_det_or_lu==1)
8450 	  coeff = (coeff * longlong(pivotval))%modulo;
8451       }
8452       modlinear_combination(N[ltemp],-coeff,N[l],modulo,(rref_or_det_or_lu>0)?(c+1):c,effcmax);
8453     }
8454   }
8455 
8456   struct thread_modular_reduction_t {
8457     vector< vector<int> > * Nptr;
8458     vector<int> * pivotcols;
8459     int l,pivotcol,pivotval,linit,lmax,c,effcmax,rref_or_det_or_lu,modulo;
8460     bool debuginfo;
8461   };
8462 
do_thread_modular_reduction(void * ptr_)8463   void * do_thread_modular_reduction(void * ptr_){
8464     thread_modular_reduction_t * ptr=(thread_modular_reduction_t *) ptr_;
8465     do_modular_reduction(*ptr->Nptr,ptr->l,ptr->pivotcol,ptr->pivotval,ptr->linit,ptr->lmax,ptr->c,ptr->effcmax,ptr->rref_or_det_or_lu,ptr->modulo);
8466     return ptr;
8467   }
8468 
do_thread_lower_reduction(void * ptr_)8469   void * do_thread_lower_reduction(void * ptr_){
8470     thread_modular_reduction_t * ptr=(thread_modular_reduction_t *) ptr_;
8471     smallmodrref_lower(*ptr->Nptr,ptr->linit,ptr->l,ptr->lmax,ptr->c,ptr->effcmax,*ptr->pivotcols,ptr->modulo,ptr->debuginfo);
8472     return ptr;
8473   }
8474 
8475   // attempt to speedup smallmodrref by using longlong intermediate matrix
8476   // modulo is assumed prime if carac==-1
8477   // or compute det (rref_or_det_or_lu==1) and modulo==carac^k with carac prime
LLsmallmodrref(vector<vector<int>> & Nint,int l_,int lmax_,int c_,int cmax_,vecteur & pivots,vector<int> & permutation,vector<int> & maxrankcols,longlong & idet,int fullreduction,int dont_swap_below,int modulo,int carac,int rref_or_det_or_lu)8478   bool LLsmallmodrref(vector< vector<int> > & Nint,int l_,int lmax_,int c_,int cmax_,vecteur & pivots,vector<int> & permutation,vector<int> & maxrankcols,longlong & idet,int fullreduction,int dont_swap_below,int modulo,int carac,int rref_or_det_or_lu){
8479     // return false;
8480     bool inverting=fullreduction==2;
8481     int L=lmax_-l_,C=cmax_-c_;
8482     // copy Nint matrix
8483     vector< vector<longlong> > N(L);
8484     for (int i=0;i<L;++i){
8485       const vector<int> & source=Nint[l_+i];
8486       if (source.empty()) continue;
8487       vector<longlong> & target=N[i];
8488       target.resize(C);
8489       for (int j=0;j<C;++j)
8490 	target[j]=source[c_+j];
8491     }
8492     // reduce N, reflect line permutations for empty lines in Nint
8493     int l=0,lmax=L,c=0,cmax=C,pivotline,pivotcol,pivot,temp;
8494     bool noswap;
8495     for (;l<lmax && c<cmax;){
8496       pivot = N[l].empty()?0:(N[l][c] %= modulo);
8497       if (rref_or_det_or_lu==3 && !pivot){
8498 	idet=0;
8499 	return true;
8500       }
8501       if ( rref_or_det_or_lu==1 && l==lmax-1 ){
8502 	idet = (idet * pivot) % modulo ;
8503 	break;
8504       }
8505       pivotline=l;
8506       pivotcol=c;
8507       if ( (carac==-1?pivot:(pivot % carac))==0 ){ // scan current line
8508 	noswap=false;
8509 	if (l<dont_swap_below){
8510 	  for (int ctemp=c+1;ctemp<cmax;++ctemp){
8511 	    temp = N[l].empty()?0:(N[l][ctemp] %= modulo);
8512 	    if (carac==-1?temp:(temp % carac)){
8513 	      pivot=smod(temp,modulo);
8514 	      pivotcol=ctemp;
8515 	      break;
8516 	    }
8517 	  }
8518 	}
8519 	else {      // scan N current column for the best pivot available
8520 	  for (int ltemp=l+1;ltemp<lmax;++ltemp){
8521 	    temp = N[ltemp].empty()?0:(N[ltemp][c] %= modulo);
8522 	    if (carac==-1?temp:(temp % carac)){
8523 	      pivot=smod(temp,modulo);
8524 	      pivotline=ltemp;
8525 	      break;
8526 	    }
8527 	  }
8528 	}
8529       } // end if is_zero(pivot),
8530       if ( (carac==-1?pivot:(pivot % carac))==0 ){
8531 	if (carac>0){
8532 	  if (rref_or_det_or_lu!=1)
8533 	    return false;
8534 	  bool not0=false;
8535 	  // divide column by carac, multiply det by carac and retry
8536 	  idet = (longlong(idet)*carac) % modulo;
8537 	  for (int L=l;L<lmax;++L){
8538 	    if (!N[L].empty()){
8539 	      if (N[L][c] /= carac)
8540 		not0=true;
8541 	    }
8542 	  }
8543 	  if (not0)
8544 	    continue;
8545 	}
8546 	idet = 0;
8547 	if (rref_or_det_or_lu==1)
8548 	  break;
8549 	if (l>=dont_swap_below)
8550 	  c++;
8551 	else
8552 	  l++;
8553 	continue;
8554       }
8555       // true pivot found on line or column
8556       if (debug_infolevel>1){
8557 	if (l%10==9){ CERR << "+"; CERR.flush();}
8558 	if (l%500==499){ CERR << CLOCK()*1e-6 << " remaining " << lmax-l << '\n'; }
8559       }
8560       maxrankcols.push_back(c_+c);
8561       if (l!=pivotline){
8562 	swap(N[l],N[pivotline]);
8563 	swap(Nint[l_+l],Nint[l_+pivotline]);
8564 	swap(permutation[l_+l],permutation[l_+pivotline]);
8565 	pivotline=l;
8566 	idet = -idet;
8567       }
8568       // save pivot for annulation test purposes
8569       if (rref_or_det_or_lu!=1)
8570 	pivots.push_back(pivot);
8571       // invert pivot. If pivot==1 we might optimize but only if allow_bloc is true
8572       temp=invmod(pivot,modulo);
8573       // multiply det
8574       idet = (idet * pivot) % modulo ;
8575       if (fullreduction || rref_or_det_or_lu<1){ // not LU decomp
8576 	vector<longlong>::iterator it=N[pivotline].begin()+c,itend=N[pivotline].end();
8577 	for (;it!=itend;++it){
8578 	  longlong tmp=*it;
8579 	  if (!tmp) continue;
8580 	  tmp %= modulo;
8581 	  tmp=(temp * tmp)%modulo;
8582 	  *it=tmp; // *it=smod_adjust(tmp,modulo);
8583 	}
8584       }
8585       else {
8586 	// reduce remainder of line pivotline
8587 	vector<longlong>::iterator it=N[pivotline].begin()+c,itend=N[pivotline].end();
8588 	for (;it!=itend;++it){
8589 	  longlong tmp=*it;
8590 	  if (!tmp) continue;
8591 	  *it=tmp%modulo;
8592 	}
8593       }
8594       // if there are 0 at the end, ignore them in linear combination
8595       int effcmax=(fullreduction && inverting && noswap)?c+lmax:cmax-1;
8596       const std::vector<longlong> & Npiv=N[l];
8597       for (;effcmax>=c;--effcmax){
8598 	if (Npiv[effcmax])
8599 	  break;
8600       }
8601       ++effcmax;
8602       int effl=fullreduction?0:l+1;
8603       LL_modular_reduction(N,l,pivotcol,temp,effl,lmax,c,effcmax,rref_or_det_or_lu,modulo);
8604       // increment column number if swap was allowed
8605       if (l>=dont_swap_below)
8606 	++c;
8607       // increment line number since reduction has been done
8608       ++l;
8609     } // for (l<lmax && c<cmax)
8610     // back copy into Nint
8611     if (rref_or_det_or_lu!=1){
8612       for (int i=0;i<L;++i){
8613 	const vector<longlong> & source=N[i];
8614 	vector<int> & target=Nint[l_+i];
8615 	if (source.empty()){
8616 	  if (!target.empty())
8617 	    CERR << "inconsistency" << '\n';
8618 	  continue;
8619 	}
8620 	else {
8621 	  if (target.empty())
8622 	    CERR << "inconsistency" << '\n';
8623 	}
8624 	for (int j=0;j<C;++j)
8625 	  target[c_+j]=smod(source[j],modulo);
8626       }
8627     }
8628     return rref_or_det_or_lu!=0 || l_==0;//true; // we can not return true for fullreduction, because the upper lines are not reduced
8629   }
8630 
8631   // if dont_swap_below !=0, for line numers < dont_swap_below
8632   // the pivot is searched in the line instead of the column
8633   // hence no line swap occur
8634   // rref_or_det_or_lu = 0 for rref, 1 for det, 2 for lu,
8635   // 3 for lu without permutation
8636   // fullreduction=0 or 1, use 2 if the right part of a is idn
smallmodrref(int nthreads,vector<vector<int>> & N,vecteur & pivots,vector<int> & permutation,vector<int> & maxrankcols,longlong & idet,int l,int lmax,int c,int cmax,int fullreduction,int dont_swap_below,int modulo,int rref_or_det_or_lu,bool reset,smallmodrref_temp_t * workptr,bool allow_block,int carac)8637   void smallmodrref(int nthreads,vector< vector<int> > & N,vecteur & pivots,vector<int> & permutation,vector<int> & maxrankcols,longlong & idet,int l, int lmax, int c,int cmax,int fullreduction,int dont_swap_below,int modulo,int rref_or_det_or_lu,bool reset,smallmodrref_temp_t * workptr,bool allow_block,int carac){
8638     bool inverting=fullreduction==2;
8639     int linit=l;//,previous_l=l;
8640     // Reduction
8641     int pivot,temp=0;
8642     // vecteur vtemp;
8643     int pivotline,pivotcol=0;
8644     if (reset){
8645       idet=1;
8646       pivots.clear();
8647       pivots.reserve(cmax-c);
8648       permutation.clear();
8649       maxrankcols.clear();
8650       for (int i=0;i<lmax;++i)
8651 	permutation.push_back(i);
8652     }
8653     int ilmax=lmax;
8654     if (allow_block){
8655       for (int i=0;i<lmax-1;){
8656       if (N[lmax-1].empty()){
8657       --lmax;
8658       continue;
8659       }
8660       if (N[i].empty()){
8661 	swap(N[i],N[lmax-1]);
8662 	swap(permutation[i],permutation[lmax-1]);
8663 	--lmax;
8664       }
8665       ++i;
8666     }
8667     }
8668     if (debug_infolevel>2)
8669       CERR << CLOCK()*1e-6 << " Effective number of rows " << lmax << "/" << ilmax << '\n';
8670     bool noswap=true;
8671     smallmodrref_temp_t * tmpptr = workptr;
8672 #ifndef GIAC_HAS_STO_38
8673     if (allow_block && (rref_or_det_or_lu==0
8674 			//|| rref_or_det_or_lu==1
8675 			) && dont_swap_below==0 ){
8676       if (
8677 	  //lmax-l>=4 && cmax-c>=4
8678 	  lmax-l>=2.5*mmult_int_blocksize && cmax-c>=2.5*mmult_int_blocksize
8679 	){
8680 	// this is not as fast as block reduction for dense matrices
8681 	// a sparsness test could be useful
8682 	// reduce first half
8683 	int halfl=(lmax-l)/2,effl=l+halfl;
8684 	if (debug_infolevel>2)
8685 	  CERR << CLOCK()*1e-6 << " rref begin " << lmax-l << "x" << cmax-c << '\n';
8686 	smallmodrref(nthreads,N,pivots,permutation,maxrankcols,idet,l,l+halfl,c,cmax,0/*fullreduction*/,0,modulo,0,false,workptr,true,carac);
8687 	// use first half for second half
8688 	vector<int> pivotcols;
8689 	smallmodrref_lower_pivots(N,l,effl,c,cmax,pivotcols,modulo);
8690 	bool reduction_done=false;
8691 	if (debug_infolevel>2)
8692 	  CERR << CLOCK()*1e-6 << " rref_lower begin " << effl << ".." << lmax << "/" << c << ".." << cmax << '\n';
8693 	// CERR << pivotcols << '\n';
8694 #ifdef HAVE_LIBPTHREAD
8695 	if (nthreads>1 && double(lmax-effl)*(cmax-c)>1e5){
8696 	  pthread_t tab[64];
8697 	  thread_modular_reduction_t redparam[64];
8698 	  if (nthreads>64) nthreads=64;
8699 	  for (int j=0;j<nthreads;++j){
8700 	    thread_modular_reduction_t tmp={&N,&pivotcols,effl,pivotcol,temp,l,lmax,c,cmax,rref_or_det_or_lu,modulo,j==0 && debug_infolevel>2};
8701 	    redparam[j]=tmp;
8702 	  }
8703 	  int kstep=int(std::ceil((lmax-effl)/double(nthreads))),k=effl;
8704 	  for (int j=0;j<nthreads;++j){
8705 	    redparam[j].l=k;
8706 	    k += kstep;
8707 	    if (k>lmax)
8708 	      k=lmax;
8709 	    redparam[j].lmax=k;
8710 	    bool res=true;
8711 	    if (j<nthreads-1)
8712 	      res=pthread_create(&tab[j],(pthread_attr_t *) NULL,do_thread_lower_reduction,(void *) &redparam[j]);
8713 	    if (res)
8714 	      do_thread_lower_reduction((void *)&redparam[j]);
8715 	  }
8716 	  for (int j=0;j<nthreads;++j){
8717 	    void * ptr=(void *)&nthreads; // non-zero initialisation
8718 	    if (j<nthreads-1)
8719 	      pthread_join(tab[j],&ptr);
8720 	  }
8721 	  reduction_done=true;
8722 	}
8723 #endif
8724 	if (!reduction_done)
8725 	  smallmodrref_lower(N,l,effl,lmax,c,cmax,pivotcols,modulo,debug_infolevel>2);
8726 	if (debug_infolevel>2)
8727 	  CERR << CLOCK()*1e-6 << " rref_lower end " << effl << ".." << lmax << "/" << c << ".." << cmax << '\n';
8728 	// reduce second half
8729 	//cerr << N <<'\n';
8730 	smallmodrref(nthreads,N,pivots,permutation,maxrankcols,idet,l+halfl,lmax,c+(idet && rref_or_det_or_lu==1?halfl:0),cmax,0/*fullreduction*/,0,modulo,0,false,workptr,true,carac);
8731 	if (debug_infolevel>2)
8732 	  CERR << CLOCK()*1e-6 << " rref end " << lmax-l << "x" << cmax-c << '\n';
8733 	//cerr << N <<'\n';
8734 #if 1
8735 	// finish reduction with permutations only
8736 	int L=l,C=c,r;
8737 	for (;L<lmax && C<cmax;){
8738 	  for (r=L;r<lmax;++r){
8739 	    if (!N[r].empty() && N[r][C])
8740 	      break;
8741 	  }
8742 	  if (r==lmax){
8743 	    ++C; continue;
8744 	  }
8745 	  if (r>L){
8746 	    if (N[r][C]!=1)
8747 	      COUT << "erreur" << N[r][C] << '\n';
8748 	    swap(N[r],N[L]);
8749 	    swap(permutation[r],permutation[L]);
8750 	    idet=-idet;
8751 	    // swap(pivots[r],pivots[L]);
8752 	  }
8753 	  ++L; ++C;
8754 	}
8755 	if (fullreduction)
8756 	  smallmodrref_upper(N,l,lmax,c,cmax,modulo);
8757 	return;
8758       } else nthreads=1;
8759 #endif
8760     }
8761     bool blocktest=allow_block && rref_or_det_or_lu!=0 && lmax-l>=2*mmult_int_blocksize && cmax-c>=2*mmult_int_blocksize;
8762     if (blocktest){
8763       // count 0 in N[l->lmax][c->cmax]
8764       // if matrix is sparse, then block operations is not faster
8765       double count=0;
8766       for (int i=l;i<lmax;++i){
8767 	if (N[i].empty()){ blocktest=false; break; }
8768 	vector<int>::const_iterator it=N[l].begin()+c,itend=N[l].begin()+giacmin(cmax,N[l].size());
8769 	for (;it!=itend;++it){
8770 	  if (!*it)
8771 	    ++count;
8772 	}
8773       }
8774       count=(count/(lmax-l)/(cmax-c));
8775       if (count>.8)
8776 	blocktest=false;
8777     }
8778     if (!workptr){
8779       if (blocktest)
8780 	tmpptr = new smallmodrref_temp_t;
8781       else
8782 	tmpptr=0;
8783     }
8784     if (//0 &&
8785 	rref_or_det_or_lu==2 &&
8786 	giacmax(lmax-l,cmax-c)*double(modulo)*modulo<(1ULL << 63) &&
8787 	blocktest
8788 	){
8789       // diag(P1,P2)*[[A,B],[C,D]]=[[L1,0],[L3,L2]]*[[U1,U3],[0,U2]]
8790       // hence P1*A=L1*U1, recursive call will determine L1, U1 and P1
8791       // if A is not invertible, failure (keep a copy of A in case)
8792       // line swaps corresponding to P1 will replace inplace B by P1*B
8793       // then P1*B=L1*U3, determine columns of U3 by int_linsolve_l, replace B with U3
8794       // keep columns of U3 in lines for later use in matrix product
8795       // P2*C=L3*U1, hence P2^-1*L3 is determined by int_linsolve_u, replace C with P2^-1*L3
8796       // P2*D=L3*U3+L2*U2 -> P2*(D-P2^-1*L3*U3)=L2*U2
8797       // substract P2^-1*L3*U3 from D and recursive call to lu will determine P2, L2 and U2
8798       // (line swaps will replace inplace P2^-1*L3 by L3)
8799       int taille=giacmin(lmax-l,cmax-c)/2;
8800       if (debug_infolevel>2)
8801 	CERR << CLOCK()*1e-6 << " recursive call mod " << modulo << " size " << taille << '\n';
8802       tmpptr->Ainv.resize(cmax-c-taille);
8803       tmpptr->y.resize(taille);
8804       tmpptr->y1.resize(taille);
8805       tmpptr->y2.resize(taille);
8806       tmpptr->y3.resize(taille);
8807       tmpptr->z.resize(taille);
8808       tmpptr->z1.resize(taille);
8809       tmpptr->z2.resize(taille);
8810       tmpptr->z3.resize(taille);
8811       for (int i=0;i<taille;i++){
8812 	int * source=&N[l+i][c];
8813 	tmpptr->Ainv[i].resize(taille);
8814 	vector<int>::iterator it=tmpptr->Ainv[i].begin(),itend=tmpptr->Ainv[i].end();
8815 	for (;it!=itend;++source,++it)
8816 	  *it=*source;
8817       }
8818       smallmodrref(nthreads,N,pivots,permutation,maxrankcols,idet,l,l+taille,c,c+taille,false,false,modulo,2,false,0,true,carac);
8819       if (!idet){
8820 	// restore N from tmpptr->Ainv
8821 	for (int i=0;i<taille;++i){
8822 	  int * target=&N[l+i][c];
8823 	  vector<int>::const_iterator it=tmpptr->Ainv[i].begin(),itend=tmpptr->Ainv[i].end();
8824 	  for (;it!=itend;++target,++it)
8825 	    *target = *it;
8826 	}
8827       }
8828       else {
8829 	// find U3: L1*U3=P1*B, cmax-c-taille systems to solve, each has taille unknowns
8830 	int i=0;
8831 	for (;i<=cmax-c-taille-4;i+=4){
8832 	  for (int j=0;j<taille;j++){
8833 	    tmpptr->y[j]=N[l+j][i+c+taille];
8834 	    tmpptr->y1[j]=N[l+j][i+1+c+taille];
8835 	    tmpptr->y2[j]=N[l+j][i+2+c+taille];
8836 	    tmpptr->y3[j]=N[l+j][i+3+c+taille];
8837 	  }
8838 	  int_linsolve_l4(N,l,c,tmpptr->y,tmpptr->y1,tmpptr->y2,tmpptr->y3,tmpptr->Ainv[i],tmpptr->Ainv[i+1],tmpptr->Ainv[i+2],tmpptr->Ainv[i+3],modulo);
8839 	  // copy into N
8840 	  for (int j=0;j<taille;j++){
8841 	    N[l+j][i+c+taille]=tmpptr->Ainv[i][j];
8842 	    N[l+j][i+1+c+taille]=tmpptr->Ainv[i+1][j];
8843 	    N[l+j][i+2+c+taille]=tmpptr->Ainv[i+2][j];
8844 	    N[l+j][i+3+c+taille]=tmpptr->Ainv[i+3][j];
8845 	  }
8846 	}
8847 	for (;i<cmax-c-taille;++i){
8848 	  for (int j=0;j<taille;j++){
8849 	    tmpptr->y[j]=N[l+j][i+c+taille];
8850 	  }
8851 	  int_linsolve_l(N,l,c,tmpptr->y,tmpptr->Ainv[i],modulo);
8852 	  // copy into N
8853 	  for (int j=0;j<taille;j++)
8854 	    N[l+j][i+c+taille]=tmpptr->Ainv[i][j];
8855 	}
8856 	// find P2^-1*L3: P2^-1*L3*U1=C, lmax-l-taille systems to solve, each with taille unknowns
8857 	for (i=0;i<=lmax-l-taille-4;i+=4){
8858 	  for (int j=0;j<taille;j++){
8859 	    tmpptr->y[j]=N[i+l+taille][c+j];
8860 	    tmpptr->y1[j]=N[i+1+l+taille][c+j];
8861 	    tmpptr->y2[j]=N[i+2+l+taille][c+j];
8862 	    tmpptr->y3[j]=N[i+3+l+taille][c+j];
8863 	  }
8864 	  int_linsolve_u4(N,l,c,tmpptr->y,tmpptr->y1,tmpptr->y2,tmpptr->y3,tmpptr->z,tmpptr->z1,tmpptr->z2,tmpptr->z3,modulo);
8865 	  for (int j=0;j<taille;j++){
8866 	    N[i+l+taille][c+j]=tmpptr->z[j];
8867 	    N[i+1+l+taille][c+j]=tmpptr->z1[j];
8868 	    N[i+2+l+taille][c+j]=tmpptr->z2[j];
8869 	    N[i+3+l+taille][c+j]=tmpptr->z3[j];
8870 	  }
8871 	}
8872 	for (;i<lmax-l-taille;++i){
8873 	  for (int j=0;j<taille;j++){
8874 	    tmpptr->y[j]=N[i+l+taille][c+j];
8875 	  }
8876 	  int_linsolve_u(N,l,c,tmpptr->y,tmpptr->z,modulo);
8877 	  for (int j=0;j<taille;j++){
8878 	    N[i+l+taille][c+j]=tmpptr->z[j];
8879 	  }
8880 	}
8881 	// substract L3*U3 from D
8882 	in_mmult_mod(N,tmpptr->Ainv,N,l+taille,c+taille,modulo,l+taille,lmax,c,c+taille,false);
8883 	// final lu decomposition
8884 	smallmodrref(nthreads,N,pivots,permutation,maxrankcols,idet,l+taille,lmax,c+taille,cmax,false,false,modulo,2,false,0,true,carac);
8885 	if (debug_infolevel>2)
8886 	  CERR << CLOCK()*1e-6 << " end recursive call mod " << modulo << " size " << taille << '\n';
8887 	// matrice dbg;
8888 	// vectvector_int2vecteur(N,dbg);
8889 	// CERR << smod(dbg,modulo) << '\n';
8890 	if (!workptr && tmpptr)
8891 	  delete tmpptr;
8892 	return;
8893       } // end else idet==0
8894     }
8895 #endif // GIAC_HAS_STO_38
8896 #ifdef GIAC_DETBLOCK
8897     int det_blocksize=mmult_int_blocksize;
8898     bool tryblock=blocktest && rref_or_det_or_lu==1 && giacmax(mmult_int_blocksize,det_blocksize)*double(modulo)*modulo<((1ULL << 63)) && lmax-l>=3*det_blocksize && cmax-c>=3*det_blocksize;
8899     // commented because it's slower...
8900     // if (tryblock) det_blocksize=giacmin((lmax-l)/3,(cmax-c)/3);
8901     if (tmpptr){
8902       tmpptr->Ainvtran.resize(det_blocksize);
8903       tmpptr->Ainv.resize(det_blocksize);
8904     }
8905 #endif
8906     for (;(l<lmax) && (c<cmax);){
8907 #ifdef GIAC_DETBLOCK
8908       if (tryblock &&lmax-l>=3*det_blocksize && cmax-c>=3*det_blocksize && l % det_blocksize==0 && c % det_blocksize==0){
8909 	// try to invert block of size det_blocksize
8910 	for (int i=0;i<det_blocksize;++i){
8911 	  tmpptr->Ainv[i].reserve(2*det_blocksize);
8912 	  tmpptr->Ainv[i].resize(det_blocksize);
8913 	  int * Ai=&tmpptr->Ainv[i][0];
8914 	  int * Ni=&N[l+i][c], *Niend=Ni+det_blocksize;
8915 	  for (;Ni!=Niend;++Ai,++Ni)
8916 	    *Ai=*Ni;
8917 	}
8918 	// lu
8919 	tmpptr->permblock.clear(); tmpptr->maxrankblock.clear(); tmpptr->pivblock.clear();
8920 	longlong idetblock;
8921 	if (debug_infolevel>2)
8922 	  CERR << CLOCK()*1e-6 << "block reduction mod " << modulo << " size " << det_blocksize << " " << workptr << '\n';
8923 	smallmodrref(nthreads,tmpptr->Ainv,tmpptr->pivblock,tmpptr->permblock,tmpptr->maxrankblock,idetblock,0,det_blocksize,0,det_blocksize,0,false,modulo,2,true,0,true,carac);
8924 	if (idetblock){
8925 	  idet = ((idetblock % modulo)*idet)%modulo;
8926 	  int_lu2inv(tmpptr->Ainv,modulo,tmpptr->permblock);
8927 	  // [[A^-1,0],[-C*A^-1,I]] * [[A,B],[C,D]] = [[I,A^-1*B],[0,-C*A^-1*B+D]]
8928 	  // first compute -C*A^-1
8929 	  // transpose Ainv and negate
8930 	  tran_int(tmpptr->Ainv,tmpptr->Ainvtran);
8931 	  negate_int(tmpptr->Ainvtran);
8932 	  mmult_mod(N,tmpptr->Ainvtran,tmpptr->CAinv,modulo,l+det_blocksize,lmax,c,c+det_blocksize);
8933 	  // transpose B
8934 	  tran_int(N,tmpptr->Ainv,l,l+det_blocksize,c+det_blocksize,cmax);
8935 	  // D += CAinv*B
8936 	  l += det_blocksize;
8937 	  c += det_blocksize;
8938 #if 0
8939 	  mmult_mod(tmpptr->CAinv,tmpptr->Ainv,N,modulo,0,0,0,0,0,0,0,l,c,true);
8940 #else
8941 	  in_mmult_mod(tmpptr->CAinv,tmpptr->Ainv,N,l,c,modulo,0,0,0,0,true);
8942 #endif
8943 	  continue;
8944 	}
8945       } // end tryblock
8946 #endif // GIAC_DETBLOCK
8947       // normal Gauss reduction
8948       if (
8949 	  // FIXME: if fullreduction, upper reduction should be done!
8950 	  (carac>0 || (lmax-l>=32 && cmax-c>=32) ) && (lmax-l)*double(modulo)*double(modulo)<(1ULL<<63) &&
8951 	  //double(lmax-l)*(cmax-c)*sizeof(longlong)<128e3 &&
8952 	  LLsmallmodrref(N,l,lmax,c,cmax,pivots,permutation,maxrankcols,idet,fullreduction,dont_swap_below,modulo,carac,rref_or_det_or_lu)){
8953 	break;
8954       }
8955       pivot = N[l].empty()?0:(N[l][c] %= modulo);
8956       if (rref_or_det_or_lu==3 && !pivot){
8957 	idet=0;
8958 	if (!workptr && tmpptr)
8959 	  delete tmpptr;
8960 	return;
8961       }
8962       if ( rref_or_det_or_lu==1 && l==lmax-1 ){
8963 	idet = (idet * pivot) % modulo ;
8964 	break;
8965       }
8966       pivotline=l;
8967       pivotcol=c;
8968       if (!pivot){ // scan current line
8969 	noswap=false;
8970 	if (l<dont_swap_below){
8971 	  for (int ctemp=c+1;ctemp<cmax;++ctemp){
8972 	    temp = N[l].empty()?0:(N[l][ctemp] %= modulo);
8973 	    if (temp){
8974 	      pivot=smod(temp,modulo);
8975 	      pivotcol=ctemp;
8976 	      break;
8977 	    }
8978 	  }
8979 	}
8980 	else {      // scan N current column for the best pivot available
8981 	  for (int ltemp=l+1;ltemp<lmax;++ltemp){
8982 	    temp = N[ltemp].empty()?0:(N[ltemp][c] %= modulo);
8983 	    if (debug_infolevel>2)
8984 	      print_debug_info(temp);
8985 	    if (temp){
8986 	      pivot=smod(temp,modulo);
8987 	      pivotline=ltemp;
8988 	      break;
8989 	    }
8990 	  }
8991 	}
8992       } // end if is_zero(pivot), true pivot found on line or column
8993       if (pivot){
8994 	if (debug_infolevel>1){
8995 	  if (l%10==9){ CERR << "+"; CERR.flush();}
8996 	  if (l%500==499){ CERR << CLOCK()*1e-6 << " remaining " << lmax-l << '\n'; }
8997 	}
8998 	maxrankcols.push_back(c);
8999 	if (l!=pivotline){
9000 	  swap(N[l],N[pivotline]);
9001 	  swap(permutation[l],permutation[pivotline]);
9002 	  pivotline=l;
9003 	  idet = -idet;
9004 	}
9005 	// save pivot for annulation test purposes
9006 	if (rref_or_det_or_lu!=1)
9007 	  pivots.push_back(pivot);
9008 	// invert pivot. If pivot==1 we might optimize but only if allow_bloc is true
9009 	if (0 && pivot==1 && allow_block)
9010 	  temp=1; // can not be activated because pseudo-mod expect reducing line to be smaller than p
9011 	else {
9012 	  temp=invmod(pivot,modulo);
9013 	  // multiply det
9014 	  idet = (idet * pivot) % modulo ;
9015 	  if (fullreduction || rref_or_det_or_lu<2){ // not LU decomp
9016 	    vector<int>::iterator it=N[pivotline].begin()+c,itend=N[pivotline].end();
9017 	    for (;it!=itend;++it){
9018 	      int tmp=*it;
9019 	      if (!tmp) continue;
9020 	      tmp=(longlong(temp) * tmp)%modulo;
9021 	      *it=smod_adjust(tmp,modulo);
9022 	    }
9023 	  }
9024 	}
9025 	// if there are 0 at the end, ignore them in linear combination
9026 	int effcmax=(fullreduction && inverting && noswap)?c+lmax:cmax-1;
9027 	const std::vector<int> & Npiv=N[l];
9028 	for (;effcmax>=c;--effcmax){
9029 	  if (Npiv[effcmax])
9030 	    break;
9031 	}
9032 	++effcmax;
9033 	// make the reduction
9034 	bool do_reduction=true;
9035 	int effl=fullreduction?linit:l+1;
9036 #ifdef HAVE_LIBPTHREAD
9037 	if (nthreads>1 && double(lmax-effl)*(effcmax-c)>1e5){
9038 	  pthread_t tab[64];
9039 	  thread_modular_reduction_t redparam[64];
9040 	  if (nthreads>64) nthreads=64;
9041 	  for (int j=0;j<nthreads;++j){
9042 	    thread_modular_reduction_t tmp={&N,0,l,pivotcol,temp,linit,lmax,c,effcmax,rref_or_det_or_lu,modulo,j==0 && debug_infolevel>2};
9043 	    redparam[j]=tmp;
9044 	  }
9045 	  int kstep=int(std::ceil((lmax-effl)/double(nthreads))),k=effl;
9046 	  for (int j=0;j<nthreads;++j){
9047 	    redparam[j].linit=k;
9048 	    k += kstep;
9049 	    if (k>lmax)
9050 	      k=lmax;
9051 	    redparam[j].lmax=k;
9052 	    bool res=true;
9053 	    if (j<nthreads-1)
9054 	      res=pthread_create(&tab[j],(pthread_attr_t *) NULL,do_thread_modular_reduction,(void *) &redparam[j]);
9055 	    if (res)
9056 	      do_thread_modular_reduction((void *)&redparam[j]);
9057 	  }
9058 	  for (int j=0;j<nthreads;++j){
9059 	    void * ptr=(void *)&nthreads; // non-zero initialisation
9060 	    if (j<nthreads-1)
9061 	      pthread_join(tab[j],&ptr);
9062 	  }
9063 	  do_reduction=false;
9064 	}
9065 #endif
9066 	if (do_reduction)
9067 	  do_modular_reduction(N,l,pivotcol,temp,effl,lmax,c,effcmax,rref_or_det_or_lu,modulo);
9068 	// increment column number if swap was allowed
9069 	if (l>=dont_swap_below)
9070 	  ++c;
9071 	// increment line number since reduction has been done
9072 	++l;
9073       } // end if (!is_zero(pivot)
9074       else { // if pivot is 0 increment either the line or the col
9075 	idet = 0;
9076 	if (rref_or_det_or_lu==1){
9077 	  if (!workptr && tmpptr)
9078 	    delete tmpptr;
9079 	  return;
9080 	}
9081 	if (l>=dont_swap_below)
9082 	  c++;
9083 	else
9084 	  l++;
9085       }
9086     } // end for reduction loop
9087     if (rref_or_det_or_lu!=1){
9088       for (int i=0;i<lmax;i++){
9089 	if (N[i].empty())
9090 	  continue;
9091 	int * Ni=&N[i][0], * Niend= Ni+cmax; // vector<int> & Ni=N[i];
9092 	if (rref_or_det_or_lu==2)
9093 	  Ni += i;
9094 	for (;Ni!=Niend;++Ni){
9095 	  if (*Ni){
9096 #if 1
9097 	    *Ni=smod(*Ni,modulo);
9098 #else
9099 	    longlong r = *Ni % modulo;
9100 	    if ( (r<<1) > modulo){
9101 	      *Ni = r-modulo;
9102 	      continue;
9103 	    }
9104 	    if ( (r<<1) > -modulo)
9105 	      *Ni = r;
9106 	    else
9107 	      *Ni = r-modulo;
9108 #endif
9109 	  }
9110 	}
9111       }
9112     }
9113     if (!workptr && tmpptr)
9114       delete tmpptr;
9115   }
9116 
9117 
9118   struct doublerref_temp_t {
9119     matrix_double Ainvtran,Ainv,CAinv;
9120     std::vector<int> permblock,maxrankblock;
9121     vecteur pivblock;
9122     std::vector<double> y,y1,y2,y3;
9123     std::vector<double> z,z1,z2,z3;
9124   };
9125   // if dont_swap_below !=0, for line numers < dont_swap_below
9126   // the pivot is searched in the line instead of the column
9127   // hence no line swap occur
9128   // rref_or_det_or_lu = 0 for rref, 1 for det, 2 for lu,
9129   // 3 for lu without permutation
9130   // fullreduction=0 or 1, use 2 if the right part of a is idn
in_doublerref(matrix_double & N,vecteur & pivots,vector<int> & permutation,vector<int> & maxrankcols,double & idet,int l,int lmax,int c,int cmax,int fullreduction,int dont_swap_below,double eps,int rref_or_det_or_lu,bool reset,doublerref_temp_t * workptr)9131   void in_doublerref(matrix_double & N,vecteur & pivots,vector<int> & permutation,vector<int> & maxrankcols,double & idet,int l, int lmax, int c,int cmax,int fullreduction,int dont_swap_below,double eps,int rref_or_det_or_lu,bool reset,doublerref_temp_t * workptr){
9132     if (debug_infolevel)
9133       CERR << CLOCK()*1e-6 << " doublerref begin " << l << '\n';
9134     bool use_cstart=!c;
9135     bool inverting=fullreduction==2;
9136     // alternative for inverting large matrices
9137     // [[A,B],[C,D]]^-1=[[E,F],[G,H]]
9138     // H=(D-C*A^-1*B)^-1
9139     // G=-H*C*A^-1
9140     // F=-A^-1*B*H
9141     // E=A^-1-F*C*A^-1=A^-1-A^-1*B*G=A^-1-A^-1*B*(D-C*A^-1*B)^-1*C*A^-1
9142     // indeed A*E+B*G=I, A*F+B*H=0, C*E+D*G, C*F+D*H
9143     // compute A^-1, then 3 products A^-1*B, C*A^-1, D-C*A^-1*B,
9144     // inverse, two products for F and G, and one for E
9145 #ifndef GIAC_HAS_STO_38
9146     if (inverting){
9147       fullreduction=0;
9148       rref_or_det_or_lu=2;
9149       cmax=lmax;
9150     }
9151 #endif
9152     int linit=l;//,previous_l=l;
9153     // Reduction
9154     double pivot,temp;
9155      // vecteur vtemp;
9156     int pivotline,pivotcol;
9157     if (reset){
9158       idet=1;
9159       pivots.clear();
9160       pivots.reserve(cmax-c);
9161       permutation.clear();
9162       maxrankcols.clear();
9163       for (int i=0;i<lmax;++i)
9164 	permutation.push_back(i);
9165     }
9166     bool noswap=true;
9167     double epspivot=(eps<1e-13)?1e-13:eps;
9168     doublerref_temp_t * tmpptr=workptr;
9169 #ifndef GIAC_HAS_STO_38
9170     bool blocktest=lmax-l>=2*mmult_double_blocksize && cmax-c>=2*mmult_double_blocksize;
9171     if (blocktest){
9172       // count 0 in N[l->lmax][c->cmax]
9173       // if matrix is sparse, then block operations is not faster
9174       double count=0;
9175       for (int i=l;i<lmax;++i){
9176 	vector<giac_double>::const_iterator it=N[l].begin()+c,itend=N[l].begin()+cmax;
9177 	for (;it!=itend;++it){
9178 	  if (!*it)
9179 	    ++count;
9180 	}
9181       }
9182       count=(count/(lmax-l)/(cmax-c));
9183       if (count>.8)
9184 	blocktest=false;
9185     }
9186     // block operation with double has lower precision,
9187     // because pivot absolute value is smaller than with the full matrix
9188     if (!workptr){
9189       if (blocktest)
9190 	tmpptr = new doublerref_temp_t;
9191       else
9192 	tmpptr=0;
9193     }
9194     if (//0 &&
9195 	rref_or_det_or_lu==2 && blocktest
9196 	){
9197       // diag(P1,P2)*[[A,B],[C,D]]=[[L1,0],[L3,L2]]*[[U1,U3],[0,U2]]
9198       // hence P1*A=L1*U1, recursive call will determine L1, U1 and P1
9199       // if A is not invertible, failure (keep a copy of A in case)
9200       // line swaps corresponding to P1 will replace inplace B by P1*B
9201       // then P1*B=L1*U3, determine columns of U3 by int_linsolve_l, replace B with U3
9202       // keep columns of U3 in lines for later use in matrix product
9203       // P2*C=L3*U1, hence P2^-1*L3 is determined by int_linsolve_u, replace C with P2^-1*L3
9204       // P2*D=L3*U3+L2*U2 -> P2*(D-P2^-1*L3*U3)=L2*U2
9205       // substract P2^-1*L3*U3 from D and recursive call to lu will determine P2, L2 and U2
9206       // (line swaps will replace inplace P2^-1*L3 by L3)
9207       int taille=mmult_double_blocksize;
9208       if (debug_infolevel>2)
9209 	CERR << CLOCK()*1e-6 << " recursive call double size " << taille << '\n';
9210       tmpptr->y.resize(taille);
9211       tmpptr->y1.resize(taille);
9212       tmpptr->y2.resize(taille);
9213       tmpptr->y3.resize(taille);
9214       tmpptr->z.resize(taille);
9215       tmpptr->z1.resize(taille);
9216       tmpptr->z2.resize(taille);
9217       tmpptr->z3.resize(taille);
9218       tmpptr->Ainv.resize(cmax-c-taille);
9219       for (int i=0;i<taille;i++){
9220 	double * source=&N[l+i][c];
9221 	tmpptr->Ainv[i].resize(taille);
9222 	vector<double>::iterator it=tmpptr->Ainv[i].begin(),itend=tmpptr->Ainv[i].end();
9223 	for (;it!=itend;++source,++it)
9224 	  *it=*source;
9225       }
9226       in_doublerref(N,pivots,permutation,maxrankcols,idet,l,lmax,c,c+taille,false,false,eps,2,false,0);
9227       // find U3: L1*U3=P1*B, cmax-c-taille systems to solve, each has taille unknowns
9228       int i=0;
9229       for (;i<=cmax-c-taille-4;i+=4){
9230 	for (int j=0;j<taille;j++){
9231 	  tmpptr->y[j]=N[l+j][i+c+taille];
9232 	  tmpptr->y1[j]=N[l+j][i+1+c+taille];
9233 	  tmpptr->y2[j]=N[l+j][i+2+c+taille];
9234 	  tmpptr->y3[j]=N[l+j][i+3+c+taille];
9235 	}
9236 	double_linsolve_l4(N,l,c,tmpptr->y,tmpptr->y1,tmpptr->y2,tmpptr->y3,tmpptr->Ainv[i],tmpptr->Ainv[i+1],tmpptr->Ainv[i+2],tmpptr->Ainv[i+3]);
9237 	// copy into N
9238 	for (int j=0;j<taille;j++){
9239 	  N[l+j][i+c+taille]=tmpptr->Ainv[i][j];
9240 	  N[l+j][i+1+c+taille]=tmpptr->Ainv[i+1][j];
9241 	  N[l+j][i+2+c+taille]=tmpptr->Ainv[i+2][j];
9242 	  N[l+j][i+3+c+taille]=tmpptr->Ainv[i+3][j];
9243 	}
9244       }
9245       for (;i<cmax-c-taille;++i){
9246 	for (int j=0;j<taille;j++){
9247 	  tmpptr->y[j]=N[l+j][i+c+taille];
9248 	}
9249 	double_linsolve_l(N,l,c,tmpptr->y,tmpptr->Ainv[i]);
9250 	// copy into N
9251 	for (int j=0;j<taille;j++)
9252 	  N[l+j][i+c+taille]=tmpptr->Ainv[i][j];
9253       }
9254       // substract L3*U3 from D
9255       in_mmult_double(N,tmpptr->Ainv,N,l+taille,c+taille,l+taille,lmax,c,c+taille,false);
9256       // final lu decomposition
9257       in_doublerref(N,pivots,permutation,maxrankcols,idet,l+taille,lmax,c+taille,cmax,false,false,eps,2,false,0);
9258       if (debug_infolevel>2)
9259 	CERR << CLOCK()*1e-6 << " end recursive call double size " << taille << '\n';
9260       // matrice dbg;
9261       // vectvector_int2vecteur(N,dbg);
9262       // CERR << smod(dbg,modulo) << '\n';
9263       if (!workptr && tmpptr)
9264 	delete tmpptr;
9265 #ifndef GIAC_HAS_STO_38
9266       if (inverting)
9267 	double_lu2inv(N,permutation);
9268 #endif
9269       return;
9270     }
9271 #endif // GIAC_HAS_STO_38
9272     for (;(l<lmax) && (c<cmax);){
9273       pivot=N[l][c];
9274       if (absdouble(pivot)<epspivot)
9275 	pivot=N[l][c]=0;
9276       if (rref_or_det_or_lu==3 && !pivot){
9277 	idet=0;
9278 	return;
9279       }
9280       if ( rref_or_det_or_lu==1 && l==lmax-1 ){
9281 	idet = (idet * pivot);
9282 	break;
9283       }
9284       pivotline=l;
9285       pivotcol=c;
9286       noswap=false;
9287       if (l<dont_swap_below){
9288 	for (int ctemp=c+1;ctemp<cmax;++ctemp){
9289 	  temp=N[l][ctemp];
9290 	  if (absdouble(temp)<epspivot)
9291 	    temp=N[l][ctemp]=0;
9292 	  if (absdouble(temp)>absdouble(pivot)){
9293 	    pivot=temp;
9294 	    pivotcol=ctemp;
9295 	  }
9296 	}
9297       }
9298       else {      // scan N current column for the best pivot available
9299 	for (int ltemp=l+1;ltemp<lmax;++ltemp){
9300 	  temp=N[ltemp][c];
9301 	  if (absdouble(temp)<epspivot)
9302 	    temp=N[ltemp][c]=0;
9303 	  if (debug_infolevel>3)
9304 	    print_debug_info(temp);
9305 	  if (absdouble(temp)>absdouble(pivot)){
9306 	    pivot=temp;
9307 	    pivotline=ltemp;
9308 	  }
9309 	}
9310       }
9311       if (pivot){
9312 	epspivot=absdouble(eps*pivot);
9313 	maxrankcols.push_back(c);
9314 	if (l!=pivotline){
9315 	  swap(N[l],N[pivotline]);
9316 	  swap(permutation[l],permutation[pivotline]);
9317 	  pivotline=l;
9318 	  idet = -idet;
9319 	}
9320 	// save pivot for annulation test purposes
9321 	if (rref_or_det_or_lu!=1)
9322 	  pivots.push_back(pivot);
9323 	// invert pivot
9324 	temp=1./pivot;
9325 	// multiply det
9326 	idet = idet * pivot ;
9327 	if (fullreduction || rref_or_det_or_lu<2){ // not LU decomp
9328 	  std::vector<giac_double>::iterator it=N[pivotline].begin(),itend=N[pivotline].end();
9329 	  for (;it!=itend;++it){
9330 	    *it /= pivot;
9331 	  }
9332 	}
9333 	// if there are 0 at the end, ignore them in linear combination
9334 	int effcmax=cmax-1;
9335 	const std::vector<giac_double> & Npiv=N[pivotline];
9336 	for (;effcmax>=c;--effcmax){
9337 	  if (Npiv[effcmax])
9338 	    break;
9339 	}
9340 	++effcmax;
9341 	if (fullreduction && inverting && noswap)
9342 	  effcmax=giacmax(effcmax,c+1+lmax);
9343 	// make the reduction
9344 	if (fullreduction){
9345 	  for (int ltemp=linit;ltemp<lmax;++ltemp){
9346 	    if (ltemp==l)
9347 	      continue;
9348 #ifndef GIAC_HAS_STO_38
9349 	    if ( ((ltemp<=l-4) || (ltemp>l && ltemp<=lmax-4))){
9350 	      double_multilinear_combination(N[ltemp],-N[ltemp][pivotcol],N[ltemp+1],-N[ltemp+1][pivotcol],N[ltemp+2],-N[ltemp+2][pivotcol],N[ltemp+3],-N[ltemp+3][pivotcol],N[l],(use_cstart?c:cmax),effcmax);
9351 	      ltemp+= (4-1);
9352 	    }
9353 	    else
9354 #endif
9355 	      double_linear_combination(N[ltemp],-N[ltemp][pivotcol],N[l],(use_cstart?c:cmax),effcmax);
9356 	  }
9357 	}
9358 	else {
9359 	  for (int ltemp=l+1;ltemp<lmax;++ltemp){
9360 	    if (rref_or_det_or_lu>=2) // LU decomp
9361 	      N[ltemp][pivotcol] *= temp;
9362 #ifndef GIAC_HAS_STO_38
9363 	    if (ltemp<lmax-4){
9364 	      if (rref_or_det_or_lu>=2){ // LU decomp
9365 		N[ltemp+1][pivotcol] *=temp;
9366 		N[ltemp+2][pivotcol] *=temp;
9367 		N[ltemp+3][pivotcol] *=temp;
9368 	      }
9369 	      double_multilinear_combination(N[ltemp],-N[ltemp][pivotcol],N[ltemp+1],-N[ltemp+1][pivotcol],N[ltemp+2],-N[ltemp+2][pivotcol],N[ltemp+3],-N[ltemp+3][pivotcol],N[l],(rref_or_det_or_lu>0)?(c+1):(use_cstart?c:cmax),effcmax);
9370 	      ltemp+= (4-1);
9371 	    }
9372 	    else
9373 #endif
9374 	      double_linear_combination(N[ltemp],-N[ltemp][pivotcol],N[l],(rref_or_det_or_lu>0)?(c+1):(use_cstart?c:cmax),effcmax);
9375 	  }
9376 	} // end else
9377 	  // increment column number if swap was allowed
9378 	if (l>=dont_swap_below)
9379 	  ++c;
9380 	// increment line number since reduction has been done
9381 	++l;
9382       } // end if (!is_zero(pivot)
9383       else { // if pivot is 0 increment either the line or the col
9384 	idet = 0;
9385 	if (rref_or_det_or_lu==1)
9386 	  return;
9387 	if (l>=dont_swap_below)
9388 	  c++;
9389 	else
9390 	  l++;
9391       }
9392     } // end for reduction loop
9393 #ifndef GIAC_HAS_STO_38
9394     if (inverting){
9395       double_lu2inv(N,permutation);
9396       // double_lu2inv_inplace(N,permutation);
9397     }
9398 #endif
9399   }
9400 
doublerref(matrix_double & N,vecteur & pivots,vector<int> & permutation,vector<int> & maxrankcols,double & idet,int l,int lmax,int c,int cmax,int fullreduction,int dont_swap_below,int rref_or_det_or_lu,double eps)9401   void doublerref(matrix_double & N,vecteur & pivots,vector<int> & permutation,vector<int> & maxrankcols,double & idet,int l, int lmax, int c,int cmax,int fullreduction,int dont_swap_below,int rref_or_det_or_lu,double eps){
9402     in_doublerref(N,pivots,permutation,maxrankcols,idet,l,lmax,c,cmax,fullreduction,dont_swap_below,eps,rref_or_det_or_lu,true,0);
9403   }
9404 
in_modrref(const matrice & a,vector<vector<int>> & N,matrice & res,vecteur & pivots,gen & det,int l,int lmax,int c,int cmax,int fullreduction,int dont_swap_below,int Modulo,int carac,int rref_or_det_or_lu,const gen & mult_by_det_mod_p,bool inverting,bool no_initial_mod,smallmodrref_temp_t * workptr)9405   bool in_modrref(const matrice & a, vector< vector<int> > & N,matrice & res, vecteur & pivots, gen & det,int l, int lmax, int c,int cmax,int fullreduction,int dont_swap_below,int Modulo,int carac,int rref_or_det_or_lu,const gen & mult_by_det_mod_p,bool inverting,bool no_initial_mod,smallmodrref_temp_t * workptr){
9406 #ifndef GIAC_HAS_STO_38
9407     if (no_initial_mod){
9408       const_iterateur it=a.begin(),itend=a.end();
9409       N.resize(itend-it);
9410       vector< vector<int> >::iterator kt=N.begin();
9411       for (;it!=itend;++kt,++it){
9412 #if 1
9413 	vecteur2vector_int(*it->_VECTptr,Modulo,*kt);
9414 #else
9415 	const_iterateur jt=it->_VECTptr->begin(),jtend=it->_VECTptr->end();
9416 	kt->resize(jtend-jt);
9417 	vector<int>::iterator lt=kt->begin();
9418 	for (;jt!=jtend;++lt,++jt){
9419 	  if (jt->type==_INT_)
9420 	    *lt=jt->val;
9421 	  else
9422 	    *lt=smod(*jt,Modulo).val;
9423 	}
9424 #endif
9425       }
9426     }
9427     else
9428 #endif
9429       {
9430 	if (!vecteur2vectvector_int(a,Modulo,N))
9431 	  return false;
9432       }
9433     longlong idet=1;
9434     vector<int> permutation,maxrankcol;
9435     if (debug_infolevel>2)
9436       CERR << CLOCK()*1e-6 << " begin smallmodrref " << '\n';
9437     smallmodrref(1,N,pivots,permutation,maxrankcol,idet,l,lmax,c,cmax,fullreduction,dont_swap_below,Modulo,rref_or_det_or_lu,true,workptr,true,carac);
9438 #ifndef GIAC_HAS_STO_38
9439     if (inverting){
9440       int_lu2inv(N,Modulo,permutation);
9441       // matrice dbg;
9442       // vectvector_int2vecteur(N,dbg);
9443       // CERR << a << "*" << smod(dbg,Modulo) << " % " << Modulo << '\n';
9444     }
9445 #endif
9446     if (debug_infolevel>2)
9447       CERR << CLOCK()*1e-6 << " rref done smallmodrref " << '\n';
9448     det = smod(longlong(idet),Modulo);
9449     if (!is_one(mult_by_det_mod_p)){
9450       idet=smod(mult_by_det_mod_p,Modulo).val;
9451       for (unsigned i=0;i<N.size();++i){
9452 	vector<int>::iterator it=N[i].begin(),itend=N[i].end();
9453 	for (;it!=itend;++it){
9454 	  *it = idet*(*it)%Modulo;
9455 	}
9456       }
9457     }
9458     if (rref_or_det_or_lu!=1)
9459       vectvector_int2vecteur(N,res);
9460     if (debug_infolevel>2)
9461       CERR << CLOCK()*1e-6 << " end smallmodrref " << '\n';
9462     if (rref_or_det_or_lu==2 && !inverting){
9463       vecteur P;
9464       vector_int2vecteur(permutation,P);
9465       pivots.push_back(P);
9466     }
9467     return true;
9468   }
9469 
9470   // if dont_swap_below !=0, for line numers < dont_swap_below
9471   // the pivot is searched in the line instead of the column
9472   // hence no line swap occur
9473   // rref_or_det_or_lu = 0 for rref, 1 for det, 2 for lu,
9474   // 3 for lu without permutation
9475   // fullreduction=0 or 1, use 2 if the right part of a is idn
modrref(const matrice & a,matrice & res,vecteur & pivots,gen & det,int l,int lmax,int c,int cmax,int fullreduction,int dont_swap_below,const gen & modulo,bool ckprime,int rref_or_det_or_lu)9476   bool modrref(const matrice & a, matrice & res, vecteur & pivots, gen & det,int l, int lmax, int c,int cmax,int fullreduction,int dont_swap_below,const gen & modulo,bool ckprime,int rref_or_det_or_lu){
9477     if (ckprime && !is_probab_prime_p(modulo)){
9478       if (rref_or_det_or_lu==1){
9479 	vecteur v=ifactors(modulo,context0);
9480 	if (v.size()<2)
9481 	  return false;
9482 	gen currentp=pow(v[0],v[1],context0);
9483 	vector< vector<int> > N;
9484 	if (currentp.type==_INT_){
9485 	  res.clear(); N.clear();
9486 	  if (!in_modrref(a,N,res,pivots,det,l,lmax,c,cmax,fullreduction,dont_swap_below,currentp.val,v[0].val /* carac */,rref_or_det_or_lu,1,false /* inverting */,false/* no initial mod */,0/*workptr*/))
9487 	    return false;
9488 	}
9489 	else {
9490 	  if ( v[1]!=1 || !modrref(a,res,pivots,det,l,lmax,c,cmax,fullreduction,dont_swap_below,v[0],false,rref_or_det_or_lu))
9491 	    return false;
9492 	}
9493 	gen pip=currentp;
9494 	for (int i=2;i<v.size();i+=2){
9495 	  currentp=pow(v[i],v[i+1],context0);
9496 	  gen curdet;
9497 	  if (currentp.type==_INT_){
9498 	    res.clear(); N.clear();
9499 	    if (!in_modrref(a,N,res,pivots,curdet,l,lmax,c,cmax,fullreduction,dont_swap_below,currentp.val,v[i].val /* carac */,rref_or_det_or_lu,1,false /* inverting */,false/* no initial mod */,0/*workptr*/))
9500 	      return false;
9501 	  }
9502 	  else {
9503 	    if (v[i+1]!=1)
9504 	      return false;
9505 	    if (!modrref(a,res,pivots,curdet,l,lmax,c,cmax,fullreduction,dont_swap_below,v[i],false,rref_or_det_or_lu))
9506 	      return false;
9507 	  }
9508 	  det=ichinrem(det,curdet,pip,v[i]);
9509 	  pip=pip*v[i];
9510 	}
9511 	return true;
9512       }
9513       CERR << "Non prime modulo. Reduction mail fail" << '\n';
9514     }
9515     if (modulo.type==_INT_ &&
9516 #if 0 // ndef _I386_
9517 	modulo.val<46340 &&
9518 #endif
9519 	is_fraction_matrice(a) ){ // Small mod reduction
9520       res.clear();
9521       vector< vector<int> > N;
9522       return in_modrref(a,N,res,pivots,det,l,lmax,c,cmax,fullreduction,dont_swap_below,modulo.val,-1/*carac*/,rref_or_det_or_lu,1,false /* inverting */,false/* no initial mod */,0/*workptr*/);
9523     }
9524     // bool use_cstart=!c;
9525     // bool inverting=fullreduction==2;
9526     det = 1;
9527     int linit=l;//,previous_l=l;
9528     vecteur lv;
9529     // Large mod reduction (coeff do not fit in an int)
9530     res=a;
9531     // COUT << res << '\n';
9532     std_matrix<gen> M;
9533     matrice2std_matrix_gen(res,M);
9534     gen pivot,temp;
9535     // vecteur vtemp;
9536     int pivotline,pivotcol;
9537     pivots.clear();
9538     pivots.reserve(cmax-c);
9539     for (;(l<lmax) && (c<cmax);){
9540       if ( (!fullreduction) && (l==lmax-1) ){
9541 	det = smod(det*M[l][c],modulo);
9542 	break;
9543       }
9544       pivot=M[l][c];
9545       pivotline=l;
9546       pivotcol=c;
9547       if (is_exactly_zero(pivot)){ // scan current line
9548 	if (rref_or_det_or_lu==3){
9549 	  det=0;
9550 	  return true;
9551 	}
9552 	if (l<dont_swap_below){
9553 	  for (int ctemp=c+1;ctemp<cmax;++ctemp){
9554 	    temp=M[l][ctemp];
9555 	    if (!is_exactly_zero(temp)){
9556 	      pivot=temp;
9557 	      pivotcol=ctemp;
9558 	      break;
9559 	    }
9560 	  }
9561 	}
9562 	else {      // scan M current column for the best pivot available
9563 	  for (int ltemp=l+1;ltemp<lmax;++ltemp){
9564 	    temp=M[ltemp][c];
9565 	    if (debug_infolevel>2)
9566 	      print_debug_info(temp);
9567 	    if (!is_exactly_zero(temp)){
9568 	      pivot=temp;
9569 	      pivotline=ltemp;
9570 	      break;
9571 	    }
9572 	  }
9573 	}
9574       } // end if is_zero(pivot), true pivot found on line or column
9575       if (!is_exactly_zero(pivot)){
9576 	if (l!=pivotline){
9577 	  swap(M[l],M[pivotline]);
9578 	  det = -det;
9579 	}
9580 	det = smod(det*pivot,modulo);
9581 	// save pivot for annulation test purposes
9582 	if (rref_or_det_or_lu!=1)
9583 	  pivots.push_back(pivot);
9584 	// invert pivot
9585 	temp=invmod(pivot,modulo);
9586 	if (fullreduction || rref_or_det_or_lu<2){
9587 	  iterateur it=M[l].begin(),itend=M[l].end();
9588 	  for (;it!=itend;++it)
9589 	    *it=smod(temp * *it,modulo);
9590 	}
9591 	// make the reduction
9592 	if (fullreduction){
9593 	  for (int ltemp=linit;ltemp<lmax;++ltemp){
9594 	    if (ltemp!=l)
9595 	      modlinear_combination(M[ltemp],-M[ltemp][pivotcol],M[l],modulo,0);
9596 	  }
9597 	}
9598 	else {
9599 	  for (int ltemp=l+1;ltemp<lmax;++ltemp){
9600 	    if (rref_or_det_or_lu>=2)
9601 	      M[ltemp][pivotcol]=smod(M[ltemp][pivotcol]*temp,modulo);
9602 	    modlinear_combination(M[ltemp],-M[ltemp][pivotcol],M[l],modulo,(c+1)*(rref_or_det_or_lu>0));
9603 	  }
9604 	} // end else
9605 	// increment column number if swap was allowed
9606 	if (l>=dont_swap_below)
9607 	  ++c;
9608 	// increment line number since reduction has been done
9609 	++l;
9610       } // end if (!is_zero(pivot)
9611       else { // if pivot is 0 increment either the line or the col
9612 	det = 0;
9613 	if (rref_or_det_or_lu==1)
9614 	  return true;
9615 	if (l>=dont_swap_below)
9616 	  c++;
9617 	else
9618 	  l++;
9619       }
9620     } // end for reduction loop
9621     std_matrix_gen2matrice_destroy(M,res);
9622     return true;
9623   }
9624 
mrref(const matrice & a,matrice & res,vecteur & pivots,gen & det,GIAC_CONTEXT)9625   bool mrref(const matrice & a, matrice & res, vecteur & pivots, gen & det,GIAC_CONTEXT){
9626     return mrref(a,res,pivots,det,0,int(a.size()),0,int(a.front()._VECTptr->size()),
9627 		 /* fullreduction */ 1,0,true,1,0,
9628 	  contextptr)!=0;
9629   }
9630 
modrref(const matrice & a,matrice & res,vecteur & pivots,gen & det,const gen & modulo)9631   bool modrref(const matrice & a, matrice & res, vecteur & pivots, gen & det,const gen& modulo){
9632     return modrref(a,res,pivots,det,0,int(a.size()),0,int(a.front()._VECTptr->size()),
9633 		   true /* full reduction */,0 /* dont_swap_below*/,modulo,true /*ckprime*/,0 /* rref */);
9634   }
9635 
9636   // add identity matrix, modifies arref in place
add_identity(matrice & arref)9637   void add_identity(matrice & arref){
9638     int s=int(arref.size());
9639     vecteur v;
9640     gen un(1),zero(0);
9641     if (!arref.empty() && has_num_coeff(arref)){
9642       gen tmp=arref.front()._VECTptr->front();
9643       if (is_zero(tmp))
9644 	tmp= tmp+1;
9645       un=tmp/tmp;
9646       zero=tmp-tmp;
9647     }
9648     for (int i=0;i<s;++i){
9649       gen tmp=new ref_vecteur(2*s,zero);
9650       iterateur it=tmp._VECTptr->begin(),jt=arref[i]._VECTptr->begin(),jtend=jt+s;
9651       for (;jt!=jtend;++it,++jt)
9652 	*it=*jt;
9653       it+=i;
9654       *it=un;
9655       arref[i] = tmp;
9656     }
9657   }
9658 
9659   // add identity matrix, modifies arref in place
add_identity(vector<vector<int>> & arref)9660   void add_identity(vector< vector<int> > & arref){
9661     int s=int(arref.size());
9662     for (int i=0;i<s;++i){
9663       vector<int> & v= arref[i];
9664       v.reserve(2*s);
9665       for (int j=0;j<s;++j)
9666 	v.push_back(i==j);
9667     }
9668   }
9669 
remove_identity(matrice & res)9670   bool remove_identity(matrice & res){
9671     return remove_identity(res,context0);
9672   }
9673 
remove_identity(vector<vector<int>> & res,int modulo)9674   bool remove_identity(vector< vector<int> > & res,int modulo){
9675     int s=int(res.size());
9676     // "shrink" res
9677     for (int i=0;i<s;++i){
9678       vector<int> & v = res[i];
9679       if (!v[i])
9680 	return false;
9681       longlong inv=invmod(v[i],modulo);
9682       v = vector<int>(v.begin()+s,v.end());
9683       for (int j=0;j<s;++j){
9684 	longlong tmp=v[j]*inv;
9685 	v[j] = tmp % modulo;
9686       }
9687     }
9688     return true;
9689   }
9690 
modinv(const matrice & a,matrice & res,const gen & modulo,gen & det_mod_p)9691   bool modinv(const matrice & a,matrice & res,const gen & modulo,gen & det_mod_p){
9692     if (modulo.type==_INT_ && a.size()*double(modulo.val)*modulo.val< 4e18){
9693       vector< vector<int> > ai,resi;
9694       longlong det_mod_pi;
9695       vecteur2vectvector_int(a,modulo.val,ai);
9696       if (!smallmodinv(ai,resi,modulo.val,det_mod_pi))
9697 	return false;
9698       det_mod_p=det_mod_pi;
9699       vectvector_int2vecteur(resi,res);
9700       return true;
9701     }
9702     matrice arref = a;
9703     add_identity(arref);
9704     int s=int(a.size());
9705     vecteur pivots;
9706     if (!modrref(arref,res,pivots,det_mod_p,0,s,0,2*s,
9707 		 2/* full reduction*/,0/*dont_swap_below*/,modulo,true/*ckprime*/,0/* rref */))
9708       return false;
9709     return remove_identity(res);
9710   }
9711 
smallmodinv(const vector<vector<int>> & a,vector<vector<int>> & res,int modulo,longlong & det_mod_p)9712   bool smallmodinv(const vector< vector<int> > & a,vector< vector<int> > & res,int modulo,longlong & det_mod_p){
9713     res = a;
9714     add_identity(res);
9715     int s=int(a.size());
9716     vecteur pivots;
9717     vector<int> permutation,rankcols;
9718 #ifndef GIAC_HAS_STO_38
9719     smallmodrref(1,res,pivots,permutation,rankcols,det_mod_p,0,s,0,s,
9720 		 0,false,modulo,2,true,0,true,-1);
9721     if (det_mod_p==0)
9722       return false;
9723     int_lu2inv(res,modulo,permutation);
9724     return true;
9725 #else
9726     smallmodrref(1,res,pivots,permutation,rankcols,det_mod_p,0,s,0,2*s,
9727 		 2/* full reduction*/,0/*dont_swap_below*/,modulo,0/* rref */,true,0,false,-1);
9728     return remove_identity(res,modulo);
9729 #endif
9730   }
9731 
9732   // works if |v|^2,|w|^2<2^31
dotvecteur_int(const vecteur & a,const vecteur & b,bool smallint,int p)9733   static gen dotvecteur_int(const vecteur & a,const vecteur & b,bool smallint,int p){
9734     vecteur::const_iterator ita=a.begin(), itaend=a.end();
9735     vecteur::const_iterator itb=b.begin(), itbend=b.end();
9736     if (smallint) {
9737       longlong res=0;
9738       for (;(ita!=itaend)&&(itb!=itbend);++ita,++itb){
9739 	res += longlong (ita->val)*(itb->val);
9740       }
9741       return p?(res %p):res;
9742     }
9743     ref_mpz_t * e = new ref_mpz_t;
9744     mpz_set_ui(e->z,0);
9745     gen tmp;
9746     for (;(ita!=itaend)&&(itb!=itbend);++ita,++itb){
9747 #ifdef USE_GMP_REPLACEMENTS
9748       type_operator_times(*ita,*itb,tmp);
9749       if (tmp.type==_INT_){
9750 	if (tmp.val<0)
9751 	  mpz_sub_ui(e->z,e->z,-tmp.val);
9752 	else
9753 	  mpz_add_ui(e->z,e->z,tmp.val);
9754       }
9755       else
9756 	mpz_add(e->z,e->z,*tmp._ZINTptr);
9757 #else
9758       if (ita->type==_ZINT){
9759 	if (itb->type==_ZINT)
9760 	  mpz_addmul(e->z,*ita->_ZINTptr,*itb->_ZINTptr);
9761 	else {
9762 	  if (itb->val>0)
9763 	    mpz_addmul_ui(e->z,*ita->_ZINTptr,itb->val);
9764 	  else
9765 	    mpz_submul_ui(e->z,*ita->_ZINTptr,-itb->val);
9766 	}
9767       }
9768       else {
9769 	if (itb->type==_ZINT){
9770 	  if (ita->val>0)
9771 	    mpz_addmul_ui(e->z,*itb->_ZINTptr,ita->val);
9772 	  else
9773 	    mpz_submul_ui(e->z,*itb->_ZINTptr,-ita->val);
9774 	}
9775 	else {
9776 #if defined INT128 && !defined USE_GMP_REPLACEMENTS
9777 	  longlong tmp=longlong(ita->val)*(itb->val);
9778 	  if (tmp>0)
9779 	    mpz_add_ui(e->z,e->z,tmp);
9780 	  else
9781 	    mpz_sub_ui(e->z,e->z,-tmp);
9782 #else
9783 	  type_operator_times(*ita,*itb,tmp);
9784 	  if (tmp.type==_INT_){
9785 	    if (tmp.val<0)
9786 	      mpz_sub_ui(e->z,e->z,-tmp.val);
9787 	    else
9788 	      mpz_add_ui(e->z,e->z,tmp.val);
9789 	  }
9790 	  else
9791 	    mpz_add(e->z,e->z,*tmp._ZINTptr);
9792 #endif
9793 	}
9794       }
9795 #endif
9796     }
9797     if (p){
9798       tmp=modulo(e->z,p);
9799       delete e;
9800       return tmp;
9801     }
9802     else
9803       return e;
9804   }
9805 
9806 #ifndef GIAC_HAS_STO_38
dotvecteur_int(const vector<int> & a,const vector<int> & b)9807   longlong dotvecteur_int(const vector<int> & a,const vector<int> & b){
9808     vector<int>::const_iterator ita=a.begin(), itaend=a.end(),itb=b.begin();
9809     longlong res=0;
9810     for (;ita!=itaend;++itb,++ita)
9811       res += longlong(*ita)*(*itb);
9812     return res;
9813   }
9814 
dotvecteur_int_(vector<vector<int>>::const_iterator at,const vector<int> & b,vector<longlong> & res)9815   void dotvecteur_int_(vector< vector<int> >::const_iterator at,const vector<int> & b,vector<longlong> & res){
9816     vector<int>::const_iterator ita0=at->begin(), ita0end=at->end();
9817     vector<int>::const_iterator ita1=(at+1)->begin();
9818     vector<int>::const_iterator ita2=(at+2)->begin();
9819     vector<int>::const_iterator ita3=(at+3)->begin();
9820     vector<int>::const_iterator itb=b.begin();
9821     longlong res0=0,res1=0,res2=0,res3=0;
9822     for (;ita0!=ita0end;++itb,++ita3,++ita2,++ita1,++ita0){
9823       int tmp=*itb;
9824       res0 += ((longlong) *ita0)*tmp;
9825       res1 += ((longlong) *ita1)*tmp;
9826       res2 += ((longlong) *ita2)*tmp;
9827       res3 += ((longlong) *ita3)*tmp;
9828     }
9829     // if (res0!=dotvecteur_int(*at,b) || res1!=dotvecteur_int(*(at+1),b) || res2!=dotvecteur_int(*(at+2),b) || res3!=dotvecteur_int(*(at+3),b)) CERR << "erreur" << '\n';
9830     res.push_back(res0);
9831     res.push_back(res1);
9832     res.push_back(res2);
9833     res.push_back(res3);
9834   }
9835 
9836   // a += b;
addvecteur_longlong(vector<longlong> & a,const vector<longlong> & b)9837   vector<longlong> & addvecteur_longlong(vector<longlong> & a,const vector<longlong> & b){
9838     vector<longlong>::iterator ita=a.begin();
9839     vector<longlong>::const_iterator itaend=a.end(),itb=b.begin();
9840     for (;ita!=itaend;++itb,++ita)
9841       *ita += *itb;
9842     return a;
9843   }
9844 
9845   // a -= b;
subvecteur_longlong(vector<longlong> & a,const vector<longlong> & b)9846   vector<longlong> & subvecteur_longlong(vector<longlong> & a,const vector<longlong> & b){
9847     vector<longlong>::iterator ita=a.begin();
9848     vector<longlong>::const_iterator itaend=a.end(),itb=b.begin();
9849     for (;ita!=itaend;++itb,++ita)
9850       *ita -= *itb;
9851     return a;
9852   }
9853 
multmatvecteur_int(const vector<vector<int>> & a,const vector<int> & b,vector<longlong> & res)9854   void multmatvecteur_int(const vector< vector<int> > & a,const vector<int> & b,vector<longlong> & res){
9855     vector< vector<int> >::const_iterator ita=a.begin(), itaend=a.end();
9856     res.clear();
9857     res.reserve(itaend-ita);
9858     for (;ita<=itaend-4;ita+=4)
9859       dotvecteur_int_(ita,b,res);
9860     for (;ita!=itaend;++ita)
9861       res.push_back(dotvecteur_int(*ita,b));
9862   }
9863 
adjust(gen * & yptr,longlong res,int p)9864   static void adjust(gen * & yptr,longlong res,int p){
9865     if (yptr->type==_INT_){
9866       longlong resp=(yptr->val-res)/p;
9867       if (resp==int(resp))
9868 	yptr->val=int(resp);
9869       else
9870 	*yptr=resp;
9871     }
9872     else {
9873 #if defined(INT128) && !defined(USE_GMP_REPLACEMENTS)
9874       if (res>0)
9875 	mpz_sub_ui(*yptr->_ZINTptr,*yptr->_ZINTptr,res);
9876       else
9877 	mpz_add_ui(*yptr->_ZINTptr,*yptr->_ZINTptr,-res);
9878 #else
9879       *yptr -= res;
9880 #endif
9881 #ifdef USE_GMP_REPLACEMENTS
9882       *yptr = *yptr/p;
9883 #else
9884       if (yptr->type==_ZINT)
9885 	mpz_divexact_ui(*yptr->_ZINTptr,*yptr->_ZINTptr,p);
9886       else
9887 	yptr->val /= p;
9888 #endif
9889     }
9890     ++yptr;
9891   }
9892   // if *yptr is !=0, instead of assigning *it we do *it=(*it-result)/p
dotvecteur_int_(vector<vector<int>>::const_iterator at,const vecteur & b,iterateur it,int p,gen * & yptr)9893   static void dotvecteur_int_(vector< vector<int> >::const_iterator at,const vecteur & b,iterateur it,int p,gen * & yptr){
9894     vector<int>::const_iterator ita0=at->begin(), ita0end=at->end();
9895     vector<int>::const_iterator ita1=(at+1)->begin();
9896     vector<int>::const_iterator ita2=(at+2)->begin();
9897     vector<int>::const_iterator ita3=(at+3)->begin();
9898     vecteur::const_iterator itb=b.begin();
9899     longlong res0=0,res1=0,res2=0,res3=0;
9900     for (;ita0!=ita0end;++itb,++ita3,++ita2,++ita1,++ita0){
9901       int tmp=itb->val;
9902       res0 += ((longlong) *ita0)*tmp;
9903       res1 += ((longlong) *ita1)*tmp;
9904       res2 += ((longlong) *ita2)*tmp;
9905       res3 += ((longlong) *ita3)*tmp;
9906     }
9907     if (yptr){
9908       adjust(yptr,res0,p);
9909       adjust(yptr,res1,p);
9910       adjust(yptr,res2,p);
9911       adjust(yptr,res3,p);
9912     }
9913     else {
9914       *it=p?res0 % p:res0;
9915       *(it+1)=p?res1 % p:res1;
9916       *(it+2)=p?res2 % p:res2;
9917       *(it+3)=p?res3 % p:res3;
9918     }
9919   }
9920 
dotvecteur_int_(const vector<int> & a,const vecteur & b,int p,gen * & yptr)9921   static gen dotvecteur_int_(const vector<int> & a,const vecteur & b,int p,gen * & yptr){
9922     vector<int>::const_iterator ita=a.begin(), itaend=a.end();
9923     vecteur::const_iterator itb=b.begin();
9924     longlong res=0;
9925     for (;ita!=itaend;++ita,++itb){
9926       res += ((longlong) *ita)*(itb->val);
9927     }
9928     if (yptr){
9929       adjust(yptr,res,p);
9930       return p;
9931     }
9932     else
9933       return p?res % p:res;
9934   }
9935 #endif
9936 
multmatvecteur_int(const matrice & a,const vector<vector<int>> & A,const vecteur & b,bool smallint,vecteur & res,int p,gen * yptr)9937   static void multmatvecteur_int(const matrice & a,const vector< vector<int> > & A,const vecteur & b,bool smallint,vecteur & res,int p,gen *yptr){
9938 #ifndef GIAC_HAS_STO_38
9939     if (smallint){
9940 #if 0
9941       int nbits=sizeinbase2(p);
9942       unsigned pseudoinv=((1ULL<<(2*nbits)))/p+1;
9943 #endif
9944       vector< vector<int> >::const_iterator ita=A.begin(), itaend=A.end(),ita4=itaend-4;
9945       res.resize(itaend-ita);
9946       iterateur itres=res.begin();
9947       for (;ita<ita4;itres+=4,ita+=4){
9948 	dotvecteur_int_(ita,b,itres,p,yptr);
9949       }
9950       for (;ita!=itaend;++itres,++ita){
9951 	// if (dotvecteur_int(*ita,b)!=dotvecteur_int(*a[ita-A.begin()]._VECTptr,b,true))
9952 	// CERR << "erreur" << '\n';
9953 	*itres=dotvecteur_int_(*ita,b,p,yptr);
9954       }
9955     }
9956     else
9957 #endif
9958       {
9959 	vecteur::const_iterator ita=a.begin(), itaend=a.end();
9960 	res.resize(itaend-ita);
9961 	iterateur itres=res.begin();
9962 	for (;ita!=itaend;++itres,++ita)
9963 	  *itres=dotvecteur_int(*(ita->_VECTptr),b,smallint,p);
9964       }
9965   }
9966 
9967   // res += pn*x
add_multvecteur(vecteur & res,const gen & pn,const vecteur & x)9968   void add_multvecteur(vecteur & res,const gen & pn,const vecteur & x){
9969     iterateur it=res.begin(),itend=res.end();
9970     const_iterateur jt=x.begin();
9971     for (;it!=itend;++jt,++it){
9972 #ifdef USE_GMP_REPLACEMENTS
9973       *it += pn*(*jt);
9974 #else
9975       if (it->type==_ZINT && it->ref_count()==1 && pn.type==_ZINT){
9976 	if (jt->type==_INT_){
9977 	  if (jt->val>0)
9978 	    mpz_addmul_ui(*it->_ZINTptr,*pn._ZINTptr,jt->val);
9979 	  else
9980 	    mpz_submul_ui(*it->_ZINTptr,*pn._ZINTptr,-jt->val);
9981 	}
9982 	else
9983 	  mpz_addmul(*it->_ZINTptr,*pn._ZINTptr,*jt->_ZINTptr);
9984       }
9985       else
9986 	*it += pn*(*jt);
9987 #endif
9988     }
9989   }
9990 
9991   // solve a*x=b where a and b have integer coeffs
9992   // using a p-adic algorithm, n is the precision required
9993   // c is the inverse of a mod p
9994   // reconstruct is the number of components of x we want to compute, or 0 if compute all
9995   // NB: on Z[i], should use a prime such that -1 has a square root.
padic_linsolve_c(const matrice & a,const vecteur & b,const matrice & c,unsigned n,const gen & p,unsigned reconstruct)9996   vecteur padic_linsolve_c(const matrice & a,const vecteur & b,const matrice & c,unsigned n,const gen & p,unsigned reconstruct){
9997     unsigned bsize=unsigned(b.size()),asize=unsigned(a.size()); // should be the same
9998     if (reconstruct && reconstruct<bsize) bsize=reconstruct;
9999     vecteur res(bsize),y(b),x,tmp; // initialize y_0=b
10000     int resbits=n*nbits(p);
10001     uncoerce(res,resbits);
10002     int smallint = 0;
10003     if (p.type==_INT_ &&
10004 	((ulonglong) p.val*p.val < ((ulonglong) 1 << 63)/asize ))
10005       smallint=1;
10006     vector< vector<int> > A,C;
10007     gen pn=1;
10008     if (smallint){
10009 #ifndef GIAC_HAS_STO_38
10010       vecteur2vectvector_int(c,0,C);
10011 #endif
10012       gen ainf=linfnorm(a,context0);
10013       gen binf=linfnorm(b,context0);
10014       if (ainf.type==_INT_ && unsigned(ainf.val)< (((ulonglong) 1 << 63)/asize)/p.val){
10015 	smallint=2; // ainf*x_n can be computed using longlong
10016 #ifndef GIAC_HAS_STO_38
10017 	vecteur2vectvector_int(a,0,A);
10018 #endif
10019 	if (binf.type==_INT_)
10020 	  smallint=3;
10021       }
10022 #if !defined(USE_GMP_REPLACEMENTS)
10023       if (ainf.type==_ZINT
10024 	  // && binf.type==_INT_ && binf.val<p.val // FIXME: temporary workaround
10025 	  ){
10026 	int k,kprime;
10027 	for (k=1;is_greater(ainf,pn,context0);++k)
10028 	  pn=pn*p;
10029 	pn=p;
10030 	for (kprime=1;is_greater(binf,pn,context0);++kprime)
10031 	  pn=pn*p;
10032 	if ((k+2)*double(p.val)*asize*p.val<(1ULL<<63)){
10033 	  // A=sum_{i=0}^{k-1} A_i p^i, ||A_i||<p, find x=sum_{i=0}^n x_i p^i such that
10034 	  // Ax=B mod p^{n+1}, ||x_i||<p
10035 	  // Ax mod p^{n+1} = sum_{i=0}^n p^i* sum_{j=0}^{k-1} A_j*x_{i-j}
10036 	  // hence the p^i term is
10037 	  // B_i = A_0 x_i + sum_{j=1}^{k-1} A_j*x_{i-j} mod p + carries of at most 2 terms
10038 	  // hence x_i=C* know terms (keep carries and also compute A_0*x_i carries)
10039 	  // where C=A0^-1 mod p
10040 	  // CERR << "Fixme: implement faster p-adic" << '\n';
10041 	  vector< vector< vector<int> > > A(k,vector< vector<int> >(asize,vector<int>(asize)));
10042 	  vector< vector<int> > B(kprime,vector<int>(asize)),X(n,vector<int>(asize));
10043 	  // write a and b in basis p
10044 	  mpz_t tmpz,tmpr;
10045 	  mpz_init(tmpz); mpz_init(tmpr);
10046 	  for (unsigned i=0;i<asize;++i){
10047 	    vecteur & ai=*a[i]._VECTptr;
10048 	    for (unsigned j=0;j<asize;++j){
10049 	      gen g=ai[j];
10050 	      if (g.type==_ZINT)
10051 		mpz_set(tmpz,*g._ZINTptr);
10052 	      else
10053 		mpz_set_si(tmpz,g.val);
10054 	      for (int l=0;l<k;++l){
10055 		mpz_tdiv_qr_ui(tmpz,tmpr,tmpz,p.val);
10056 		A[l][i][j]=mpz_get_si(tmpr);
10057 	      }
10058 	    }
10059 	  }
10060 	  for (unsigned i=0;i<bsize;++i){
10061 	    gen g=b[i];
10062 	    if (g.type==_ZINT)
10063 	      mpz_set(tmpz,*g._ZINTptr);
10064 	    else
10065 	      mpz_set_si(tmpz,g.val);
10066 	    for (int l=0;l<kprime;++l){
10067 	      mpz_tdiv_qr_ui(tmpz,tmpr,tmpz,p.val);
10068 	      B[l][i]=mpz_get_si(tmpr);
10069 	    }
10070 	  }
10071 	  vector<int> carry1(asize),carry2(asize),value(asize);
10072 	  vector<longlong> restmp(asize),tmp(asize);
10073 	  for (unsigned i=0;i<n;++i){
10074 	    // compute sum_{j=1}^{k-1} A_j*x_{i-j}, take care of carries
10075 	    for (unsigned j=0;j<asize;++j){
10076 	      restmp[j]=carry1[j];
10077 	      carry1[j]=carry2[j];
10078 	    }
10079 	    if (int(i)<kprime){
10080 	      for (unsigned j=0;j<asize;++j){
10081 		restmp[j] += B[i][j];
10082 		// ?adjust carry1
10083 		// carry1[j] += restmp[j] / p.val;
10084 		// restmp[j] %= p.val;
10085 	      }
10086 	      // CERR << restmp << '\n';
10087 	    }
10088 	    for (int j=1;j<k && j<=int(i);++j){
10089 	      multmatvecteur_int(A[j],X[i-j],tmp);
10090 	      subvecteur_longlong(restmp,tmp);
10091 	    }
10092 	    for (unsigned j=0;j<asize;++j){
10093 	      value[j]=restmp[j] % p.val;
10094 	    }
10095 	    // value of x_i
10096 	    multmatvecteur_int(C,value,tmp);
10097 	    for (unsigned j=0;j<asize;++j){
10098 	      int x = tmp[j] % p.val;
10099 	      if (x<0)
10100 		x += p.val;
10101 	      X[i][j] = x;
10102 	    }
10103 	    // adjust tmp by substracting A[0]*X[i]
10104 	    multmatvecteur_int(A[0],X[i],tmp);
10105 	    subvecteur_longlong(restmp,tmp);
10106 	    // compute carries
10107 	    for (unsigned j=0;j<asize;++j){
10108 	      longlong l=restmp[j];
10109 	      // if (l % p.val) CERR << "error " << '\n';
10110 	      l /= p.val;
10111 	      longlong c=carry1[j] + (l % p.val);
10112 	      carry1[j] = c % p.val;
10113 	      carry2[j] = l/ p.val+c/p.val;
10114 	      // if (absint(carry2[j])>=p.val) CERR << "error " << '\n';
10115 	    }
10116 	  } // end loop on i
10117 	  pn=pow(p,int(n));
10118 	  // construct res from X[n-1]...X[0]
10119 	  for (unsigned l=0;l<bsize;++l){
10120 	    mpz_set_si(tmpz,0);
10121 	    for (int i=n-1;i>=0;--i){
10122 	      mpz_mul_ui(tmpz,tmpz,p.val);
10123 	      int x=X[i][l];
10124 	      if (x>0)
10125 		mpz_add_ui(tmpz,tmpz,x);
10126 	      else
10127 		mpz_sub_ui(tmpz,tmpz,-x);
10128 	    }
10129 	    mpz_set(*res[l]._ZINTptr,tmpz);
10130 	    res[l]=smod(res[l],pn);
10131 	  }
10132 	  mpz_clear(tmpz); mpz_clear(tmpr);
10133 	  // multmatvecteur(a,res,y);
10134 	  // CERR << smod(y,pn) << '\n';
10135 	  return res;
10136 	} // end ainf value eligible
10137       } // end ainf.type==_ZINT
10138 #endif
10139     }
10140     for (unsigned i=0;i<n;++i){
10141       smod(y,p,tmp);
10142       if (debug_infolevel>2)
10143 	CERR << CLOCK()*1e-6 << " padic mult A^-1 mod p*y step " << i << '\n';
10144       multmatvecteur_int(c,C,tmp,smallint!=0,x,smallint?p.val:0,NULL);
10145       if (!smallint) smod(x,p,x); // x_{n}=c*y_n mod p
10146       if (debug_infolevel>2)
10147 	CERR << CLOCK()*1e-6 << " padic mult A *x step " << i << '\n';
10148       if (smallint==3)
10149 	multmatvecteur_int(a,A,x,true,tmp,p.val,&y.front());
10150       else {
10151 	// y_{n+1}=(y_n-Ax_n)/p, |x_n|<=p
10152 	// A*x_n computation requires n^2 multiplications in log(Ainf)*log(p) time
10153 	// optimization if p is large: compute y_n=p*q+r, then y_{n+1}=q+(r-Ax_n)/p
10154 	// where (r-Ax_n)/p can be computed using modular arithmetic
10155 	// and the majoration ||(r-A*x_n)/p|| <= Ainf*n
10156 	// n^2*log(Ainf*n) operations, reconstruction is O(n*...)
10157 	// According to Chen and Storjohann tests the best choice is
10158 	// p=product of l primes
10159 	// l=(2 or 1)*log2(Ainf*n)
10160 	// total time: l*n^3 (initial inversions) + n^2*log(Ainf*n)*log(hadamard)/l
10161 	// vs 1 prime: n^3+n^2*log(Ainf)*log(hadamard)
10162 	// conclusion: optimization is only interesting if the constant before inversion n^3 is small compared to constant before n^2 matrix*vector multiplication
10163 	multmatvecteur_int(a,A,x,smallint>=2,tmp,0,NULL);
10164 	if (debug_infolevel>2)
10165 	  CERR << CLOCK()*1e-6 << " padic adjust y step " << i << '\n';
10166 	subvecteur(y,tmp,y);
10167 #ifdef USE_GMP_REPLACEMENTS
10168 	divvecteur(y,p,y);
10169 #else
10170 	iterateur it=y.begin(),itend=y.end();
10171 	if (p.type==_INT_){
10172 	  for (;it!=itend;++it){
10173 	    if (it->type==_ZINT) // assumes that p>0
10174 	      mpz_divexact_ui(*it->_ZINTptr,*it->_ZINTptr,p.val);
10175 	    else
10176 	      it->val /= p.val;
10177 	  }
10178 	}
10179 	else {
10180 	  for (;it!=itend;++it){
10181 	    if (it->type==_ZINT)
10182 	      mpz_divexact(*it->_ZINTptr,*it->_ZINTptr,*p._ZINTptr);
10183 	    // otherwise *it is of type _INT_ and divisible by p of type _ZINT hence it's 0
10184 	  }
10185 	}
10186 #endif
10187       }
10188       if (debug_infolevel>2)
10189 	CERR << CLOCK()*1e-6 << " padic adjust res step " << i << '\n';
10190       // should use below on Z[i]
10191       // x=smod(multmatvecteur(c,y),p); // x_{n+1}=c*y_n mod p
10192       // y=divvecteur(subvecteur(y,multmatvecteur(a,x)),p); // y_{n+1}=(y_n-Ax_n)/p
10193 #if 0
10194       multvecteur(pn,x,x);
10195       addvecteur(res,x,res);
10196 #else
10197       add_multvecteur(res,pn,x);
10198 #endif
10199       pn=pn*p;
10200     }
10201     return res;
10202   }
10203 
iszero(const vector<int> & p)10204   bool iszero(const vector<int> & p){
10205     vector<int>::const_iterator it=p.begin(),itend=p.end();
10206     for (;it!=itend;++it){
10207       if (*it)
10208 	return false;
10209     }
10210     return true;
10211   }
10212 
extract(const vector<vector<int>> & source,const vector<int> & lines,int rang,vector<vector<int>> & target,vector<vector<int>> & excluded)10213   static void extract(const vector< vector<int> > & source,const vector<int> & lines,int rang,vector< vector<int> > & target,vector< vector<int> > & excluded){
10214     int s=int(lines.size()),i;
10215     target.clear();
10216     target.reserve(rang);
10217     for (i=0;i<rang;++i){
10218       const vector<int> & si=source[lines[i]];
10219       if (iszero(si))
10220 	break;
10221       target.push_back(si);
10222     }
10223     for (;i<s;++i)
10224       excluded.push_back(source[lines[i]]);
10225   }
10226 
extract1(const matrice & source,const vector<int> & lines,int rang,matrice & target,vector<vecteur> & excluded)10227   static void extract1(const matrice & source,const vector<int> & lines,int rang,matrice & target,vector<vecteur> & excluded){
10228     int s=int(lines.size()),i;
10229     target.clear();
10230     target.reserve(rang);
10231     for (i=0;i<rang;++i){
10232       const vecteur & si=*source[lines[i]]._VECTptr;
10233       if (is_zero(si,context0))
10234 	break;
10235       target.push_back(si);
10236     }
10237     for (;i<s;++i)
10238       excluded.push_back(*source[lines[i]]._VECTptr);
10239   }
10240 
extract2(const matrice & source,const vector<int> & lines,int rang,matrice & target,vector<vecteur> & k_excluded,vector<int> & k_excluded_col)10241   static void extract2(const matrice & source,const vector<int> & lines,int rang,matrice & target,vector<vecteur> & k_excluded,vector<int> & k_excluded_col){
10242     int s=int(source.size()),i,j=0;
10243     target.clear();
10244     target.reserve(rang);
10245     for (i=0;i<rang;++i,++j){
10246       int li=lines[i];
10247       for (;j<li;++j){
10248 	k_excluded.push_back(*source[j]._VECTptr);
10249 	k_excluded_col.push_back(j);
10250       }
10251       const vecteur & si=*source[li]._VECTptr;
10252       target.push_back(si);
10253     }
10254     for (;j<s;++j){
10255       k_excluded.push_back(*source[j]._VECTptr);
10256       k_excluded_col.push_back(j);
10257     }
10258   }
10259 
init_modulo(int n,double logbound)10260   static gen init_modulo(int n,double logbound){
10261 #if 1 // def _I386_
10262     double pinit= double(longlong(1) << 60);
10263     pinit /=n ;
10264     pinit = std::sqrt(pinit);
10265     pinit -= 3*logbound; // keep enough primes satisfying p^2*n<2^63
10266     return nextprime(int(pinit));
10267 #else
10268     return 36007;
10269 #endif
10270   }
10271 
10272   // a is a matrix with integer coeffs
10273   // find p such that a mod p has the same rank
10274   // rankline and rankcols are the lines/cols used for the submatrix
10275   // asub of max rank, ainv is the inverse of asub mod p
10276   // return -1 or the rank
padic_linsolve_prepare(const matrice & a,gen & p,vector<int> & ranklines,vector<int> & rankcols,matrice & asub,matrice & ainv,vecteur & compat,vecteur & kernel)10277   int padic_linsolve_prepare(const matrice & a,gen & p,vector<int> & ranklines, vector<int> & rankcols,matrice & asub,matrice & ainv,vecteur & compat,vecteur & kernel){
10278     if (!is_integer_matrice(a))
10279       return -1;
10280     vector< vector<int> > N;
10281     if (!vecteur2vectvector_int(a,p.val,N))
10282       return -1;
10283     int nrows=int(N.size());
10284     int ncols=int(N.front().size());
10285     int n0=giacmax(ncols,nrows);
10286     gen h2=4*square_hadamard_bound(a);
10287     gen B=evalf_double(linfnorm(a,context0),0,context0);
10288     double Bd=B._DOUBLE_val;
10289     double logbound=n0*(std::log10(double(n0))/2+std::log10(Bd));
10290     if (is_exactly_zero(p) || p.type!=_INT_)
10291       p=init_modulo(n0,logbound);
10292     for (;;){ // break loop as soon as a good p is found
10293       matrice atmp;
10294       vector< vector<int> > Ntmp,Ninv,Nsub,Nmaxrank,Nexcluded;
10295       vector<vecteur> excluded,k_excluded;
10296       Nsub=N;
10297       int nstep=int(giacmin(nrows,ncols)*std::log(evalf_double(h2,1,context0)._DOUBLE_val)/2/std::log(double(p.val)))+1;
10298       vecteur pivots;
10299       longlong idet;
10300       smallmodrref(1,Nsub,pivots,ranklines,rankcols,idet,0,nrows,0,ncols,0 /* fullreduction*/,0 /* dont_swap_below */,p.val,0 /* rref_or_det_or_lu */,true,0,true,-1);
10301       int rang=int(rankcols.size());
10302       /* extract maxrank submatrix */
10303       extract(N,ranklines,rang,Ntmp,Nexcluded);
10304       tran_vect_vector_int(Ntmp,Nsub);
10305       extract1(a,ranklines,rang,atmp,excluded);
10306       mtran(atmp,asub);
10307       // next call does not change excluded
10308       extract(Nsub,rankcols,rang,Ntmp,Nexcluded);
10309       tran_vect_vector_int(Ntmp,Nsub);
10310       vector<int> k_excluded_col;
10311       extract2(asub,rankcols,rang,atmp,k_excluded,k_excluded_col);
10312       mtran(atmp,asub);
10313       // now asub contains the invertible matrix
10314       // we must truncate excluded, then rewrite each line of excluded
10315       // as a linear combination of lines of Np
10316       int es=int(excluded.size());
10317       for (int i=0;i<es;++i){
10318 	vecteur & v=excluded[i];
10319 	vecteur tmp=v;
10320 	v.clear();
10321 	for (int j=0;j<rang;++j)
10322 	  v.push_back(tmp[rankcols[j]]);
10323       }
10324       /* invert Nsub in Ninv */
10325       longlong det;
10326       if (!smallmodinv(Nsub,Ninv,p.val,det))
10327 	break; // should not happen!
10328       /* find compatibility with the lines of a that are not in Nmaxrank */
10329       vectvector_int2vecteur(Ninv,ainv);
10330       tran_vect_vector_int(Ninv,Ntmp);
10331       matrice c;
10332       vectvector_int2vecteur(Ntmp,c);
10333       int i;
10334       gen pn=pow(p,nstep,context0);
10335       for (i=0;i<es;++i){
10336 	/* p-adic lift of each compatibility equation */
10337 	vecteur current,cond(nrows);
10338 	cond[ranklines[rang+i]]=-1;
10339 	current=padic_linsolve_c(atmp,excluded[i],c,nstep,p);
10340 	int cs=int(current.size());
10341 	for (int j=0;j<cs;++j)
10342 	  current[j]=fracmod(current[j],pn);
10343 	/* rewrite using ranklines */
10344 	for (int j=0;j<rang;++j)
10345 	  cond[ranklines[j]]=current[j];
10346 	/* check that it is correct with the original matrix */
10347 	if (!is_zero(multvecteurmat(cond,a),context0))
10348 	  break;
10349 	compat.push_back(cond);
10350       }
10351       if (i==es){
10352 	/* compute kernel using k_excluded */
10353 	es=int(k_excluded.size());
10354 	for (i=0;i<es;++i){
10355 	  /* p-adic lift of each kernel element basis */
10356 	  vecteur current,cond(ncols);
10357 	  cond[k_excluded_col[i]]=-1;
10358 	  current=padic_linsolve_c(asub,k_excluded[i],ainv,nstep,p);
10359 	  int cs=int(current.size());
10360 	  for (int j=0;j<cs;++j)
10361 	    current[j]=fracmod(current[j],pn);
10362 	  /* rewrite using ranklines */
10363 	  for (int j=0;j<rang;++j)
10364 	    cond[rankcols[j]]=current[j];
10365 	  kernel.push_back(cond);
10366 	}
10367 	return rang;
10368       }
10369       /* bad modulo */
10370       p=nextprime(p+1);
10371     }
10372     return -1;
10373   }
10374 
10375   // solve
padic_linsolve_solve(const matrice & a,const gen & p,const vector<int> & ranklines,const vector<int> & rankcols,const matrice & asub,const matrice & ainv,const vecteur & compat,const vecteur & b,vecteur & sol)10376   bool padic_linsolve_solve(const matrice & a,const gen & p,const vector<int> & ranklines,const vector<int> & rankcols,const matrice & asub,const matrice & ainv,const vecteur & compat,const vecteur & b,vecteur & sol){
10377     // first check that b verifies compat
10378     int es=int(compat.size());
10379     for (int i=0;i<es;++i){
10380       if (!is_exactly_zero(dotvecteur(compat[i],b))){
10381 	return false;
10382       }
10383     }
10384     /* padic solve asub*x=part of b (ranklines) */
10385     int rang=int(asub.size());
10386     vecteur newb(rang);
10387     for (int i=0;i<rang;++i)
10388       newb[i]=b[ranklines[i]];
10389     gen h2=4*square_hadamard_bound(asub)*l2norm2(newb);
10390     int nstep=int(rang*std::log(evalf_double(h2,1,context0)._DOUBLE_val)/2/std::log(double(p.val)))+1;
10391     vecteur res=padic_linsolve_c(asub,newb,ainv,nstep,p);
10392     gen pn=pow(p,nstep,context0);
10393     int ress=int(res.size());
10394     for (int i=0;i<ress;++i)
10395       res[i]=fracmod(res[i],pn);
10396     /* find x (using rankcols) */
10397     int xs=int(a.front()._VECTptr->size());
10398     sol=vecteur(xs);
10399     for (int i=0;i<rang;++i){
10400       sol[rankcols[i]]=res[i];
10401     }
10402     return true;
10403   }
10404 
_padic_linsolve(const gen & g,GIAC_CONTEXT)10405   gen _padic_linsolve(const gen & g,GIAC_CONTEXT){
10406     if ( g.type==_STRNG && g.subtype==-1) return  g;
10407     if (g.type!=_VECT || g._VECTptr->empty())
10408       return gensizeerr(contextptr);
10409     if (g.subtype==_SEQ__VECT && g._VECTptr->size()==2){
10410       gen a=g._VECTptr->front();
10411       gen b=g._VECTptr->back();
10412       if (!ckmatrix(a) || b.type!=_VECT)
10413 	return gensizeerr(contextptr);
10414       if (a._VECTptr->front()._VECTptr->size()!=b._VECTptr->size())
10415 	return gendimerr(contextptr);
10416       matrice & A=*a._VECTptr;
10417       gen p;
10418       matrice asub,ainv;
10419       vecteur compat,kernel;
10420       vector<int> ranklines,rankcols;
10421       if (!padic_linsolve_prepare(A,p,ranklines,rankcols,asub,ainv,compat,kernel))
10422 	return gensizeerr(gettext("Unable to find a modulus to solve"));
10423       vecteur & B=*b._VECTptr;
10424       vecteur res;
10425       if (padic_linsolve_solve(A,p,ranklines,rankcols,asub,ainv,compat,B,res))
10426 	return makevecteur(res,kernel);
10427       else
10428 	return gensizeerr(gettext("Incompatible system"));
10429     }
10430     return gensizeerr(contextptr);
10431   }
10432   static const char _padic_linsolve_s []="padic_linsolve";
10433   static define_unary_function_eval (__padic_linsolve,&_padic_linsolve,_padic_linsolve_s);
10434   define_unary_function_ptr5( at_padic_linsolve ,alias_at_padic_linsolve,&__padic_linsolve,0,true);
10435 
10436   // solve A*x=b where a and b have integer coeffs using a p-adic algorithm
10437   // (ignoring extra columns of A)
10438   // lcmdeno of the answer may be used to give an estimate of the
10439   // least divisor element of A if b is random
10440   // returns 0 if no invertible found, -1 if det==0, 1 otherwise
padic_linsolve(const matrice & A,const vecteur & b,vecteur & res,gen & p,gen & det_mod_p,gen & h2,unsigned reconstruct,int maxtry)10441   int padic_linsolve(const matrice & A,const vecteur & b,vecteur & res,gen & p,gen & det_mod_p,gen & h2,unsigned reconstruct,int maxtry){
10442 #ifdef GIAC_HAS_STO_38
10443     return 0;
10444 #endif
10445     // first find p such that a mod p is invertible
10446     // find a bound on the num/den of x
10447     // let c=(a mod p)^(-1)
10448     matrice a(A);
10449     if (A.size()!=A.front()._VECTptr->size()){
10450       for (unsigned i=0;i<a.size();++i){
10451 	a[i]=new ref_vecteur(a[i]._VECTptr->begin(),a[i]._VECTptr->begin()+a.size());
10452       }
10453     }
10454     matrice c;
10455     matrice ab(a);
10456     ab.push_back(b);
10457     if (is_exactly_zero(p))
10458       p=36007;
10459     if (is_zero(h2))
10460       h2=4*square_hadamard_bound(ab);
10461     gen pip(1);
10462     if (debug_infolevel>2)
10463       CERR << "Modinv begin " << CLOCK()*1e-6 << '\n';
10464     for (int tryinv=0;;++tryinv){
10465       if (modinv(a,c,p,det_mod_p))
10466 	break;
10467       pip=pip*p;
10468       if (tryinv>maxtry)
10469 	return 0;
10470       if (is_strictly_greater(pip*pip,h2,context0)) // ok
10471 	return -1;
10472       p=nextprime(p+1);
10473     }
10474     if (debug_infolevel>2)
10475       CERR << "Modinv end " << CLOCK()*1e-6 << '\n';
10476     unsigned n=1;
10477     gen pn=p;
10478     while (is_strictly_greater(h2,pn,context0)){ // ok
10479       ++n;
10480       pn = pn * p;
10481     }
10482     gen sqrtpn=isqrt(pn); // (pow(gen(p),int(n/2),context0)-1)/2;
10483     vecteur resp=padic_linsolve_c(a,b,c,n,p,reconstruct);
10484     if (debug_infolevel>2)
10485       CERR << "Padic end " << CLOCK()*1e-6 << '\n';
10486     // rational reconstruction
10487     unsigned s=unsigned(resp.size());
10488     if (reconstruct)
10489       s=std::min(s,reconstruct);
10490     res.clear();
10491     res.reserve(s);
10492     gen lcmdeno(1);
10493     for (unsigned j=0;j<s;++j){
10494       if (j){
10495 	gen tmp=smod(lcmdeno*resp[j],pn);
10496 	if (is_strictly_positive(sqrtpn+tmp,context0) && is_strictly_positive(sqrtpn-tmp,context0)){
10497 	  if (0){ // debug
10498 	    gen tmp1=tmp/lcmdeno,tmp2=fracmod(resp[j],pn);
10499 	    if (tmp1!=tmp2)
10500 	      CERR << "err" << '\n';
10501 	  }
10502 	  res.push_back(tmp/lcmdeno);
10503 	  continue;
10504 	}
10505       }
10506       res.push_back(fracmod(resp[j],pn));
10507       if (res.back().type==_FRAC)
10508 	lcmdeno=lcm(lcmdeno,res.back()._FRACptr->den);
10509     }
10510     if (debug_infolevel>2)
10511       CERR << "Padic end rational reconstruction " << CLOCK()*1e-6 << '\n';
10512     if (0 && A.size()==res.size()){ // debug
10513       vecteur tmp(multvecteur(lcmdeno,res));
10514       tmp=multmatvecteur(A,tmp);
10515       CERR << tmp << multvecteur(lcmdeno,b) << '\n';
10516     }
10517     return 1;
10518   }
10519 
mrref(const matrice & a,GIAC_CONTEXT)10520   matrice mrref(const matrice & a,GIAC_CONTEXT){
10521     if (a.empty())
10522       return vecteur(vecteur(1,gendimerr(contextptr)));
10523     gen det;
10524     vecteur pivots;
10525     matrice res;
10526     if (!mrref(a,res,pivots,det,0,int(a.size()),0,int(a.front()._VECTptr->size()),
10527 	  /* fullreduction */1,0,true,1,0,
10528 	       contextptr))
10529       return vecteur(1,vecteur(1,gendimerr(contextptr)));
10530     return res;
10531   }
10532 
read_reduction_options(const gen & a_orig,matrice & a,bool & convert_internal,int & algorithm,bool & minor_det,bool & keep_pivot,int & last_col)10533   bool read_reduction_options(const gen & a_orig,matrice & a,bool & convert_internal,int & algorithm,bool & minor_det,bool & keep_pivot,int & last_col){
10534     convert_internal=true;
10535     algorithm=RREF_GUESS;
10536     minor_det=false;
10537     keep_pivot=false;
10538     last_col=-1;
10539     if (ckmatrix(a_orig)){
10540       a=*a_orig._VECTptr;
10541     }
10542     else { // rref with options
10543       if (a_orig.type!=_VECT)
10544 	return false;
10545       vecteur v=*a_orig._VECTptr;
10546       int s=int(v.size());
10547       if (s<=3 && v[0].is_symb_of_sommet(at_pnt)){
10548 	for (int i=0;i<s;++i){
10549 	  v[i]=remove_at_pnt(v[i]);
10550 	  if (v[i].subtype==_VECTOR__VECT && v[i]._VECTptr->size()==2)
10551 	    v[i]=v[i]._VECTptr->back()-v[i]._VECTptr->front();
10552 	  if (v[i].type!=_VECT){
10553 	    gen a,b;
10554 	    reim(v[i],a,b,context0);
10555 	    v[i]=makevecteur(a,b);
10556 	  }
10557 	}
10558 	if (ckmatrix(v))
10559 	  return read_reduction_options(v,a,convert_internal,algorithm,minor_det,keep_pivot,last_col);
10560       }
10561       if (!s || !ckmatrix(v[0]))
10562 	return false;
10563       a=*v[0]._VECTptr;
10564       for (int i=1;i<s;++i){
10565 	if (v[i]==at_lagrange)
10566 	  algorithm=RREF_LAGRANGE;
10567 	if (v[i]==at_irem)
10568 	  algorithm=RREF_MODULAR;
10569 	if (v[i]==at_linsolve)
10570 	  algorithm=RREF_PADIC;
10571 	if (v[i].type==_INT_){
10572 	  if (v[i].subtype==_INT_SOLVER){
10573 	    switch (v[i].val){
10574 	    case _RATIONAL_DET:
10575 	      convert_internal=false;
10576 	      algorithm=RREF_GAUSS_JORDAN;
10577 	      break;
10578 	    case _BAREISS:
10579 	      algorithm=RREF_BAREISS;
10580 	      break;
10581 	    case _KEEP_PIVOT:
10582 	      keep_pivot=true;
10583 	      break;
10584 	    case _MINOR_DET:
10585 	      minor_det=true;
10586 	    }
10587 	  }
10588 	  else
10589 	    last_col=v[i].val;
10590 	}
10591       }
10592     }
10593     return true;
10594   }
_rref(const gen & a_orig,GIAC_CONTEXT)10595   gen _rref(const gen & a_orig,GIAC_CONTEXT) {
10596     if ( a_orig.type==_STRNG && a_orig.subtype==-1) return  a_orig;
10597     matrice a;
10598     bool convert_internal,minor_det,keep_pivot;
10599     int algorithm,last_col;
10600     if (!read_reduction_options(a_orig,a,convert_internal,algorithm,minor_det,keep_pivot,last_col))
10601       return gensizeerr(contextptr);
10602     if (minor_det)
10603       return gensizeerr(gettext("minor_det option applies only to det"));
10604     gen det;
10605     vecteur pivots;
10606     matrice res;
10607     int ncols=int(a.front()._VECTptr->size());
10608     if (last_col>=0)
10609       ncols=giacmin(ncols,last_col);
10610     if (!mrref(a,res,pivots,det,0,int(a.size()),0,ncols,
10611 	  /* fullreduction */1,0,convert_internal,algorithm,0,
10612 	       contextptr))
10613       return gendimerr(contextptr);
10614     if (!keep_pivot){
10615       mdividebypivot(res,ncols,contextptr);
10616     }
10617     if (res.front().type==_VECT && res.front()._VECTptr->front().type==_MOD)
10618       return res;
10619     return ratnormal(res,contextptr);
10620   }
10621   static const char _rref_s []="rref";
10622   static define_unary_function_eval (__rref,&_rref,_rref_s);
10623   define_unary_function_ptr5( at_rref ,alias_at_rref,&__rref,0,true);
10624 
10625   // returns 0 if all elements are 0
first_non_zero(const vecteur & v,int lastcol,GIAC_CONTEXT)10626   static gen first_non_zero(const vecteur & v,int lastcol,GIAC_CONTEXT){
10627     vecteur::const_iterator it=v.begin(),itend=v.end();
10628     if (itend-it>lastcol)
10629       itend=it+lastcol;
10630     if (has_num_coeff(v)){
10631       gen vmax=0,tmp;
10632       // in approx mode, we want to make a relative comparison with 0
10633       // find the largest value of the row in absolute value
10634       for (;it!=itend;++it){
10635 	if (has_evalf(*it,tmp,1,contextptr) && is_greater((tmp=abs(tmp,contextptr)),vmax,contextptr))
10636 	  vmax=tmp;
10637       }
10638       it=v.begin();
10639       vmax=inv(vmax,contextptr);
10640       for (;it!=itend;++it){
10641 	if (!is_zero(*it*vmax,contextptr))
10642 	  //if (!is_exactly_zero(*it))
10643 	  return *it;
10644       }
10645     }
10646     else {
10647       for (;it!=itend;++it){
10648 	if (!is_zero(*it,contextptr))
10649 	  return *it;
10650       }
10651     }
10652     return 0;
10653   }
10654 
mdividebypivot(matrice & a,int lastcol,GIAC_CONTEXT)10655   void mdividebypivot(matrice & a,int lastcol,GIAC_CONTEXT){
10656     if (lastcol==-1)
10657       lastcol=int(a.front()._VECTptr->size());
10658     if (lastcol==-2)
10659       lastcol=int(a.front()._VECTptr->size())-1;
10660     if (lastcol<0)
10661       lastcol=0;
10662     vecteur::const_iterator ita=a.begin(),itaend=a.end();
10663     gen pivot;
10664     for (;ita!=itaend;++ita){
10665       pivot=first_non_zero(*(ita->_VECTptr),lastcol,contextptr);
10666       if (!is_exactly_zero(pivot))
10667 	divvecteur(*(ita->_VECTptr),pivot,*(ita->_VECTptr));
10668     }
10669   }
10670 
mdividebypivot(matrice & a,int lastcol)10671   void mdividebypivot(matrice & a,int lastcol){
10672     mdividebypivot(a,lastcol,context0);
10673   }
10674 
midn(int n,matrice & res)10675   void midn(int n,matrice & res){
10676     if (n<=0 || longlong(n)*n>LIST_SIZE_LIMIT){
10677       res= vecteur(1,vecteur(1,gendimerr(gettext("idn"))));
10678       return ;
10679     }
10680     res.clear();
10681     res.reserve(n);
10682     vecteur v;
10683     for (int i=0;i<n;++i){
10684       res.push_back(new ref_vecteur(n));
10685       (*res[i]._VECTptr)[i]=1;
10686     }
10687   }
10688 
midn(int n)10689   matrice midn(int n){
10690     matrice res;
10691     midn(n,res);
10692     return res;
10693   }
10694 
_idn(const gen & e,GIAC_CONTEXT)10695   gen _idn(const gen & e,GIAC_CONTEXT) {
10696     if ( e.type==_STRNG && e.subtype==-1) return  e;
10697     matrice res;
10698     if (e.type==_INT_)
10699       midn(e.val,res);
10700     else {
10701       if (e.type==_DOUBLE_)
10702 	midn(int(e._DOUBLE_val),res);
10703       else {
10704 	if ((e.type==_VECT) && is_squarematrix(*e._VECTptr))
10705 	  midn(int(e._VECTptr->size()),res);
10706 	else
10707 	  return gensizeerr(contextptr);
10708       }
10709     }
10710     return gen(res,_MATRIX__VECT);
10711   }
10712   static const char _idn_s []="idn";
10713   static define_unary_function_eval (__idn,&_idn,_idn_s);
10714   define_unary_function_ptr5( at_idn ,alias_at_idn,&__idn,0,true);
10715 
10716   // find index i of x in v that is i such that v[i] <= x < v[i+1]
10717   // where v[-1]=-inf, and v[v.size()]=+inf
dichotomy(const vector<giac_double> & v,double x)10718   int dichotomy(const vector<giac_double> & v,double x){
10719     int s=int(v.size());
10720     if (x<v[0])
10721       return -1;
10722     if (x>=v[s-1])
10723       return s-1;
10724     int a=0, b=s-1; // v[a] <= x < v[b]
10725     while (b-a>1){
10726       int c=(a+b)/2;
10727       if (x>=v[c])
10728 	a=c;
10729       else
10730 	b=c;
10731     }
10732     return a;
10733   }
10734 
10735 #ifndef USE_GMP_REPLACEMENTS
10736   static int randvar_count=0;
10737 
find_randvars(const gen & g,gen_map & rv,GIAC_CONTEXT)10738   gen find_randvars(const gen &g,gen_map &rv,GIAC_CONTEXT) {
10739     stringstream ss;
10740     if (g.type==_IDNT) {
10741       if (rv.find(g)!=rv.end())
10742         return rv[g];
10743       ss << " var" << randvar_count;
10744       identificateur v(ss.str().c_str());
10745       rv[g]=v;
10746       ++randvar_count;
10747       return v;
10748     }
10749 #ifndef USE_GMP_REPLACEMENTS
10750     if (g.is_symb_of_sommet(at_discreted) || is_distribution(g)>0) {
10751       ss << " tmp" << randvar_count;
10752       identificateur t(ss.str().c_str());
10753       ss.str("");
10754       ss << " var" << randvar_count;
10755       identificateur v(ss.str().c_str());
10756       _eval(symbolic(at_sto,makesequence(g,t)),contextptr);
10757       rv[t]=v;
10758       ++randvar_count;
10759       return v;
10760     }
10761 #endif
10762     if (g.type==_SYMB) {
10763       gen &f=g._SYMBptr->feuille;
10764       if (f.type==_VECT) {
10765         vecteur F;
10766         F.reserve(f._VECTptr->size());
10767         for (iterateur it=f._VECTptr->begin();it!=f._VECTptr->end();++it) {
10768           F.push_back(find_randvars(*it,rv,contextptr));
10769         }
10770         return symbolic(g._SYMBptr->sommet,change_subtype(F,_SEQ__VECT));
10771       }
10772       return symbolic(g._SYMBptr->sommet,find_randvars(f,rv,contextptr));
10773     }
10774     return g;
10775   }
10776 #endif
10777 
fieldcoeff(const gen & F)10778   gen fieldcoeff(const gen &F){
10779     if (F.type!=_VECT)
10780       return F;
10781     const vecteur & v=*F._VECTptr;
10782     gen res;
10783     for (size_t i=0;i<v.size();++i){
10784       gen tmp(fieldcoeff(v[i]));
10785       if (tmp.type==_USER)
10786 	return tmp;
10787       if (tmp.type>=res.type)
10788 	res=tmp;
10789     }
10790     return res;
10791   }
10792 
vranm(int n,const gen & F,vecteur & res,GIAC_CONTEXT)10793   void vranm(int n,const gen & F,vecteur & res,GIAC_CONTEXT){
10794     gen f(fieldcoeff(F));
10795     if (f.type==_USER)
10796       f=symbolic(at_rand,f);
10797     n=giacmax(1,n);
10798     if (n>LIST_SIZE_LIMIT)
10799       setstabilityerr();
10800     res.reserve(n);
10801     if (f.type!=_MOD && f.type!=_USER && is_zero(f,contextptr)){
10802       for (int i=0;i<n;++i){
10803 	res.push_back((int) (2*randrange*giac_rand(contextptr)/(rand_max2+1.0)-randrange));
10804       }
10805       return;
10806     }
10807     if (is_integer(f)){
10808       if (f.type==_INT_){
10809 	int t=f.val;
10810 	if (t<0){
10811 	  for (int i=0;i<n;++i)
10812 	    res.push_back((int) (2*t*(giac_rand(contextptr)/(rand_max2+1.0))-t)	);
10813 	  return;
10814 	}
10815 #if 0
10816 	int add=(xcas_mode(contextptr)==3 || abs_calc_mode(contextptr)==38);
10817 	for (int i=0;i<n;++i)
10818 	  res.push_back(add+(int) t*(giac_rand(contextptr)/(rand_max2+1.0)));
10819 	return;
10820 #endif
10821       }
10822       for (int i=0;i<n;++i)
10823 	res.push_back(_rand(f,contextptr));
10824       return;
10825     }
10826     if (f.type==_MOD){
10827       gen fm=*(f._MODptr+1);
10828       vranm(n,fm,res,contextptr);
10829       for (int i=0;i<n;++i)
10830 	res[i]=makemod(res[i],fm);
10831       return;
10832     }
10833     if (f.type==_VECT){
10834       const vecteur & v = *f._VECTptr;
10835       int s=int(v.size());
10836       for (int i=0;i<n;++i){
10837 	double d=giac_rand(contextptr)*double(s)/(rand_max2+1.0);
10838 	res.push_back(v[int(d)]);
10839       }
10840       return;
10841     }
10842     if (f.is_symb_of_sommet(at_interval) && f._SYMBptr->feuille.type==_VECT){
10843       gen x=evalf(f._SYMBptr->feuille._VECTptr->front(),1,contextptr),y=evalf(f._SYMBptr->feuille._VECTptr->back(),1,contextptr);
10844       if (x.type==_DOUBLE_ && y.type==_DOUBLE_){
10845 	double xd=x._DOUBLE_val,yd=y._DOUBLE_val;
10846 	double scale=(yd-xd)/(rand_max2+1.0);
10847 	for (int i=0;i<n;++i){
10848 	  double xr= giac_rand(contextptr)*scale+xd;
10849 	  res.push_back(xr);
10850 	}
10851 	return;
10852       }
10853       for (int i=0;i<n;++i)
10854 	res.push_back(rand_interval(*f._SYMBptr->feuille._VECTptr,false,contextptr));
10855       return;
10856     }
10857     if (f==at_uniform || f==at_uniformd){
10858       for (int i=0;i<n;++i)
10859 	res.push_back(giac_rand(contextptr)/(rand_max2+1.0));
10860       return;
10861     }
10862     if (f.is_symb_of_sommet(at_uniform) ||f.is_symb_of_sommet(at_uniformd) ){
10863       f=evalf_double(f._SYMBptr->feuille,1,contextptr);
10864       if (f.type!=_VECT || f._VECTptr->size()!=2 || f._VECTptr->front().type!=_DOUBLE_ || f._VECTptr->back().type!=_DOUBLE_){
10865 	res=vecteur(1,gensizeerr(contextptr));
10866 	return ;
10867       }
10868       double a=f._VECTptr->front()._DOUBLE_val,b=f._VECTptr->back()._DOUBLE_val,c=b-a;
10869       for (int i=0;i<n;++i)
10870 	res.push_back(a+c*giac_rand(contextptr)/(rand_max2+1.0));
10871       return;
10872     }
10873     if (f.is_symb_of_sommet(at_poisson) ||f.is_symb_of_sommet(at_POISSON) ){
10874       f=evalf_double(f._SYMBptr->feuille,1,contextptr);
10875       if (f.type!=_DOUBLE_ || f._DOUBLE_val<=0){
10876 	res=vecteur(1,gensizeerr(contextptr));
10877 	return ;
10878       }
10879       double lambda=f._DOUBLE_val;
10880       int Nv=int(2*lambda+53); // insure that poisson_cdf(lambda,Nv)==1 up to double precision
10881       if (Nv*n>5*lambda+n*std::ceil(std::log(double(Nv))/std::log(2.0))){
10882 	vector<giac_double> tableau(Nv+1);
10883 	long_double cumul=0;
10884 	long_double current;
10885 	for (int k=0;k<Nv;++k){
10886 	  // recompute current from time to time
10887 	  if (k>>5==0)
10888 	    current=std::exp(-lambda+k*std::log(lambda)-lngamma(k+1));
10889 	  cumul += current;
10890 	  tableau[k+1] = cumul;
10891 	  current *= lambda/(k+1);
10892 	}
10893 	for (int i=0;i<n;++i){
10894 	  res.push_back(dichotomy(tableau,double(giac_rand(contextptr))/rand_max2));
10895 	}
10896 	return;
10897       }
10898       for (int i=0;i<n;++i)
10899 	res.push_back(randpoisson(lambda,contextptr));
10900       return;
10901     }
10902     bool loigamma=f.is_symb_of_sommet(at_gammad) || f.is_symb_of_sommet(at_randgammad);
10903     bool loibeta=f.is_symb_of_sommet(at_betad) || f.is_symb_of_sommet(at_randbetad);
10904     bool loiweibull=f.is_symb_of_sommet(at_weibulld) || f.is_symb_of_sommet(at_randweibulld);
10905     if (loigamma || loiweibull || loibeta){
10906       f=evalf_double(f._SYMBptr->feuille,1,contextptr);
10907       gen a,b;
10908       if (f.type==_VECT && f._VECTptr->size()==2){
10909 	a=f._VECTptr->front();
10910 	b=f._VECTptr->back();
10911       }
10912       if (a.type!=_DOUBLE_ || b.type!=_DOUBLE_ || a._DOUBLE_val<=0 || b._DOUBLE_val<=0){
10913 	res=vecteur(1,gensizeerr(contextptr));
10914 	return;
10915       }
10916       if (loibeta){
10917 	for (int i=0;i<n;++i){
10918 	  double X=rgamma(a._DOUBLE_val,1.0,contextptr);
10919 	  double Y=rgamma(b._DOUBLE_val,1.0,contextptr);
10920 	  res.push_back(X/(X+Y));
10921 	}
10922 	return;
10923       }
10924       if (loigamma){
10925 	double scale=1.0/b._DOUBLE_val;
10926 	for (int i=0;i<n;++i)
10927 	  res.push_back(rgamma(a._DOUBLE_val,scale,contextptr));
10928 	return;
10929       }
10930       if (loiweibull){
10931 	double invk=1.0/a._DOUBLE_val;
10932 	for (int i=0;i<n;++i)
10933 	  res.push_back(b._DOUBLE_val*std::pow(exp_rand(contextptr),invk));
10934 	return;
10935       }
10936     }
10937     if (f.is_symb_of_sommet(at_exp) || f.is_symb_of_sommet(at_EXP) || f.is_symb_of_sommet(at_randexp) || f.is_symb_of_sommet(at_exponential) || f.is_symb_of_sommet(at_exponentiald)){
10938       f=evalf_double(f._SYMBptr->feuille,1,contextptr);
10939       if (f.type!=_DOUBLE_ || f._DOUBLE_val<=0){
10940 	res=vecteur(1,gensizeerr(contextptr));
10941 	return;
10942       }
10943       double lambda=f._DOUBLE_val;
10944       for (int i=0;i<n;++i)
10945 	res.push_back(gen(-std::log(1-giac_rand(contextptr)/(rand_max2+1.0))/lambda));
10946       return;
10947     }
10948     if (f.is_symb_of_sommet(at_geometric) || f.is_symb_of_sommet(at_randgeometric)){
10949       f=evalf_double(f._SYMBptr->feuille,1,contextptr);
10950       if (f.type!=_DOUBLE_ || f._DOUBLE_val<=0){
10951 	res=vecteur(1,gensizeerr(contextptr));
10952 	return;
10953       }
10954       double lambda=std::log(1-f._DOUBLE_val);
10955       for (int i=0;i<n;++i)
10956 	res.push_back(int(std::ceil(std::log(1-giac_rand(contextptr)/(rand_max2+1.0))/lambda)));
10957       return;
10958     }
10959     if (f==at_normald || f==at_NORMALD || f==at_normal || f==at_randNorm || f==at_randnormald)
10960       f=symbolic(at_normald,makesequence(0,1));
10961     if ( (f.is_symb_of_sommet(at_normald) || f.is_symb_of_sommet(at_NORMALD) || f.is_symb_of_sommet(at_normal) || f.is_symb_of_sommet(at_randNorm) || f.is_symb_of_sommet(at_randnormald)) && f._SYMBptr->feuille.type==_VECT && f._SYMBptr->feuille._VECTptr->size()==2 ){
10962       gen M=evalf_double(f._SYMBptr->feuille._VECTptr->front(),1,contextptr);
10963       f=evalf_double(f._SYMBptr->feuille._VECTptr->back(),1,contextptr);
10964       if (is_squarematrix(f)){
10965 	int dim=int(f._VECTptr->size());
10966 	vecteur w(dim);
10967 	for (int i=0;i<n;++i){
10968 	  for (int j=0;j<dim;++j){
10969 	    double u=giac_rand(contextptr)/(rand_max2+1.0);
10970 	    double d=giac_rand(contextptr)/(rand_max2+1.0);
10971 	    w[j]=std::sqrt(-2*std::log(u))*std::cos(2*M_PI*d);
10972 	  }
10973 	  res.push_back(M+multmatvecteur(*f._VECTptr,w));
10974 	}
10975 	return;
10976       }
10977       if (M.type!=_DOUBLE_ || f.type!=_DOUBLE_ || f._DOUBLE_val<=0 ){
10978 	res=vecteur(1,gensizeerr(contextptr));
10979 	return;
10980       }
10981       double m=M._DOUBLE_val,sigma=f._DOUBLE_val;
10982       for (int i=0;i<n;++i){
10983 	double u=giac_rand(contextptr)/(rand_max2+1.0);
10984 	double d=giac_rand(contextptr)/(rand_max2+1.0);
10985 	res.push_back(m+sigma*std::sqrt(-2*std::log(u))*std::cos(2*M_PI*d));
10986       }
10987       return;
10988     }
10989     if ( (f.is_symb_of_sommet(at_fisher) || f.is_symb_of_sommet(at_fisherd) || f.is_symb_of_sommet(at_randfisherd)
10990 	  || f.is_symb_of_sommet(at_snedecor)
10991 	  || f.is_symb_of_sommet(at_randfisher)) && f._SYMBptr->feuille.type==_VECT && f._SYMBptr->feuille._VECTptr->size()==2 ){
10992       gen g1(f._SYMBptr->feuille._VECTptr->front()),g2(f._SYMBptr->feuille._VECTptr->back());
10993       if ( is_integral(g1) && g1.type==_INT_ && g1.val>0 && g1.val<=1000 && is_integral(g2) && g2.type==_INT_ && g2.val>0 && g2.val<=1000){
10994 	int k1=g1.val,k2=g2.val;
10995 	for (int i=0;i<n;++i)
10996 	  res.push_back(randchisquare(k1,contextptr)/k1/(randchisquare(k2,contextptr)/k2));
10997 	return ;
10998       }
10999     }
11000     if ( (f.is_symb_of_sommet(at_chisquare) || f.is_symb_of_sommet(at_randchisquare) ||
11001 	  f.is_symb_of_sommet(at_chisquared) || f.is_symb_of_sommet(at_randchisquared) ) && f._SYMBptr->feuille.type==_INT_ && f._SYMBptr->feuille.val>0 && f._SYMBptr->feuille.val<=1000){
11002       int k=f._SYMBptr->feuille.val;
11003       for (int i=0;i<n;++i)
11004 	res.push_back(randchisquare(k,contextptr));
11005       return;
11006     }
11007     if (f==at_cauchy || f==at_cauchyd){
11008       for (int i=0;i<n;++i)
11009 	res.push_back(std::tan(M_PI*giac_rand(contextptr)/(rand_max2+1.0)-.5));
11010       return;
11011     }
11012       if ( (f.is_symb_of_sommet(at_cauchy) || f.is_symb_of_sommet(at_cauchyd) ) && f._SYMBptr->feuille.type==_VECT && f._SYMBptr->feuille._VECTptr->size()==2 ){
11013       gen g1(f._SYMBptr->feuille._VECTptr->front()),g2(f._SYMBptr->feuille._VECTptr->back());
11014       g1=evalf_double(g1,1,contextptr);
11015       g2=evalf_double(g2,1,contextptr);
11016       if (g1.type!=_DOUBLE_ || g2.type!=_DOUBLE_){
11017 	res=vecteur(1,gensizeerr(contextptr));
11018 	return;
11019       }
11020       //double d1=g1._DOUBLE_val,d2=g2._DOUBLE_val;
11021       for (int i=0;i<n;++i)
11022 	res.push_back(std::tan(M_PI*giac_rand(contextptr)/(rand_max2+1.0)-.5)*g2+g1);
11023       return;
11024     }
11025     if ( f.is_symb_of_sommet(at_student) || f.is_symb_of_sommet(at_randstudent) ||
11026 	 f.is_symb_of_sommet(at_studentd) || f.is_symb_of_sommet(at_randstudentd)){
11027       if (f._SYMBptr->feuille.type==_INT_ && f._SYMBptr->feuille.val>0 && f._SYMBptr->feuille.val<=1000){
11028 	int k=f._SYMBptr->feuille.val;
11029 	for (int i=0;i<n;++i)
11030 	  res.push_back(randstudent(k,contextptr));
11031 	return;
11032       }
11033       res= vecteur(1,gensizeerr(contextptr));
11034       return;
11035     }
11036     if (f.is_symb_of_sommet(at_multinomial) && f._SYMBptr->feuille.type==_VECT){
11037       gen P=f._SYMBptr->feuille;
11038       vecteur val;
11039       if (P._VECTptr->size()==2 && P._VECTptr->front().type==_VECT){
11040 	if (P._VECTptr->back().type!=_VECT || P._VECTptr->front()._VECTptr->size()!=P._VECTptr->back()._VECTptr->size()){
11041 	  res=vecteur(1,gensizeerr(contextptr));
11042 	  return;
11043 	}
11044 	val=*P._VECTptr->back()._VECTptr;
11045 	P=P._VECTptr->front();
11046       }
11047       if (!is_zero(1-_sum(P,contextptr))){
11048 	res=vecteur(1,gensizeerr(contextptr));
11049 	return;
11050       }
11051       const vecteur & v=*P._VECTptr;
11052       // cdf of probabilities
11053       unsigned vs=unsigned(v.size());
11054       vector<giac_double> tableau(vs+1);
11055       vector<int> eff(vs);
11056       if (!val.empty())
11057 	res.reserve(n);
11058       gen g=evalf_double(v[0],1,contextptr);
11059       if (g.type!=_DOUBLE_){
11060 	res=vecteur(1,gensizeerr(contextptr));
11061 	return;
11062       }
11063       tableau[1]=g._DOUBLE_val*rand_max2;
11064       for (unsigned i=1;i<vs;++i){
11065 	g=evalf_double(v[i],1,contextptr);
11066 	if (g.type!=_DOUBLE_){
11067 	  res=vecteur(1,gensizeerr(contextptr));
11068 	  return;
11069 	}
11070 	tableau[i+1]=g._DOUBLE_val*rand_max2+tableau[i];
11071       }
11072       // generate n random values, count them if val=0
11073       for (unsigned i=0;int(i)<n;++i){
11074 	int j=dichotomy(tableau,giac_rand(contextptr));
11075 	if (j>=int(vs))
11076 	  j=vs;
11077 	if (val.empty())
11078 	  ++eff[j];
11079 	else
11080 	  res.push_back(val[j]);
11081       }
11082       if (val.empty())
11083 	vector_int2vecteur(eff,res);
11084       return;
11085     }
11086     if ( (f.is_symb_of_sommet(at_binomial) || f.is_symb_of_sommet(at_BINOMIAL))
11087 	 && f._SYMBptr->feuille.type==_VECT && f._SYMBptr->feuille._VECTptr->size()==2){
11088       gen N=f._SYMBptr->feuille._VECTptr->front();
11089       f=evalf_double(f._SYMBptr->feuille._VECTptr->back(),1,contextptr);
11090       if (!is_integral(N) || N.type!=_INT_ || N.val<=0 || f.type!=_DOUBLE_ || f._DOUBLE_val<=0 || f._DOUBLE_val>=1){
11091 	res= vecteur(1,gensizeerr(contextptr));
11092 	return;
11093       }
11094       double p=f._DOUBLE_val;
11095       int Nv=N.val;
11096       if (Nv==1){
11097 	int seuil=int(rand_max2*p);
11098 	for (int i=0;i<n;++i){
11099 	  res.push_back(giac_rand(contextptr)<=seuil);
11100 	}
11101 	return;
11102       }
11103       // computation time is proportionnal to Nv*n with the sum of n randoms value 0/1
11104       // other idea compute once binomial_cdf(Nv,k,p) for k in [0..Nv]
11105       // then find position of random value in the list: this costs Nv+n*ceil(log2(Nv)) operations
11106       if (double(Nv)*n>5*Nv+n*std::ceil(std::log(double(Nv))/std::log(2.0))){
11107 	vector<giac_double> tableau(Nv+1);
11108 	long_double cumul=0;
11109 	long_double current; // =std::pow(1-p,Nv);
11110 	for (int k=0;k<Nv;++k){
11111 	  // recompute current from time to time
11112 	  if (k%32==0)
11113 	    current=std::exp(lngamma(Nv+1)-lngamma(k+1)-lngamma(Nv-k+1)+k*std::log(p)+(Nv-k)*std::log(1-p));
11114 	  cumul += current;
11115 	  tableau[k+1] = cumul;
11116 	  current *= p*(Nv-k)/(k+1)/(1-p);
11117 	}
11118 	for (int i=0;i<n;++i){
11119 	  res.push_back(dichotomy(tableau,double(giac_rand(contextptr))/rand_max2));
11120 	}
11121 	return;
11122       }
11123       if (Nv>1000){
11124 	for (int i=0;i<n;++i)
11125 	  res.push_back(binomial_icdf(Nv,p,double(giac_rand(contextptr))/rand_max2,contextptr));
11126       }
11127       else {
11128 	p *= rand_max2;
11129 	for (int i=0;i<n;++i){
11130 	  int ok=0;
11131 	  for (int j=0;j<Nv;++j){
11132 	    if (giac_rand(contextptr)<=p)
11133 	      ok++;
11134 	  }
11135 	  res.push_back(ok);
11136 	}
11137       }
11138       return;
11139     }
11140     if (f.is_symb_of_sommet(at_program)){
11141       for (int i=0;i<n;++i)
11142 	res.push_back(f(vecteur(0),contextptr));
11143       return;
11144     }
11145     if (f.is_symb_of_sommet(at_rootof)){
11146       gen ff=f._SYMBptr->feuille;
11147       if (ff.type==_VECT && !ff._VECTptr->empty()){
11148 	ff=ff._VECTptr->back();
11149 	if (ff.type==_VECT && !ff._VECTptr->empty()){
11150 	  int d=int(ff._VECTptr->size())-1;
11151 	  for (int i=0;i<n;++i){
11152 	    gen g=vranm(d,0,contextptr);
11153 	    res.push_back(symb_rootof(g,ff,contextptr));
11154 	  }
11155 	  return;
11156 	}
11157       }
11158     }
11159 #ifndef USE_GMP_REPLACEMENTS
11160     if (f.is_symb_of_sommet(at_discreted)) {
11161       const vecteur &args=*f._SYMBptr->feuille._VECTptr;
11162       for (int i=0;i<n;++i) {
11163         res.push_back(randdiscrete(args,contextptr));
11164       }
11165       return;
11166     }
11167     if (f.type==_SYMB) {
11168       gen_map rv;
11169       randvar_count=0;
11170       gen e=find_randvars(f,rv,contextptr);
11171       if (!rv.empty()) {
11172         int nv=rv.size();
11173         vecteur vars;
11174         matrice R;
11175         vars.reserve(nv);
11176         R.reserve(nv);
11177         for (gen_map::const_iterator it=rv.begin();it!=rv.end();++it) {
11178           vars.push_back(it->second);
11179           R.push_back(vranm(n,_eval(it->first,contextptr),contextptr));
11180         }
11181         R=mtran(R);
11182         for (const_iterateur it=R.begin();it!=R.end();++it) {
11183           res.push_back(_subs(makesequence(e,vars,*it),contextptr));
11184         }
11185         return;
11186       }
11187     }
11188 #endif
11189     for (int i=0;i<n;++i)
11190       res.push_back(eval(f,eval_level(contextptr),contextptr));
11191   }
11192 
vranm(int n,const gen & F,GIAC_CONTEXT)11193   vecteur vranm(int n,const gen & F,GIAC_CONTEXT){
11194     vecteur res;
11195     vranm(n,F,res,contextptr);
11196     return res;
11197   }
11198 
mranm(int n,int m,const gen & f,GIAC_CONTEXT)11199   matrice mranm(int n,int m,const gen & f,GIAC_CONTEXT){
11200     n=giacmax(1,n);
11201     m=giacmax(1,m);
11202     if (longlong(n)*m>LIST_SIZE_LIMIT)
11203       setstabilityerr();
11204     matrice res;
11205     res.reserve(n);
11206     for (int i=0;i<n;++i){
11207       res.push_back(vecteur(0));
11208       vranm(m,f,*res[i]._VECTptr,contextptr);
11209     }
11210     return res;
11211   }
11212 
_ranm(const gen & e,GIAC_CONTEXT)11213   gen _ranm(const gen & e,GIAC_CONTEXT){
11214     if ( e.type==_STRNG && e.subtype==-1) return  e;
11215     int n=0,m=0;
11216     switch (e.type){
11217     case _INT_:
11218       return vranm(e.val,zero,contextptr);
11219     case _DOUBLE_:
11220       return vranm(int(e._DOUBLE_val),zero,contextptr);
11221     case _VECT:
11222       if (e._VECTptr->size()==1)
11223 	return _ranm(e._VECTptr->front(),contextptr);
11224       if (e._VECTptr->size()>=2){
11225 	if (e._VECTptr->front().type==_INT_)
11226 	  n=e._VECTptr->front().val;
11227 	else {
11228 	  if (e._VECTptr->front().type==_DOUBLE_)
11229 	    n=int(e._VECTptr->front()._DOUBLE_val);
11230 	  else
11231 	    return gensizeerr(contextptr);
11232 	}
11233 	if ((*e._VECTptr)[1].type==_INT_)
11234 	  m=(*e._VECTptr)[1].val;
11235 	else {
11236 	  if ((*e._VECTptr)[1].type==_DOUBLE_)
11237 	    m=int((*e._VECTptr)[1]._DOUBLE_val);
11238 	  else
11239 	    return _randvector(e,contextptr); // try vector instead of gensizeerr(contextptr);
11240 	}
11241 	if (e._VECTptr->size()==3)
11242 	  return gen(mranm(n,m,e._VECTptr->back(),contextptr),_MATRIX__VECT);
11243 	if (e._VECTptr->size()==4){
11244 	  gen loi=(*e._VECTptr)[2];
11245 	  if (loi.type==_INT_ && e._VECTptr->back().type==_INT_){
11246 	    // random integer vector in interval
11247 	    int a=loi.val,b=e._VECTptr->back().val;
11248 	    matrice M(n);
11249 	    for (int j=0;j<n;++j){
11250 	      gen res=vecteur(m);
11251 	      for (int k=0;k<m;++k){
11252 		(*res._VECTptr)[k]=(a+int((b-a+1)*(giac_rand(contextptr)/(rand_max2+1.0))));
11253 	      }
11254 	      M[j]=res;
11255 	    }
11256 	    return gen(M,_MATRIX__VECT);
11257 	  }
11258 	  if (loi.type==_FUNC){
11259 	    if (loi==at_multinomial)
11260 	      loi=symbolic(at_multinomial,e._VECTptr->back());
11261 	    else
11262 	      loi=loi(e._VECTptr->back(),contextptr);
11263 	  }
11264 	  else
11265 	    loi=symb_of(loi,e._VECTptr->back());
11266 	  return gen(mranm(n,m,loi,contextptr),_MATRIX__VECT);
11267 	}
11268 	if (e._VECTptr->size()>4){
11269 	  gen loi=(*e._VECTptr)[2];
11270 	  if (loi.type==_FUNC){
11271 	    if (loi==at_multinomial)
11272 	      loi=symbolic(at_multinomial,gen(vecteur(e._VECTptr->begin()+3,e._VECTptr->end()),_SEQ__VECT));
11273 	    else
11274 	      loi=loi(gen(vecteur(e._VECTptr->begin()+3,e._VECTptr->end()),_SEQ__VECT),contextptr);
11275 	  }
11276 	  else
11277 	    loi=symb_of(loi,gen(vecteur(e._VECTptr->begin()+3,e._VECTptr->end()),_SEQ__VECT));
11278 	  return gen(mranm(n,m,loi,contextptr),_MATRIX__VECT);
11279 	}
11280 	return gen(mranm(n,m,0,contextptr),_MATRIX__VECT);
11281       }
11282     default:
11283       return gensizeerr(contextptr);
11284     }
11285     return undef;
11286   }
11287   static const char _ranm_s []="ranm";
11288   static define_unary_function_eval (__ranm,&_ranm,_ranm_s);
11289   define_unary_function_ptr5( at_ranm ,alias_at_ranm,&__ranm,0,true);
11290 
_randvector(const gen & e,GIAC_CONTEXT)11291   gen _randvector(const gen & e,GIAC_CONTEXT){
11292     if ( e.type==_STRNG && e.subtype==-1) return  e;
11293     int n=0;
11294     switch (e.type){
11295     case _INT_:
11296       return vranm(e.val,zero,contextptr);
11297     case _DOUBLE_:
11298       return vranm(int(e._DOUBLE_val),zero,contextptr);
11299     case _VECT:
11300       if (e._VECTptr->size()==1)
11301 	return _randvector(e._VECTptr->front(),contextptr);
11302       if (e._VECTptr->size()>=2){
11303 	if (e._VECTptr->front().type==_INT_)
11304 	  n=e._VECTptr->front().val;
11305 	else {
11306 	  if (e._VECTptr->front().type==_DOUBLE_)
11307 	    n=int(e._VECTptr->front()._DOUBLE_val);
11308 	  else
11309 	    return gensizeerr(contextptr);
11310 	}
11311 	gen loi=(*e._VECTptr)[1];
11312 	if (loi==at_uniform)
11313 	  loi=at_uniformd;
11314 	gen res(vecteur(0));
11315 	if (e._VECTptr->size()==3){
11316 	  if (loi.type==_INT_ && e._VECTptr->back().type==_INT_){
11317 	    // random integer vector in interval
11318 	    int a=loi.val,b=e._VECTptr->back().val;
11319 	    res._VECTptr->reserve(n);
11320 	    for (int j=0;j<n;++j){
11321 	      res._VECTptr->push_back(a+int((b-a+1)*(giac_rand(contextptr)/(rand_max2+1.0))));
11322 	    }
11323 	    return res;
11324 	  }
11325 	  if (loi.type==_FUNC){
11326 	    if (loi==at_multinomial)
11327 	      loi=symbolic(at_multinomial,e._VECTptr->back());
11328 	    else
11329 	      loi=loi(e._VECTptr->back(),contextptr);
11330 	  }
11331 	  else
11332 	    loi=symb_of(loi,e._VECTptr->back());
11333 	}
11334 	if (e._VECTptr->size()>3){
11335 	  if (loi.type==_FUNC){
11336 	    if (loi==at_multinomial)
11337 	      loi=symbolic(at_multinomial,gen(vecteur(e._VECTptr->begin()+2,e._VECTptr->end()),_SEQ__VECT));
11338 	    else
11339 	      loi=loi(gen(vecteur(e._VECTptr->begin()+2,e._VECTptr->end()),_SEQ__VECT),contextptr);
11340 	  }
11341 	  else
11342 	    loi=symb_of(loi,gen(vecteur(e._VECTptr->begin()+2,e._VECTptr->end()),_SEQ__VECT));
11343 	}
11344 	vranm(n,loi,*res._VECTptr,contextptr);
11345 	return res;
11346       }
11347     default:
11348       return gensizeerr(contextptr);
11349     }
11350     return undef;
11351   }
11352   static const char _randvector_s []="randvector";
11353   static define_unary_function_eval (__randvector,&_randvector,_randvector_s);
11354   define_unary_function_ptr5( at_randvector ,alias_at_randvector,&__randvector,0,true);
11355 
11356   static const char _ranv_s []="ranv";
11357   static define_unary_function_eval (__ranv,&_randvector,_ranv_s);
11358   define_unary_function_ptr5( at_ranv ,alias_at_ranv,&__ranv,0,true);
11359 
11360 #ifdef HAVE_LIBLAPACK
matrix2zlapack(const std_matrix<gen> & m,doublef2c_complex * A,GIAC_CONTEXT)11361   bool matrix2zlapack(const std_matrix<gen> & m,doublef2c_complex * A,GIAC_CONTEXT){
11362     std_matrix<gen>::const_iterator it=m.begin(),itend=m.end();
11363     gen g;
11364     int rows=itend-it;
11365     for (int i = 0; it!=itend; ++i,++it){
11366       const_iterateur jt=it->begin(),jtend=it->end();
11367       for (int j = 0; jt!=jtend;++j, ++jt){
11368 	g=evalf_double(*jt,1,contextptr);
11369 	if (g.type==_DOUBLE_){
11370 	  A[i + j * rows].r=g._DOUBLE_val;
11371 	  A[i + j * rows].i=0;
11372 	  continue;
11373 	}
11374 	if (g.type==_CPLX && g._CPLXptr->type==_DOUBLE_ && (*g._CPLXptr+1).type==_DOUBLE_){
11375 	  A[i + j * rows].r = g._CPLXptr->_DOUBLE_val;
11376 	  A[i + j * rows].i = (g._CPLXptr+1)->_DOUBLE_val;
11377 	}
11378 	else
11379 	  return false;
11380       }
11381     }
11382     return true;
11383   }
11384 
matrice2zlapack(const matrice & m,doublef2c_complex * A,GIAC_CONTEXT)11385   bool matrice2zlapack(const matrice & m,doublef2c_complex * A,GIAC_CONTEXT){
11386     const_iterateur it=m.begin(),itend=m.end();
11387     gen g;
11388     int rows=itend-it;
11389     for (int i = 0; it!=itend; ++i,++it){
11390       if (it->type!=_VECT)
11391 	return false;
11392       const_iterateur jt=it->_VECTptr->begin(),jtend=it->_VECTptr->end();
11393       for (int j = 0; jt!=jtend;++j, ++jt){
11394 	g=evalf_double(*jt,1,contextptr);
11395 	if (g.type==_DOUBLE_){
11396 	  A[i + j * rows].r=g._DOUBLE_val;
11397 	  A[i + j * rows].i=0;
11398 	  continue;
11399 	}
11400 	if (g.type==_CPLX && g._CPLXptr->type==_DOUBLE_ && (*g._CPLXptr+1).type==_DOUBLE_){
11401 	  A[i + j * rows].r = g._CPLXptr->_DOUBLE_val;
11402 	  A[i + j * rows].i = (g._CPLXptr+1)->_DOUBLE_val;
11403 	}
11404 	else
11405 	  return false;
11406       }
11407     }
11408     return true;
11409   }
11410 
zlapack2matrix(doublef2c_complex * A,unsigned rows,unsigned cols,std_matrix<gen> & R)11411   void zlapack2matrix(doublef2c_complex * A,unsigned rows,unsigned cols,std_matrix<gen> & R){
11412     R.resize(rows);
11413     for (unsigned i=0;i<rows;++i){
11414       vecteur r(cols);
11415       for (unsigned j=0;j<cols;++j)
11416 	r[j] = gen(A[i + j * rows].r,A[i + j * rows].i);
11417       R[i]=r;
11418     }
11419   }
11420 
zlapack2matrice(doublef2c_complex * A,unsigned rows,unsigned cols,matrice & R)11421   void zlapack2matrice(doublef2c_complex * A,unsigned rows,unsigned cols,matrice & R){
11422     R.resize(rows);
11423     for (unsigned i=0;i<rows;++i){
11424       vecteur r(cols);
11425       for (unsigned j=0;j<cols;++j)
11426 	r[j] = gen(A[i + j * rows].r,A[i + j * rows].i);
11427       R[i]=r;
11428     }
11429   }
11430 #endif
11431 
minv(const matrice & a,matrice & res,bool convert_internal,int algorithm,GIAC_CONTEXT)11432   bool minv(const matrice & a,matrice & res,bool convert_internal,int algorithm,GIAC_CONTEXT){
11433 #ifdef HAVE_LIBLAPACK
11434     if (is_squarematrix(a) && is_fully_numeric(a) && int(a.size())>=CALL_LAPACK){
11435       integer N,LDA,INFO,LWORK;
11436       int n=a.size();
11437       LDA=n; N=n; LWORK=N*N;
11438       integer * IPIV=new integer[n];
11439       if (is_zero(im(a,contextptr))){
11440 	double * A = new double[N*N];
11441 	matrice2lapack(a,A,contextptr);
11442 	dgetrf_( &N, &N, A, &LDA, IPIV, &INFO );
11443 	if (INFO){
11444 	  delete [] IPIV;
11445 	  delete [] A;
11446 	  return false;
11447 	}
11448 	double * WORK=new double [LWORK];
11449 	/* DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) */
11450 	dgetri_(&N,A,&LDA,IPIV,WORK,&LWORK,&INFO);
11451 	delete [] IPIV; delete [] WORK;
11452 	if (INFO){
11453 	  delete [] A;
11454 	  return false;
11455 	}
11456 	lapack2matrice(A,N,N,res);
11457 	delete [] A;
11458 	return true;
11459       }
11460       doublef2c_complex * A = new doublef2c_complex[N*N];
11461       matrice2zlapack(a,A,contextptr);
11462       zgetrf_( &N, &N, A, &LDA, IPIV, &INFO );
11463       if (INFO){
11464 	delete [] IPIV;
11465 	delete [] A;
11466 	return false;
11467       }
11468       doublef2c_complex * WORK=new doublef2c_complex [LWORK];
11469       /* ZGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) */
11470       zgetri_(&N,A,&LDA,IPIV,WORK,&LWORK,&INFO);
11471       delete [] IPIV; delete [] WORK;
11472       if (INFO){
11473 	delete [] A;
11474 	return false;
11475       }
11476       zlapack2matrice(A,N,N,res);
11477       delete [] A;
11478       return true;
11479     }
11480 #endif
11481     if (debug_infolevel)
11482       CERR << CLOCK()*1e-6 << " matrix inv begin" << '\n';
11483     matrice arref = a;
11484     add_identity(arref);
11485     if (debug_infolevel)
11486       CERR << CLOCK()*1e-6 << " identity added" << '\n';
11487     int s=int(a.size());
11488     gen det;
11489     vecteur pivots;
11490     int ok=mrref(arref,res,pivots,det,0,s,0,2*s,
11491 		 /* fullreduction */2*256,0,convert_internal,algorithm,0,
11492 		 contextptr);
11493     if (!ok)
11494       return false;
11495     if (debug_infolevel)
11496       CERR << CLOCK()*1e-6 << " remove identity" << '\n';
11497     if (ok!=2 && !remove_identity(res,contextptr))
11498       return false;
11499     if (debug_infolevel)
11500       CERR << CLOCK()*1e-6 << " end matrix inv" << '\n';
11501     return true;
11502   }
11503 
minv(const matrice & a,GIAC_CONTEXT)11504   matrice minv(const matrice & a,GIAC_CONTEXT){
11505     matrice res;
11506     if (!minv(a,res,/*convert_internal */true,/* algorithm */ 1,contextptr))
11507       return vecteur(1,vecteur(1,gensizeerr(gettext("Not invertible"))));
11508     return res;
11509   }
11510 
det_minor(const matrice & a,vecteur lv,bool convert_internal,GIAC_CONTEXT)11511   gen det_minor(const matrice & a,vecteur lv,bool convert_internal,GIAC_CONTEXT){
11512     int n=int(a.size());
11513     if (n==1)
11514       return a.front()._VECTptr->front();
11515     std_matrix<gen> A;
11516     if (convert_internal){
11517       lv=alg_lvar(a);
11518       matrice2std_matrix_gen(*(e2r(a,lv,contextptr)._VECTptr),A);
11519     }
11520     else
11521       matrice2std_matrix_gen(a,A);
11522     gen deno(1);
11523     for (int i=0;i<n;++i){
11524       gen ppcm(1);
11525       for (int j=0;j<n;++j){
11526 	if (A[i][j].type==_FRAC)
11527 	  ppcm=lcm(ppcm,A[i][j]._FRACptr->den);
11528       }
11529       if (!is_one(ppcm)){
11530 	for (int j=0;j<n;++j){
11531 	  A[i][j]=A[i][j]*ppcm;
11532 	}
11533 	deno=deno*ppcm;
11534       }
11535     }
11536     index_t index(n),mineur_index(n);
11537     map< index_t, gen > tab_mineurs,old_tab;
11538     // int s=int(std::exp(lgamma(n+1)-2*lgamma(n/2+1)))+1;
11539     // init: compute 2*2 determinants lines i,j columns 1,2
11540     gen res;
11541     for (int i=0;i<n;++i){
11542       index[0]=i;
11543       for (int j=i+1;j<n;++j){
11544 	index[1]=j;
11545 	res=A[i][0]*A[j][1]-A[i][1]*A[j][0];
11546 	tab_mineurs[index]=res;
11547       }
11548     }
11549     // compute all possibles i*i det with columns 0..i using (i-1)*(i-1) det
11550     for (int i=2;i<n;++i){
11551       if (debug_infolevel>2)
11552 	CERR << "// Computing " << i+1 << "*" << i+1 << "minors " << CLOCK()*1e-6 << '\n';
11553       swap(old_tab,tab_mineurs);
11554       tab_mineurs.clear();
11555       // initialize index
11556       for (int j=0;j<=i;++j)
11557 	index[j]=j;
11558       // computation loop
11559       for (;;){
11560 	res=zero;
11561 	for (int j=0;j<=i;++j){
11562 	  // make mineur without line index[j]
11563 	  for (int k=0;k<=i;++k){
11564 	    if (k==j)
11565 	      continue;
11566 	    if (k>j)
11567 	      mineur_index[k-1]=index[k];
11568 	    else
11569 	      mineur_index[k]=index[k];
11570 	  }
11571 	  if ((i+j)%2)
11572 	    res = res-A[index[j]][i]*old_tab[mineur_index];
11573 	  else
11574 	    res = res+A[index[j]][i]*old_tab[mineur_index];
11575 	}
11576 	tab_mineurs[index]=res;
11577 	// increment index and test for breaking loop
11578 	int j=i;
11579 	for (;j>=0;--j){
11580 	  ++index[j];
11581 	  if (index[j]!=n+j-i)
11582 	    break;
11583 	}
11584 	if (j<0)
11585 	  break;
11586 	for (;j<i;++j)
11587 	  index[j+1]=index[j]+1;
11588       }
11589     }
11590     if (debug_infolevel>2)
11591       CERR << "// Computation done " << CLOCK()*1e-6 << '\n';
11592     res = res/deno;
11593     if (convert_internal)
11594       return r2sym(res,lv,contextptr);
11595     else
11596       return res;
11597   }
11598 
11599   // determinant by expanding wrt last column
det_minor(const matrice & a,bool convert_internal,GIAC_CONTEXT)11600   gen det_minor(const matrice & a,bool convert_internal,GIAC_CONTEXT){
11601     vecteur lv;
11602     return det_minor(a,lv,convert_internal,contextptr);
11603   }
11604 
_det_minor(const gen & a,GIAC_CONTEXT)11605   gen _det_minor(const gen & a,GIAC_CONTEXT){
11606     if ( a.type==_STRNG && a.subtype==-1) return  a;
11607     if (!is_squarematrix(a)){
11608       if (a.type==_VECT && a._VECTptr->size()==2 && is_squarematrix(a._VECTptr->front())){
11609 	vecteur v(1,a._VECTptr->back());
11610 	return det_minor(*a._VECTptr->front()._VECTptr,v,true,contextptr);
11611       }
11612       return symbolic(at_det_minor,a);
11613     }
11614     return det_minor(*a._VECTptr,true,contextptr);
11615   }
11616   static const char _det_minor_s []="det_minor";
11617   static define_unary_function_eval (__det_minor,(const gen_op_context)_det_minor,_det_minor_s);
11618   define_unary_function_ptr5( at_det_minor ,alias_at_det_minor,&__det_minor,0,true);
11619 
mdet(const matrice & a,GIAC_CONTEXT)11620   gen mdet(const matrice & a,GIAC_CONTEXT){
11621     if (!is_squarematrix(a))
11622       return gendimerr(contextptr);
11623     vecteur pivots;
11624     matrice res;
11625     gen determinant;
11626     int s=int(a.size());
11627     if (!mrref(a,res,pivots,determinant,0,s,0,s,
11628 	  /* fullreduction */0,0,true,1/* guess algorithm */,1/* determinant */,
11629 	       contextptr))
11630       return gendimerr(contextptr);
11631     return determinant;
11632   }
11633 
_det(const gen & a_orig,GIAC_CONTEXT)11634   gen _det(const gen & a_orig,GIAC_CONTEXT){
11635     if ( a_orig.type==_STRNG && a_orig.subtype==-1) return  a_orig;
11636     matrice a;
11637     bool convert_internal,minor_det,keep_pivot;
11638     int algorithm,last_col;
11639     if (!read_reduction_options(a_orig,a,convert_internal,algorithm,minor_det,keep_pivot,last_col))
11640       return gensizeerr(contextptr);
11641     if (keep_pivot)
11642       return gensizeerr(gettext("Option keep_pivot not applicable"));
11643     if (minor_det)
11644       return det_minor(a,convert_internal,contextptr);
11645     if (!is_squarematrix(a))
11646       *logptr(contextptr) << gettext("Warning: non-square matrix!") << '\n';
11647     vecteur pivots;
11648     matrice res;
11649     gen determinant;
11650     int s=int(a.size());
11651     if (!mrref(a,res,pivots,determinant,0,s,0,s,
11652 	  /* fullreduction */0,0,convert_internal,algorithm,1/* det */,
11653 	       contextptr))
11654       return gendimerr(contextptr);
11655     return determinant;
11656   }
11657   static const char _det_s []="det";
11658   static define_unary_function_eval (__det,&_det,_det_s);
11659   define_unary_function_ptr5( at_det ,alias_at_det,&__det,0,true);
11660 
11661   // Find minimal poly by trying with 3 random vectors
probabilistic_pmin(const matrice & m,vecteur & w,bool check,GIAC_CONTEXT)11662   bool probabilistic_pmin(const matrice & m,vecteur & w,bool check,GIAC_CONTEXT){
11663     int n=int(m.size());
11664     modpoly p;
11665     for (int i=0;i<3;++i){
11666       vecteur v(vranm(n,0,0));
11667       // /* Old algorithm
11668       matrice temp(1,v);
11669       for (int j=0;j<n;++j){
11670 	v=multmatvecteur(m,v);
11671 	temp.push_back(v);
11672       }
11673       temp=mtran(temp);
11674       temp=mker(temp,contextptr);
11675       if (temp.empty() || is_undef(temp))
11676 	return false; // setsizeerr();
11677       w=-*temp.front()._VECTptr;
11678       reverse(w.begin(),w.end());
11679       w=trim(w,0);
11680       // */
11681       /*
11682       // New algorithm using A^(2n-1)v and Pade
11683       vecteur temp(1,v[0]);
11684       for (int j=1;j<2*n;++j){
11685 	v=multmatvecteur(m,v);
11686 	temp.push_back(v[0]);
11687       }
11688       w=reverse_rsolve(temp,false);
11689       // End new algorithù
11690       */
11691       if (signed(w.size())!=n+1 && !p.empty())
11692 	w=lcm(w,p,0);
11693       p=w;
11694       if (signed(w.size())==n+1){
11695 	w=w/w.front();
11696 	return true;
11697       }
11698     }
11699     if (!check)
11700       return false;
11701     gen res=horner(w,m);
11702     return is_zero(res,contextptr);
11703   }
11704 
11705   // Reduction to Hessenberg form, see e.g. Cohen algorithm 2.2.9
11706   // (with C array indices)
11707   // integer modulo case
mhessenberg(vector<vector<int>> & H,vector<vector<int>> & P,int modulo,bool compute_P)11708   void mhessenberg(vector< vector<int> > & H,vector< vector<int> > & P,int modulo,bool compute_P){
11709     int t,u,n=int(H.size());
11710     vecteur vtemp;
11711     for (int m=0;m<n-2;++m){
11712       if (debug_infolevel>=5)
11713 	CERR << "// hessenberg reduction line " << m << '\n';
11714       // check for a non zero coeff in the column m below ligne m+1
11715       int i=m+1;
11716       for (;i<n;++i){
11717 	t=H[i][m];
11718 	if (t)
11719 	  break;
11720       }
11721       if (i==n) //not found
11722 	continue;
11723       t=invmod(t,modulo);
11724       // permutation of lines m+1 and i and columns m+1 and i
11725       if (i>m+1){
11726 	H[i].swap(H[m+1]);
11727 	if (compute_P)
11728 	  P[i].swap(P[m+1]);
11729 	for (int j=0;j<n;++j){
11730 	  swapint(H[j][i],H[j][m+1]);
11731 	  // tmp=H[j][i]; H[j][i]=H[j][m+1]; H[j][m+1]=tmp;
11732 	}
11733       }
11734       // now coeff at line m+1 column m is H[m+1][m]=t!=0
11735       // creation of zeros in column m+1, lines i=m+2 and below
11736       vector<int> & Hmp1=H[m+1];
11737       for (i=m+2;i<n;++i){
11738 	// line operation
11739 	vector<int> & Hi=H[i];
11740 	u=((longlong) t*Hi[m])%modulo;
11741 	if (!u){
11742 	  //CERR << "zero " << m << " " << i << '\n';
11743 	  continue;
11744 	}
11745 	if (debug_infolevel>3)
11746 	  CERR << "// i=" << i << " " << u <<'\n';
11747 	modlinear_combination(Hi,-u,Hmp1,modulo,m,0,false); // H[i]=H[i]-u*H[m+1]; COULD START at m
11748 	// column operation
11749 	for (int j=0;j<n;++j){
11750 	  vector<int> & Hj=H[j];
11751 #ifdef _I386_
11752 	  mod(Hj[m+1],u,Hj[i],modulo);
11753 #else
11754 	  int * ptr=&Hj[m+1];
11755 	  *ptr=(*ptr+longlong(u)*Hj[i])%modulo;
11756 #endif
11757 	}
11758 	if (compute_P)
11759 	  modlinear_combination(P[i],-u,P[m+1],modulo,0,0,false); // P[i]=P[i]-u*P[m+1];
11760       }
11761     }
11762   }
11763 
11764   // Hessenberg reduction, P is not orthogonal
11765   // P^(-1)*H*P = original
hessenberg(std_matrix<gen> & H,std_matrix<gen> & P,GIAC_CONTEXT)11766   void hessenberg(std_matrix<gen> & H,std_matrix<gen> & P,GIAC_CONTEXT){
11767     int n=int(H.size());
11768     gen t,tabs,u,tmp;
11769     vecteur vtemp;
11770     for (int m=0;m<n-2;++m){
11771       if (debug_infolevel>=5)
11772 	CERR << "// hessenberg reduction line " << m << '\n';
11773       // check for a non zero coeff in the column m below ligne m+1
11774       int i=m+1;
11775       gen pivot=0;
11776       int pivotline=0;
11777       for (;i<n;++i){
11778 	t=H[i][m];
11779 	tabs=abs(t,contextptr);
11780 	if (is_strictly_greater(tabs,pivot,contextptr)){
11781 	  pivotline=i;
11782 	  pivot=tabs;
11783 	}
11784       }
11785       if (is_zero(pivot)) //not found
11786 	continue;
11787       i=pivotline;
11788       t=H[i][m];
11789       // permutation of lines m+1 and i and columns m+1 and i
11790       /*
11791       if (i>m+1){
11792 	for (int j=0;j<n;++j){
11793 	  tmp=H[i][j];
11794 	  H[i][j]=H[m+1][j];
11795 	  H[m+1][j]=tmp;
11796 	}
11797 	for (int j=0;j<n;++j){
11798 	  tmp=H[j][i];
11799 	  H[j][i]=H[j][m+1];
11800 	  H[j][m+1]=tmp;
11801 	}
11802       }
11803       */
11804       if (i>m+1){
11805 	swap(H[i],H[m+1]);
11806 	swap(P[i],P[m+1]);
11807 	for (int j=0;j<n;++j){
11808 	  vecteur & Hj=H[j];
11809 	  swapgen(Hj[i],Hj[m+1]);
11810 	}
11811       }
11812       // now coeff at line m+1 column m is H[m+1][m]=t!=0
11813       // creation of zeros in column m+1, lines i=m+2 and below
11814       for (i=m+2;i<n;++i){
11815 	// line operation
11816 	u=rdiv(H[i][m],t,contextptr);
11817 	if (debug_infolevel>2)
11818 	  CERR << "// i=" << i << " " << u <<'\n';
11819 	linear_combination(plus_one,H[i],-u,H[m+1],plus_one,1,vtemp,1e-12,0); // H[i]=H[i]-u*H[m+1];
11820 	swap(H[i],vtemp);
11821 	linear_combination(plus_one,P[i],-u,P[m+1],plus_one,1,vtemp,1e-12,0); // H[i]=H[i]-u*H[m+1];
11822 	swap(P[i],vtemp);
11823 	// column operation
11824 	for (int j=0;j<n;++j){
11825 	  vecteur & Hj=H[j];
11826 	  tmp=Hj[m+1]+u*Hj[i];
11827 	  Hj[m+1]=tmp;
11828 	}
11829       }
11830     }
11831   }
11832 
11833   // a*A+c*C->A
11834   // c*A-a*C->C
bi_linear_combination_AC(giac_double a,vector<giac_double> & A,giac_double c,vector<giac_double> & C,int cstart=0,int cend=-1)11835   void bi_linear_combination_AC(giac_double a,vector<giac_double> & A,giac_double c,vector<giac_double> & C,int cstart=0,int cend=-1){
11836     giac_double * Aptr=&A.front()+cstart;
11837     giac_double * Cptr=&C.front()+cstart,* Cend=&C.front()+(cend<0?C.size():cend);
11838     for (;Cptr!=Cend;++Aptr,++Cptr){
11839       giac_double tmp=a*(*Aptr)+c*(*Cptr);
11840       *Cptr=c*(*Aptr)-a*(*Cptr);
11841       *Aptr=tmp;
11842     }
11843   }
11844 
11845   // a*A+c*C->C
11846   // c*A-a*C->A
bi_linear_combination_CA(giac_double a,vector<giac_double> & A,giac_double c,vector<giac_double> & C,int cstart,int cend)11847   void bi_linear_combination_CA(giac_double a,vector<giac_double> & A,giac_double c,vector<giac_double> & C,int cstart,int cend){
11848     giac_double * Aptr=&A.front()+cstart;
11849     giac_double * Cptr=&C.front()+cstart,* Cend=Cptr+(cend-cstart);
11850     Cend-=4;
11851     for (;Cptr<=Cend;){
11852       giac_double tmp;
11853       tmp=c*(*Aptr)-a*(*Cptr);
11854       *Cptr=a*(*Aptr)+c*(*Cptr);
11855       *Aptr=tmp;
11856       ++Aptr;++Cptr;
11857       // 1
11858       tmp=c*(*Aptr)-a*(*Cptr);
11859       *Cptr=a*(*Aptr)+c*(*Cptr);
11860       *Aptr=tmp;
11861       ++Aptr;++Cptr;
11862       //2
11863       tmp=c*(*Aptr)-a*(*Cptr);
11864       *Cptr=a*(*Aptr)+c*(*Cptr);
11865       *Aptr=tmp;
11866       ++Aptr;++Cptr;
11867       //3
11868       tmp=c*(*Aptr)-a*(*Cptr);
11869       *Cptr=a*(*Aptr)+c*(*Cptr);
11870       *Aptr=tmp;
11871       ++Aptr;++Cptr;
11872     }
11873     Cend+=4;
11874     for (;Cptr<Cend;){
11875       giac_double tmp=c*(*Aptr)-a*(*Cptr);
11876       *Cptr=a*(*Aptr)+c*(*Cptr);
11877       *Aptr=tmp;
11878       ++Aptr;++Cptr;
11879     }
11880   }
11881 
tri_linear_combination(giac_double c11,vector<giac_double> & x1,giac_double c12,vector<giac_double> & x2,giac_double c13,vector<giac_double> & x3,giac_double c22,giac_double c23,giac_double c33,int cstart=0,int cend=-1)11882   void tri_linear_combination(giac_double c11,vector<giac_double> & x1,giac_double c12,vector<giac_double> & x2,giac_double c13,vector<giac_double> &x3,giac_double c22,giac_double c23,giac_double c33,int cstart=0,int cend=-1){
11883     vector<giac_double>::iterator it1=x1.begin()+cstart,it2=x2.begin()+cstart,it3=x3.begin()+cstart,it3end=cend<0?x3.end():x3.begin()+cend;
11884     for (;it3!=it3end;++it1,++it2,++it3){
11885       giac_double d1=*it1,d2=*it2,d3=*it3;
11886       *it1=c11*d1+c12*d2+c13*d3;
11887       *it2=c12*d1+c22*d2+c23*d3;
11888       *it3=c13*d1+c23*d2+c33*d3;
11889     }
11890   }
11891 
11892   // First a*A+b*B->B and b*A-a*B->A
11893   // Then aprime*C+bprime*B->B and bprime*C-aprime*B->C
tri_linear_combination(giac_double a,vector<giac_double> & A,giac_double b,vector<giac_double> & B,giac_double aprime,vector<giac_double> & C,giac_double bprime,int cstart,int cend=0)11894   void tri_linear_combination(giac_double a,vector<giac_double> & A,giac_double b,vector<giac_double> & B,giac_double aprime,vector<giac_double> & C,giac_double bprime,int cstart,int cend=0){
11895     giac_double * Aptr=&A.front()+cstart, *Cptr=&C.front()+cstart;
11896     giac_double * Bptr=&B.front()+cstart,* Bend=Bptr+(cend<=0?(B.size()-cstart):cend-cstart);
11897     Bend-=8;
11898     for (;Bptr<=Bend;){ // 3 read/3 write for 1
11899       giac_double tmp1=*Aptr,tmp2=*Bptr;
11900       *Aptr=b*tmp1-a*tmp2;
11901       tmp2=a*tmp1+b*tmp2;
11902       tmp1=*Cptr;
11903       *Bptr=aprime*tmp1+bprime*tmp2;
11904       *Cptr=bprime*tmp1-aprime*tmp2;
11905       ++Aptr; ++Bptr; ++Cptr;
11906       // 1
11907       tmp1=*Aptr; tmp2=*Bptr;
11908       *Aptr=b*tmp1-a*tmp2;
11909       tmp2=a*tmp1+b*tmp2;
11910       tmp1=*Cptr;
11911       *Bptr=aprime*tmp1+bprime*tmp2;
11912       *Cptr=bprime*tmp1-aprime*tmp2;
11913       ++Aptr; ++Bptr; ++Cptr;
11914       // 2
11915       tmp1=*Aptr; tmp2=*Bptr;
11916       *Aptr=b*tmp1-a*tmp2;
11917       tmp2=a*tmp1+b*tmp2;
11918       tmp1=*Cptr;
11919       *Bptr=aprime*tmp1+bprime*tmp2;
11920       *Cptr=bprime*tmp1-aprime*tmp2;
11921       ++Aptr; ++Bptr; ++Cptr;
11922       // 3
11923       tmp1=*Aptr; tmp2=*Bptr;
11924       *Aptr=b*tmp1-a*tmp2;
11925       tmp2=a*tmp1+b*tmp2;
11926       tmp1=*Cptr;
11927       *Bptr=aprime*tmp1+bprime*tmp2;
11928       *Cptr=bprime*tmp1-aprime*tmp2;
11929       ++Aptr; ++Bptr; ++Cptr;
11930       // 4
11931       tmp1=*Aptr; tmp2=*Bptr;
11932       *Aptr=b*tmp1-a*tmp2;
11933       tmp2=a*tmp1+b*tmp2;
11934       tmp1=*Cptr;
11935       *Bptr=aprime*tmp1+bprime*tmp2;
11936       *Cptr=bprime*tmp1-aprime*tmp2;
11937       ++Aptr; ++Bptr; ++Cptr;
11938       // 5
11939       tmp1=*Aptr; tmp2=*Bptr;
11940       *Aptr=b*tmp1-a*tmp2;
11941       tmp2=a*tmp1+b*tmp2;
11942       tmp1=*Cptr;
11943       *Bptr=aprime*tmp1+bprime*tmp2;
11944       *Cptr=bprime*tmp1-aprime*tmp2;
11945       ++Aptr; ++Bptr; ++Cptr;
11946       // 6
11947       tmp1=*Aptr; tmp2=*Bptr;
11948       *Aptr=b*tmp1-a*tmp2;
11949       tmp2=a*tmp1+b*tmp2;
11950       tmp1=*Cptr;
11951       *Bptr=aprime*tmp1+bprime*tmp2;
11952       *Cptr=bprime*tmp1-aprime*tmp2;
11953       ++Aptr; ++Bptr; ++Cptr;
11954       // 7
11955       tmp1=*Aptr; tmp2=*Bptr;
11956       *Aptr=b*tmp1-a*tmp2;
11957       tmp2=a*tmp1+b*tmp2;
11958       tmp1=*Cptr;
11959       *Bptr=aprime*tmp1+bprime*tmp2;
11960       *Cptr=bprime*tmp1-aprime*tmp2;
11961       ++Aptr; ++Bptr; ++Cptr;
11962     }
11963     Bend+=8;
11964     for (;Bptr<Bend;++Cptr,++Aptr,++Bptr){
11965       giac_double tmp1=*Aptr,tmp2=*Bptr;
11966       *Aptr=b*tmp1-a*tmp2;
11967       tmp2=a*tmp1+b*tmp2;
11968       tmp1=*Cptr;
11969       *Bptr=aprime*tmp1+bprime*tmp2;
11970       *Cptr=bprime*tmp1-aprime*tmp2;
11971     }
11972   }
11973 
is_identity(const matrix_double & P)11974   bool is_identity(const matrix_double & P){
11975     int r=int(P.size());
11976     int c=int(P.front().size());
11977     if (r!=c)
11978       return false;
11979     for (int i=0;i<r;++i){
11980       const vector<giac_double> v=P[i];
11981       if (v[i]!=1)
11982 	return false;
11983       int j=0;
11984       for (;j<i;++j){
11985 	if (v[j])
11986 	  return false;
11987       }
11988       for (++j;j<r;++j){
11989 	if (v[j])
11990 	  return false;
11991       }
11992     }
11993     return true;
11994   }
11995 
double_idn(matrix_double & P)11996   void double_idn(matrix_double & P){
11997     int cP=int(P.size());
11998     for (int i=0;i<cP;++i){
11999       vector<giac_double> & Pi=P[i];
12000       if (Pi.size()!=cP) Pi.resize(cP);
12001       vector<giac_double>::iterator it=Pi.begin(),itend=Pi.end();
12002       for (;it!=itend;++it)
12003 	*it=0;
12004       Pi[i]=1;
12005     }
12006   }
12007 
qr_givens_p(matrix_double & P,int Pstart,int Pend,int cstart,int n,int lastcol,const vector<giac_double> & coeffs)12008   void qr_givens_p(matrix_double & P,int Pstart,int Pend,int cstart,int n,int lastcol,const vector<giac_double> & coeffs){
12009     int pos=int(coeffs.size());
12010     // m-cstart must be < Pend, otherwise nothing to do
12011     for (int m=lastcol-1;m>=cstart;--m){
12012       for (;m>=Pend+cstart;--m){
12013 	pos -= 2*(n-1-(m-cstart));
12014       }
12015       for (int i=n-1;i>m-cstart;--i){
12016 	// line operation
12017 	--pos;
12018 	double un=-coeffs[pos];
12019 	--pos;
12020 	double tn=coeffs[pos];
12021 	if (un==0)
12022 	  continue;
12023 	if (i>m-cstart+1){
12024 	  double U=-coeffs[pos-1];
12025 	  double T=coeffs[pos-2];
12026 	  if (U!=0){
12027 	    tri_linear_combination(un,P[i],tn,P[m-cstart],U,P[i-1],T,giacmax(m-cstart,Pstart),Pend);
12028 	    --i;
12029 	    pos-=2;
12030 	    continue;
12031 	  }
12032 	}
12033 	bi_linear_combination_CA(un,P[i],tn,P[m-cstart],giacmax(m-cstart,Pstart),Pend); // givens_linear_combination(un,P[i],tn,P[m],m);
12034       }
12035     } // end for m
12036   }
12037 
12038   struct thread_givens_p_t {
12039     matrix_double *Pptr;
12040     int Pstart,Pend,cstart,n,lastcol;
12041     const vector<giac_double> * coeffsptr;
12042   };
12043 
do_thread_qr_givens_p(void * ptr_)12044   void * do_thread_qr_givens_p(void * ptr_){
12045     thread_givens_p_t * ptr=(thread_givens_p_t *)ptr_;
12046     qr_givens_p(*ptr->Pptr,ptr->Pstart,ptr->Pend,ptr->cstart,ptr->n,ptr->lastcol,*ptr->coeffsptr);
12047     return ptr;
12048   }
12049 
12050 #ifdef FXCG // FIXME chk largest in x/y to avoid overflow
hypot(double x,double y)12051   double hypot(double x,double y){
12052     return std::sqrt(x*x+y*y);
12053   }
12054 #endif
12055   // QR reduction, Q=P is orthogonal and should be initialized to identity
12056   // P*H=original if tranpose is false, H=P*original otherwise, Givens method
12057   // H[rstart..n+rstart-1] n rows, c cols -> Q=nxn matrix and R n rows, c cols
qr_givens(matrix_double & H,int rstart,matrix_double & P,bool computeP,bool Pidn,bool transpose,int cstart=0,int cend=0,bool recurse=true)12058   void qr_givens(matrix_double & H,int rstart,matrix_double & P,bool computeP,bool Pidn,bool transpose,int cstart=0,int cend=0,bool recurse=true){
12059     int n=int(H.size())-rstart,c=int(H.front().size()),cP=int(P.front().size());
12060     if (cstart>=c) return;
12061     if (cend<=0) cend=c;
12062 #ifndef GIAC_HAS_STO_38
12063     if (recurse && n>=c && cend-cstart>200){
12064       // if cstart, cend !=0, block-recursive version
12065       // H n rows, c1+c2 cols, n>=c1+c2, H=[A1|A2]=Q*[[R11,R12],[0,R22]]
12066       // A1 and A2 have n rows and c1, c2 columns
12067       // first step A1=Q1*[[R11],[0]] recursive call,
12068       // R11 c1 rows, c1 cols, R12 c1 rows, n-c1 cols, R22 c2 rows, n-c1 cols
12069       // tran(Q1)*A2=[[R12],[A22]]
12070       // A22=Q2*R22
12071       // [A1|A2]=Q1*[[R11,R12],[0,A22]]=Q1*[[Id,0],[0,Q2]]*[[R11,R12],[0,R22]]
12072       // tran(Q)=[[Id,0],[0,tran(Q2)]]*tran(Q1)
12073       // If tran(Q1)=[[Q11],[Q12]] then tran(Q)=[[Q11],[tran(Q2)*Q12]]
12074       // Q12 has n-c1 rows, Q2 has n-c2 rows
12075       int c1=(cend-cstart)/2,c2=cend-cstart-c1;
12076       qr_givens(H,rstart,P,true,true,false,cstart,cstart+c1,/* recurse*/ false); // P is Q1
12077       transpose_double(P); // P is tran(Q1)
12078       // R11 is in place in H, R21=0 also
12079       // temporary storage to compute tran(Q1)*A2
12080       // tranA2 c2 rows, n cols
12081       matrix_double tranA2; tranA2.reserve(giacmax(c2,n-c1));
12082       transpose_double(H,rstart,rstart+n,cstart+c1,cend,tranA2);
12083       matrix_double R(n,vector<giac_double>(n-c1));
12084       mmult_double(P,tranA2,R); // R n rows, c2 cols, n-c1 cols reserved for later use as tranQ12
12085 #if 0
12086       // QR on A22
12087       matrix_double A22(R.begin()+c1,R.end()); // A22 n-c1 rows, c2 cols
12088       matrix_double Q2(P.begin()+c1,P.end());
12089       qr_givens(A22,0,Q2,computeP,false,true,0,0,false);
12090       // work on columns c1 to cend of H
12091       for (int i=0;i<c1;++i){
12092 	std::copy(R[i].begin(),R[i].end(),H[i].begin()+c1);
12093       }
12094       for (int i=0;i<n-c1;++i){
12095 	std::copy(A22[i].begin(),A22[i].end(),H[i+c1].begin()+c1);
12096       }
12097       for (int i=0;i<n-c1;++i)
12098 	swap(Q2[i],P[i+c1]);
12099 #else
12100       // QR on A22 stored in rows c1..n-1 of R
12101       // matrix_double Q2(n-c1,vector<giac_double>(n-c1));
12102       matrix_double & Q2 =tranA2; Q2.resize(n-c1);
12103       double_idn(Q2);
12104       qr_givens(R,c1,Q2,computeP,true,false,0,0,/* recurse */true);
12105       for (int i=0;i<n;++i){
12106 	std::copy(R[i].begin(),R[i].end(),H[rstart+i].begin()+c1);
12107       }
12108       // P is tran(Q1), Q12
12109       transpose_double(Q2);
12110       matrix_double tmp;
12111       transpose_double(P,c1,n,0,0,R); // R as tranQ12: n rows, n-c1 cols
12112       // tran(Q2)*Q12
12113       mmult_double(Q2,R,tmp); // tmp n-c1 rows, n cols
12114       for (int i=0;i<n-c1;++i){
12115 	swap(tmp[i],P[i+c1]);
12116       }
12117       if (!transpose)
12118 	transpose_double(P);
12119 #endif
12120       return;
12121     }
12122 #endif // GIAC_HAS_STO_38
12123     int lastcol=std::min(n,cend);
12124     double t,tn,u,un,norme;
12125     vector<double> coeffs; coeffs.reserve(lastcol*(2*n-lastcol));
12126     if (debug_infolevel)
12127       CERR << CLOCK()*1e-6 << " givens start" << '\n';
12128     for (int m=cstart;m<lastcol;++m){
12129       if (debug_infolevel>=5)
12130 	CERR << "// Givens reduction H line " << m << '\n';
12131       int i;
12132       // creation of zeros in lines i=m+1 and below
12133       for (i=m-cstart+1;i<n;++i){
12134 	// line operation
12135 	t=H[m-cstart+rstart][m];
12136 	u=H[i+rstart][m];
12137 	if (u==0){
12138 	  coeffs.push_back(t);
12139 	  coeffs.push_back(u);
12140 	  continue;
12141 	}
12142 	norme=hypot(u,t);
12143 	un=u/norme; tn=t/norme;
12144 	coeffs.push_back(tn);
12145 	coeffs.push_back(un);
12146 	if (debug_infolevel>=6)
12147 	  CERR << "// i=" << i << " " << u <<'\n';
12148 	if (i+1<n){
12149 	  double T=un*u+tn*t, U=H[i+rstart+1][m];
12150 	  if (U!=0){
12151 	    norme=hypot(U,T);
12152 	    U/=norme; T/=norme;
12153 	    coeffs.push_back(T);
12154 	    coeffs.push_back(U);
12155 	    tri_linear_combination(un,H[i+rstart],tn,H[m-cstart+rstart],U,H[i+rstart+1],T,m,cend);
12156 	    ++i;
12157 	    continue;
12158 	  }
12159 	}
12160 	// H[m]=un*H[i]+tn*H[m] and H[i]=tn*H[i]-un*H[m];
12161 	bi_linear_combination_CA(un,H[i+rstart],tn,H[m-cstart+rstart],m,cend); // givens_linear_combination(un,H[i],tn,H[m],m);
12162       }
12163     }
12164     if (!computeP)
12165       return;
12166     if (debug_infolevel)
12167       CERR << CLOCK()*1e-6 << " givens compute P" << '\n';
12168     if (Pidn){
12169       // assumes P=idn at begin, transpose the product, reverse order
12170       bool done=false;
12171 #ifdef HAVE_LIBPTHREAD
12172       int nthreads=threads_allowed?threads:1;
12173       if (nthreads>1){
12174 	pthread_t tab[nthreads];
12175 	thread_givens_p_t multdparam[nthreads];
12176 	for (int j=0;j<nthreads;++j){
12177 	  thread_givens_p_t tmp={&P,0,0,cstart,n,lastcol,&coeffs};
12178 	  multdparam[j]=tmp;
12179 	}
12180 	int slicesize=cP/nthreads+1;
12181 	int Pstart=0,Pend=0;
12182 	for (int j=0;j<nthreads;++j){
12183 	  Pstart=Pend;
12184 	  Pend = Pstart+slicesize;
12185 	  if (Pend>=cP)
12186 	    Pend=cP;
12187 	  multdparam[j].Pstart=Pstart;
12188 	  multdparam[j].Pend=Pend;
12189 	  bool res=true;
12190 	  if (j<nthreads-1)
12191 	    res=pthread_create(&tab[j],(pthread_attr_t *) NULL,do_thread_qr_givens_p,(void *) &multdparam[j]);
12192 	  if (res)
12193 	    do_thread_qr_givens_p((void *)&multdparam[j]);
12194 	}
12195 	for (int j=0;j<nthreads;++j){
12196 	  void * ptr=(void *)&nthreads; // non-zero initialisation
12197 	  if (j<nthreads-1)
12198 	    pthread_join(tab[j],&ptr);
12199 	}
12200 	done=true;
12201       } // end nthreads
12202 #endif // PTHREAD
12203       if (!done){
12204 	// slicing is slower
12205 	int nslice=1; // nslice=cP/128+1;
12206 	int slicesize=cP/nslice+1;
12207 	int Pstart=0,Pend=0;
12208 	for (;Pstart<cP;Pstart=Pend){
12209 	  Pend = Pstart+slicesize;
12210 	  if (Pend>=cP)
12211 	    Pend=cP;
12212 	  qr_givens_p(P,Pstart,Pend,cstart,n,lastcol,coeffs);
12213 	} // end slice
12214       }
12215       if (transpose)
12216 	transpose_double(P);
12217     }
12218     else {
12219       int pos=0;
12220       for (int m=cstart;m<lastcol;++m){
12221 	if (debug_infolevel>=5)
12222 	  CERR << "// Givens reduction P line " << m << '\n';
12223 	int i=m;
12224 	for (i=m+1;i<n;++i){
12225 	  // line operation
12226 	  tn=coeffs[pos];
12227 	  ++pos;
12228 	  un=coeffs[pos];
12229 	  ++pos;
12230 	  if (un==0)
12231 	    continue;
12232 	  if (i+1<n){
12233 	    t=coeffs[pos];
12234 	    u=coeffs[pos+1];
12235 	    if (u!=0){
12236 	      tri_linear_combination(un,P[i],tn,P[m-cstart],u,P[i+1],t,0,cP);
12237 	      pos+=2;
12238 	      ++i;
12239 	      continue;
12240 	    }
12241 	  }
12242 	  bi_linear_combination_CA(un,P[i],tn,P[m],0,cP); // givens_linear_combination(un,P[i],tn,P[m],0);
12243 	}
12244       }
12245       if (!transpose)
12246 	transpose_double(P);
12247     }
12248     if (debug_infolevel)
12249       CERR << CLOCK()*1e-6 << " givens end" << '\n';
12250   }
12251 
12252   // IMPROVE: don't do operations with 0
qr_rq(std_matrix<gen> & H,std_matrix<gen> & P,const gen & shift,int n,int & nitershift0,GIAC_CONTEXT)12253   void qr_rq(std_matrix<gen> & H,std_matrix<gen> & P,const gen & shift,int n,int & nitershift0,GIAC_CONTEXT){
12254     gen t,tn,tc,tabs,uabs,t2,u,un,uc,tmp1,tmp2,norme;
12255     int n_orig=int(H.size());
12256     vecteur v1,v2,TN(n_orig),UN(n_orig);
12257     if (is_zero(shift)){
12258       nitershift0++;
12259     }
12260     else{
12261       for (int i=0;i<n_orig;++i){
12262 	H[i][i] -= shift;
12263       }
12264     }
12265     // H -> H-shift*identity
12266     for (int m=0;m<n-1;++m){
12267       // reduce coeff line m+1, col m
12268       t=H[m][m];
12269       // if (is_zero(t)) *logptr(contextptr) << "qr iteration: 0 on diagonal");
12270       int i=m+1;
12271       u=H[i][m];
12272       // now coeff at line m+1 column m is H[m+1][m]=t
12273       // creation of zeros in column m+1, lines i=m+2 and below
12274       // normalization of t and u such that t is real positive
12275       tabs=abs(t,contextptr);
12276       uabs=abs(u,contextptr);
12277       if (is_strictly_greater(uabs/tabs,1,contextptr))
12278 	t2=uabs/u;
12279       else
12280 	t2=tabs/t;
12281       t=t*t2;
12282       u=u*t2;
12283       // compute unitary matrix coefficients
12284       tc=conj(t,contextptr);
12285       uc=conj(u,contextptr);
12286       norme=sqrt(re(u*uc+t*tc,contextptr),contextptr);
12287       un=u/norme; tn=t/norme; uc=conj(un,contextptr);	tc=conj(tn,contextptr);
12288       // line operation
12289       // H[m]=uc*H[i]+tc*H[m] and H[i]=tn*H[i]-un*H[m];
12290       linear_combination(uc,H[i],tc,H[m],plus_one,1,v1,1e-12,0);
12291       linear_combination(tn,H[i],-un,H[m],plus_one,1,v2,1e-12,0);
12292       swap(H[m],v1);
12293       swap(H[i],v2);
12294       linear_combination(uc,P[i],tc,P[m],plus_one,1,v1,1e-12,0);
12295       linear_combination(tn,P[i],-un,P[m],plus_one,1,v2,1e-12,0);
12296       swap(P[m],v1);
12297       swap(P[i],v2);
12298       TN[m]=tn;
12299       UN[m]=un;
12300     } // end for m
12301     for (int m=0;m<n-1;++m){
12302       tn=TN[m];
12303       un=UN[m];
12304       tc=conj(tn,contextptr);
12305       uc=conj(un,contextptr);
12306       // column operation
12307       // int nmax=n_orig>m+3?m+3:n_orig;
12308       for (int j=0;j<n_orig;++j){
12309 	vecteur & Hj=H[j];
12310 	gen & Hjm=Hj[m];
12311 	gen & Hjm1=Hj[m+1];
12312 	tmp1=tn*Hjm+un*Hjm1;
12313 	tmp2=-uc*Hjm+tc*Hjm1;
12314 	Hjm=tmp1;
12315 	Hjm1=tmp2;
12316       }
12317     }
12318     if (!is_zero(shift)){
12319       for (int i=0;i<n_orig;++i){
12320 	H[i][i] += shift;
12321       }
12322     }
12323   }
12324 
re(std_matrix<gen> & H,int n,GIAC_CONTEXT)12325   void re(std_matrix<gen> & H,int n,GIAC_CONTEXT){
12326     for (int i=0;i<n;i++){
12327       for (int j=0;j<n;j++){
12328 	H[i][j]=re(H[i][j],contextptr);
12329       }
12330     }
12331   }
12332 
convert(const vecteur & v,vector<giac_double> & v1,bool crunch)12333   bool convert(const vecteur & v,vector<giac_double> & v1,bool crunch){
12334     int n=int(v.size());
12335     v1.clear();
12336     v1.reserve(n);
12337     for (int i=0;i<n;++i){
12338       if (v[i].type==_INT_){
12339 	v1.push_back(v[i].val);
12340 	continue;
12341       }
12342       if (v[i].type==_FLOAT_){
12343 	v1.push_back(get_double(v[i]._FLOAT_val));
12344 	continue;
12345       }
12346       if (v[i].type==_ZINT){
12347 	v1.push_back(mpz_get_d(*v[i]._ZINTptr));
12348 	continue;
12349       }
12350 #ifdef HAVE_LIBMPFR
12351       if (crunch && v[i].type==_REAL){
12352 	v1.push_back(mpfr_get_d(v[i]._REALptr->inf,GMP_RNDN));
12353 	continue;
12354       }
12355       if (crunch && v[i].type==_FRAC){
12356 	gen g=accurate_evalf(v[i],60);
12357 	if (g.type!=_REAL)
12358 	  return false;
12359 	v1.push_back(mpfr_get_d(g._REALptr->inf,GMP_RNDN));
12360 	continue;
12361       }
12362 #else
12363       if (crunch && v[i].type==_FRAC){
12364 	gen g=evalf_double(v[i],1,context0);
12365 	if (g.type!=_DOUBLE_)
12366 	  return false;
12367 	v1.push_back(g._DOUBLE_val);
12368 	continue;
12369       }
12370 #endif
12371       if (v[i].type!=_DOUBLE_)
12372 	return false;
12373       v1.push_back(v[i]._DOUBLE_val);
12374     }
12375     return true;
12376   }
12377 
convert(const vecteur & v,vector<complex_double> & v1,bool crunch)12378   bool convert(const vecteur & v,vector< complex_double > & v1,bool crunch){
12379     int n=int(v.size());
12380     v1.clear();
12381     v1.reserve(n);
12382     for (int i=0;i<n;++i){
12383       if (v[i].type==_INT_){
12384 	v1.push_back(double(v[i].val));
12385 	continue;
12386       }
12387       if (v[i].type==_FLOAT_){
12388 	v1.push_back(get_double(v[i]._FLOAT_val));
12389 	continue;
12390       }
12391       if (v[i].type==_CPLX){
12392 	gen r=evalf_double(*v[i]._CPLXptr,1,context0);
12393 	gen im=evalf_double(*(v[i]._CPLXptr+1),1,context0);
12394 	if (r.type!=_DOUBLE_ || im.type!=_DOUBLE_)
12395 	  return false;
12396 	v1.push_back(complex_double(r._DOUBLE_val,im._DOUBLE_val));
12397 	continue;
12398       }
12399       if (v[i].type!=_DOUBLE_)
12400 	return false;
12401       v1.push_back(v[i]._DOUBLE_val);
12402     }
12403     return true;
12404   }
12405 
std_matrix_gen2std_matrix_giac_double(const std_matrix<gen> & H,matrix_double & H1,bool crunch)12406   bool std_matrix_gen2std_matrix_giac_double(const std_matrix<gen> & H,matrix_double & H1,bool crunch){
12407     int n=int(H.size());
12408     H1.resize(n);
12409     for (int i=0;i<n;++i){
12410       if (!convert(H[i],H1[i],crunch))
12411 	return false;
12412     }
12413     return true;
12414   }
12415 
std_matrix_gen2std_matrix_complex_double(const std_matrix<gen> & H,matrix_complex_double & H1,bool crunch)12416   bool std_matrix_gen2std_matrix_complex_double(const std_matrix<gen> & H,matrix_complex_double & H1,bool crunch){
12417     int n=int(H.size());
12418     H1.resize(n);
12419     for (int i=0;i<n;++i){
12420       if (!convert(H[i],H1[i],crunch))
12421 	return false;
12422     }
12423     return true;
12424   }
12425 
convert(const vector<giac_double> & v,vecteur & v1)12426   bool convert(const vector<giac_double> & v,vecteur & v1){
12427     int n=int(v.size());
12428 #if 0
12429     v1.clear();
12430     v1.reserve(n);
12431     for (int i=0;i<n;++i){
12432       v1.push_back(double(v[i]));
12433     }
12434 #else
12435     v1.resize(n);
12436     for (int i=0;i<n;++i){
12437       v1[i]=double(v[i]);
12438     }
12439 #endif
12440     return true;
12441   }
12442 
convert(const vector<complex_double> & v,vecteur & v1)12443   bool convert(const vector<complex_double> & v,vecteur & v1){
12444     int n=int(v.size());
12445     v1.resize(n);
12446     for (int i=0;i<n;++i){
12447       v1[i]=gen(v[i].real(),v[i].imag());
12448     }
12449     return true;
12450   }
12451 
std_matrix_giac_double2std_matrix_gen(const matrix_double & H,std_matrix<gen> & H1)12452   bool std_matrix_giac_double2std_matrix_gen(const matrix_double & H,std_matrix<gen> & H1){
12453     int n=int(H.size());
12454     H1.resize(n);
12455     for (int i=0;i<n;++i){
12456       if (!convert(H[i],H1[i]))
12457 	return false;
12458     }
12459     return true;
12460   }
12461 
std_matrix_complex_double2std_matrix_gen(const matrix_complex_double & H,std_matrix<gen> & H1)12462   bool std_matrix_complex_double2std_matrix_gen(const matrix_complex_double & H,std_matrix<gen> & H1){
12463     int n=int(H.size());
12464     H1.resize(n);
12465     for (int i=0;i<n;++i){
12466       if (!convert(H[i],H1[i]))
12467 	return false;
12468     }
12469     return true;
12470   }
12471 
hessenberg_ortho(std_matrix<gen> & H,std_matrix<gen> & P,GIAC_CONTEXT)12472   void hessenberg_ortho(std_matrix<gen> & H,std_matrix<gen> & P,GIAC_CONTEXT){
12473     hessenberg_ortho(H,P,-1,-1,true,0,0.0,contextptr);
12474   }
12475 
12476   // v=(c1*v1+c2*v2), begin at cstart
linear_combination(const gen & c1,const vecteur & v1,const gen & c2,const vecteur & v2,vecteur & v,int cstart,double eps)12477   void linear_combination(const gen & c1,const vecteur & v1,const gen & c2,const vecteur & v2,vecteur & v,int cstart,double eps){
12478     eps=0;
12479     if (cstart<0)
12480       cstart=0;
12481     const_iterateur it1=v1.begin()+cstart,it1end=v1.end(),it2=v2.begin()+cstart;
12482     iterateur jt1=v.begin()+cstart;
12483 #ifdef DEBUG_SUPPORT
12484     if (it1end-it1!=v2.end()-it2)
12485       setdimerr();
12486 #endif
12487     if (it2==jt1){
12488       linear_combination(c2,v2,c1,v1,v,cstart,eps);
12489       return;
12490     }
12491     if (it1==jt1){
12492       for (;jt1!=it1end;++jt1,++it2){
12493 	*jt1=trim(c1*(*jt1)+c2*(*it2),c1,eps);
12494       }
12495       return;
12496     }
12497     if (int(v.size())==it1end-it1){
12498       jt1=v.begin();
12499       for (int i=0;i<cstart;++i,++jt1)
12500 	*jt1=0;
12501       for (;it1!=it1end;++it1,++it2,++jt1)
12502 	*jt1=trim(c1*(*it1)+c2*(*it2),c1,eps);
12503       return;
12504     }
12505     v.clear();
12506     v.reserve(it1end-it1);
12507     for (int i=0;i<cstart;++i)
12508       v.push_back(0);
12509     for (;it1!=it1end;++it1,++it2)
12510       v.push_back(trim(c1*(*it1)+c2*(*it2),c1,eps));
12511   }
12512 
12513   matrice H0;
12514 
dbg_schur(const std_matrix<gen> & H,const std_matrix<gen> & P)12515   void dbg_schur(const std_matrix<gen> & H,const std_matrix<gen> & P){
12516     matrice Hg,Pg;
12517     std_matrix_gen2matrice(H,Hg);
12518     std_matrix_gen2matrice(P,Pg);
12519     matrice res=mmult(mtran(Pg),Hg);
12520     res=mmult(res,Pg);
12521     gen t=subvecteur(res,H0);
12522     gen t1=_max(_abs(t,context0),context0);
12523     if (t1._DOUBLE_val>1e-5)
12524       CERR << "Error" << '\n';
12525   }
12526 
12527 
12528   // Hessenberg reduction, P is orthogonal and should be initialized to identity
12529   // trn(P)*H*P=original
12530   // already_zero is either <=0 or an integer such that H[i][j]==0 if i>j+already_zero
12531   // (already_zero==1 if H is hessenberg, ==3 for Francis algorithm)
hessenberg_ortho(std_matrix<gen> & H,std_matrix<gen> & P,int firstrow,int n,bool compute_P,int already_zero,double eps,GIAC_CONTEXT)12532   void hessenberg_ortho(std_matrix<gen> & H,std_matrix<gen> & P,int firstrow,int n,bool compute_P,int already_zero,double eps,GIAC_CONTEXT){
12533     double eps_save(epsilon(contextptr));
12534     epsilon(eps,contextptr);
12535     int nH=int(H.size());
12536     if (n<0 || n>nH)
12537       n=nH;
12538     if (firstrow<0 || firstrow>n)
12539       firstrow=0;
12540     gen t,tn,tc,tabs,u,un,uc,tmp1,tmp2,norme;
12541     vecteur v1(nH),v2(nH),TN(n,1),UN(n);
12542     for (int m=firstrow;m<n-2;++m){
12543       if (debug_infolevel>=5)
12544 	CERR << "// hessenberg reduction line " << m << '\n';
12545       // check for a non zero coeff in the column m below ligne m+1
12546       int i=m+1;
12547       gen pivot=0;
12548       int pivotline=0;
12549       int nend=n;
12550       if (already_zero && i+already_zero<n)
12551 	nend=i+already_zero;
12552       for (;i<nend;++i){
12553 	t=H[i][m];
12554 	tabs=abs(t,contextptr);
12555 	if (is_strictly_greater(tabs,pivot,contextptr)){
12556 	  pivotline=i;
12557 	  pivot=tabs;
12558 	}
12559       }
12560       if (is_zero(pivot,contextptr)) //not found
12561 	continue;
12562       i=pivotline;
12563       // exchange line and columns
12564       if (i>m+1){
12565 	swap(H[i],H[m+1]);
12566 	if (compute_P)
12567 	  swap(P[i],P[m+1]);
12568 	for (int j=0;j<n;++j){
12569 	  vecteur & Hj=H[j];
12570 	  swapgen(Hj[i],Hj[m+1]);
12571 	}
12572       }
12573       // now coeff at line m+1 column m is H[m+1][m]=t!=0
12574       // creation of zeros in column m+1, lines i=m+2 and below
12575       // if (firstrow==100) dbg_schur(H,P);
12576       int nprime=n;
12577       for (i=m+2;i<nend;++i){
12578 	// line operation
12579 	t=H[m+1][m];
12580 	u=H[i][m];
12581 	// CERR << t << " " << u << '\n';
12582 	uc=conj(u,contextptr);
12583 	tc=conj(t,contextptr);
12584 	norme=sqrt(u*uc+t*tc,contextptr);
12585 	un=u/norme; tn=t/norme; uc=conj(un,contextptr);	tc=conj(tn,contextptr);
12586 	if (is_zero(un,contextptr)){
12587 	  UN[i]=0;
12588 	  continue;
12589 	}
12590 	if (debug_infolevel>=3)
12591 	  CERR << "// i=" << i << " " << u <<'\n';
12592 	// H[m+1]=tc*H[m+1]+uc*H[i] and H[i]=tn*H[i]-un*H[m+1];
12593 	linear_combination(uc,H[i],tc,H[m+1],v1,0,0.0);
12594 	linear_combination(tn,H[i],-un,H[m+1],v2,0,0.0);
12595 	swap(H[m+1],v1);
12596 	swap(H[i],v2);
12597 	if (compute_P){
12598 	  linear_combination(uc,P[i],tc,P[m+1],v1,0,0.0);
12599 	  linear_combination(tn,P[i],-un,P[m+1],v2,0,0.0);
12600 	  swap(P[m+1],v1);
12601 	  swap(P[i],v2);
12602 	}
12603 	TN[i]=tn;
12604 	UN[i]=un;
12605       }
12606       for (i=m+2;i<nprime;++i){
12607 	un=UN[i];
12608 	if (is_zero(un,contextptr))
12609 	  continue;
12610 	tn=TN[i];
12611 	tc=conj(tn,contextptr);
12612 	uc=conj(un,contextptr);
12613 	// column operation
12614 	for (int j=0;j<nH;++j){
12615 	  vecteur & Hj=H[j];
12616 	  tmp1=tn*Hj[m+1]+un*Hj[i];
12617 	  tmp2=-uc*Hj[m+1]+tc*Hj[i];
12618 	  Hj[m+1]=tmp1;
12619 	  Hj[i]=tmp2;
12620 	}
12621       }
12622       // if (firstrow==100) dbg_schur(H,P);
12623     }
12624     // make 0 below subdiagonal (i<nH all matrix, i<n only relevant lines/column)
12625     for (int i=2;i<n;i++){
12626       iterateur it=H[i].begin(),itend=it+i-1; // or min(i-1,n);
12627       for (;it!=itend;++it){
12628 	if (debug_infolevel>2 && abs(*it,contextptr)>1e-10)
12629 	  CERR << "Precision " << i << " " << *it << '\n';
12630 	*it=0;
12631       }
12632     }
12633     epsilon(eps_save,contextptr);
12634   }
12635 
12636 #ifdef HAVE_LIBMPFR
tri_linear_combination(const gen & c1,const gen & x1,const gen & c2,const gen & x2,const gen & c3,const gen & x3,mpfr_t & tmp1,mpfr_t & tmp2)12637   gen tri_linear_combination(const gen & c1,const gen & x1,const gen & c2,const gen & x2,const gen & c3,const gen & x3,mpfr_t & tmp1,mpfr_t & tmp2){
12638     if (c1.type!=_REAL || x1.type!=_REAL || c2.type!=_REAL ||x2.type!=_REAL ||  c3.type!=_REAL || x3.type!=_REAL)
12639       return c1*x1+c2*x2+c3*x3;
12640     mpfr_set_prec(tmp1,mpfr_get_prec(c1._REALptr->inf));
12641     mpfr_set_prec(tmp2,mpfr_get_prec(c1._REALptr->inf));
12642     mpfr_mul(tmp1,c1._REALptr->inf,x1._REALptr->inf,GMP_RNDD);
12643     mpfr_mul(tmp2,c2._REALptr->inf,x2._REALptr->inf,GMP_RNDD);
12644     mpfr_add(tmp1,tmp1,tmp2,GMP_RNDD);
12645     mpfr_mul(tmp2,c3._REALptr->inf,x3._REALptr->inf,GMP_RNDD);
12646     mpfr_add(tmp1,tmp1,tmp2,GMP_RNDD);
12647     return real_object(tmp1);
12648   }
12649 #endif
12650 
tri_linear_combination(const gen & c1,const vecteur & x1,const gen & c2,const vecteur & x2,const gen & c3,const vecteur & x3,vecteur & y)12651   void tri_linear_combination(const gen & c1,const vecteur & x1,const gen & c2,const vecteur & x2,const gen & c3,const vecteur & x3,vecteur & y){
12652     const_iterateur it1=x1.begin(),it2=x2.begin(),it3=x3.begin(),it3end=x3.end();
12653     iterateur jt=y.begin();
12654 #ifdef HAVE_LIBMPFR // not significantly faster...
12655     if (c1.type==_REAL && c2.type==_REAL && c3.type==_REAL){
12656       mpfr_t tmp1,tmp2;
12657       mpfr_init2(tmp1,mpfr_get_prec(c1._REALptr->inf));
12658       mpfr_init2(tmp2,mpfr_get_prec(c1._REALptr->inf));
12659       for (;it3!=it3end;++jt,++it1,++it2,++it3){
12660 	if (it1->type==_REAL && it2->type==_REAL && it3->type==_REAL){
12661 	  mpfr_mul(tmp1,c1._REALptr->inf,it1->_REALptr->inf,GMP_RNDD);
12662 	  mpfr_mul(tmp2,c2._REALptr->inf,it2->_REALptr->inf,GMP_RNDD);
12663 	  mpfr_add(tmp1,tmp1,tmp2,GMP_RNDD);
12664 	  mpfr_mul(tmp2,c3._REALptr->inf,it3->_REALptr->inf,GMP_RNDD);
12665 	  mpfr_add(tmp1,tmp1,tmp2,GMP_RNDD);
12666 	  *jt=real_object(tmp1);
12667 	}
12668 	else
12669 	  *jt=c1*(*it1)+c2*(*it2)+c3*(*it3);
12670       }
12671       mpfr_clear(tmp1);
12672       mpfr_clear(tmp2);
12673       return;
12674     }
12675 #endif
12676     for (;it3!=it3end;++jt,++it1,++it2,++it3){
12677       *jt=c1*(*it1)+c2*(*it2)+c3*(*it3);
12678     }
12679   }
12680 
francis_schur_iterate(std_matrix<gen> & H,double eps,const gen & l1,int n_orig,int n1,int n2,std_matrix<gen> & P,bool compute_P,GIAC_CONTEXT)12681   void francis_schur_iterate(std_matrix<gen> & H,double eps,const gen & l1,int n_orig,int n1,int n2,std_matrix<gen> & P,bool compute_P,GIAC_CONTEXT){
12682     // compute (H-l1) on n1-th basis vector
12683     gen x=H[n1][n1]-l1,y=H[n1+1][n1];
12684     // make x real
12685     gen xr,xi,yr,yi;
12686     reim(x,xr,xi,contextptr);
12687     reim(y,yr,yi,contextptr);
12688     x = sqrt(xr*xr+xi*xi,contextptr);
12689     if (x==0) return;
12690     // gen xy = gen(xr/x,-xi/x); y=y*xy;
12691     y = gen((yr*xr+yi*xi)/x,(yi*xr-yr*xi)/x);
12692     reim(y,yr,yi,contextptr);
12693     gen xy=sqrt(x*x+yr*yr+yi*yi,contextptr);
12694     // normalize eigenvector
12695     x = x/xy; y = y/xy;
12696     // compute reflection matrix such that Q*[1,0]=[x,y]
12697     // hence column 1 is [x,y] and column2 is [conj(y),-x]
12698     // apply Q on H and P: line operations on H and P
12699     gen c11=x, c12=conj(y,contextptr),
12700       c21=y, c22=-x,tmp1,tmp2;
12701     vecteur v1(n_orig),v2(n_orig);
12702     linear_combination(c11,H[n1],c12,H[n1+1],v1,0,0.0);
12703     linear_combination(c21,H[n1],c22,H[n1+1],v2,0,0.0);
12704     swap(H[n1],v1);
12705     swap(H[n1+1],v2);
12706     if (compute_P){
12707       linear_combination(c11,P[n1],c12,P[n1+1],v1,0,0.0);
12708       linear_combination(c21,P[n1],c22,P[n1+1],v2,0,0.0);
12709       swap(P[n1],v1);
12710       swap(P[n1+1],v2);
12711     }
12712     // now columns operations on H (not on P)
12713     for (int j=0;j<n_orig;++j){
12714       vecteur & Hj=H[j];
12715       gen & Hjm1=Hj[n1];
12716       gen & Hjm2=Hj[n1+1];
12717       tmp1=Hjm1*c11+Hjm2*c21;
12718       tmp2=Hjm1*c12+Hjm2*c22;
12719       Hjm1=tmp1;
12720       Hjm2=tmp2;
12721     }
12722   }
12723 
francis_schur_iterate_real(std_matrix<gen> & H,int n_orig,int n1,int n2,std_matrix<gen> & P,bool compute_P,GIAC_CONTEXT)12724   void francis_schur_iterate_real(std_matrix<gen> & H,int n_orig,int n1,int n2,std_matrix<gen> & P,bool compute_P,GIAC_CONTEXT){
12725     vecteur v1(n_orig),v2(n_orig),v3(n_orig);
12726     gen tmp1,tmp2,tmp3;
12727     gen s,p; // s=l1+l2, p=l1*l2
12728     s=H[n2-2][n2-2]+H[n2-1][n2-1];
12729     p=H[n2-2][n2-2]*H[n2-1][n2-1]-H[n2-1][n2-2]*H[n2-2][n2-1];
12730     // compute (H-l2)(H-l1)=(H-s)*H+p on n1-th basis vector (if n1==0, on [1,0,...,0])
12731     gen ha=H[n1][n1],hb=H[n1][n1+1],
12732       hd=H[n1+1][n1],he=H[n1+1][n1+1],
12733       hh=H[n1+2][n1+1];
12734     gen x=hb*hd+ha*(ha-s)+p,y=hd*(he-s+ha),z=hd*hh;
12735     // normalize, substract [1,0,0] and normalize again
12736     gen xyz=sqrt(x*conj(x,contextptr)+y*conj(y,contextptr)+z*conj(z,contextptr),contextptr);
12737     // if x/xyz is near 1, improve precision:
12738     // x/xyz-1 = ((x/xyz)^2-1)/(x/xyz+1)=-((y/xyz)^2+(z/xyz)^2)/(x/xyz+1)
12739     x=x/xyz; y=y/xyz; z=z/xyz;
12740     if (fabs(evalf_double(re(x,contextptr)-1,1,contextptr)._DOUBLE_val)<0.5)
12741       x=-(y*y+z*z)/(x+1);
12742     else
12743       x-=1;
12744     xyz=sqrt(x*conj(x,contextptr)+y*conj(y,contextptr)+z*conj(z,contextptr),contextptr);
12745     x=x/xyz; y=y/xyz; z=z/xyz;
12746     // compute reflection matrix let n=[[x],[y],[z]] trn(n)=conj([[x,y,z]])
12747     // Q=idn(3)-2*n*trn(n);
12748     // i.e. [[ 1-2x*conj(x), -2x*conj(y),   -2x*conj(z)  ],
12749     //       [ -2*y*conj(x), 1-2*y*conj(y), -2*y*conj(z) ],
12750     //       [ -2*z*conj(x), -2*z*conj(y),  1-2*z*conj(z)]]
12751     // apply Q on H and P: line operations on H and P
12752     gen c11=1-2*x*conj(x,contextptr),c12=-2*x*conj(y,contextptr),c13=-2*x*conj(z,contextptr);
12753     gen c21=-2*y*conj(x,contextptr),c22=1-2*y*conj(y,contextptr),c23=-2*y*conj(z,contextptr);
12754     gen c31=-2*z*conj(x,contextptr),c32=-2*z*conj(y,contextptr),c33=1-2*z*conj(z,contextptr);
12755     // CERR << "[[" << c11 <<"," << c12 << "," << c13 << "],[" <<  c21 <<"," << c22 << "," << c23 << "],[" << c31 <<"," << c32 << "," << c33 << "]]" << '\n';
12756     tri_linear_combination(c11,H[n1],c12,H[n1+1],c13,H[n1+2],v1);
12757     tri_linear_combination(c21,H[n1],c22,H[n1+1],c23,H[n1+2],v2);
12758     tri_linear_combination(c31,H[n1],c32,H[n1+1],c33,H[n1+2],v3);
12759     swap(H[n1],v1);
12760     swap(H[n1+1],v2);
12761     swap(H[n1+2],v3);
12762 #ifdef HAVE_LIBMPFR
12763     mpfr_t tmpf1,tmpf2; mpfr_init(tmpf1); mpfr_init(tmpf2);
12764 #endif
12765     // now columns operations on H (not on P)
12766     for (int j=0;j<n_orig;++j){
12767       vecteur & Hj=H[j];
12768       gen & Hjm1=Hj[n1];
12769       gen & Hjm2=Hj[n1+1];
12770       gen & Hjm3=Hj[n1+2];
12771 #ifdef HAVE_LIBMPFR
12772       tmp1=tri_linear_combination(Hjm1,c11,Hjm2,c21,Hjm3,c31,tmpf1,tmpf2);
12773       tmp2=tri_linear_combination(Hjm1,c12,Hjm2,c22,Hjm3,c32,tmpf1,tmpf2);
12774       tmp3=tri_linear_combination(Hjm1,c13,Hjm2,c23,Hjm3,c33,tmpf1,tmpf2);
12775 #else
12776       tmp1=Hjm1*c11+Hjm2*c21+Hjm3*c31;
12777       tmp2=Hjm1*c12+Hjm2*c22+Hjm3*c32;
12778       tmp3=Hjm1*c13+Hjm2*c23+Hjm3*c33;
12779 #endif
12780       Hjm1=tmp1;
12781       Hjm2=tmp2;
12782       Hjm3=tmp3;
12783     }
12784 #ifdef HAVE_LIBMPFR
12785     mpfr_clear(tmpf1); mpfr_clear(tmpf2);
12786 #endif
12787     // CERR << H << '\n';
12788     if (compute_P){
12789       tri_linear_combination(c11,P[n1],c12,P[n1+1],c13,P[n1+2],v1);
12790       tri_linear_combination(c21,P[n1],c22,P[n1+1],c23,P[n1+2],v2);
12791       tri_linear_combination(c31,P[n1],c32,P[n1+1],c33,P[n1+2],v3);
12792       swap(P[n1],v1);
12793       swap(P[n1+1],v2);
12794       swap(P[n1+2],v3);
12795     }
12796   }
12797 
12798   // Francis algorithm on submatrix rows and columns n1..n2-1
12799   // Invariant: trn(P)*H*P=orig matrix
francis_schur(std_matrix<gen> & H,int n1,int n2,std_matrix<gen> & P,int maxiter,double eps,bool is_hessenberg,bool complex_schur,bool compute_P,bool no_lapack,GIAC_CONTEXT)12800   bool francis_schur(std_matrix<gen> & H,int n1,int n2,std_matrix<gen> & P,int maxiter,double eps,bool is_hessenberg,bool complex_schur,bool compute_P,bool no_lapack,GIAC_CONTEXT){
12801     vecteur eigenv;
12802     if (n1==0 && eps>1e-15 && !no_lapack && lapack_schur(H,P,compute_P,eigenv,contextptr))
12803       return true;
12804     int n_orig=int(H.size());//,nitershift0=0;
12805     if (!is_hessenberg){
12806       std_matrix_gen2matrice(H,H0);
12807       hessenberg_ortho(H,P,0,n_orig,compute_P,0,0.0,contextptr); // insure Hessenberg form (on the whole matrix)
12808     }
12809     if (n2-n1<=1)
12810       return true; // nothing to do
12811     if (n2-n1==2){ // 2x2 submatrix, we know how to diagonalize
12812       gen l1,l2;
12813       if (eigenval2(H,n2,l1,l2,contextptr) || complex_schur){
12814 	// choose l1 or l2 depending on H[n1][n1]-l1, H[n1][n1+1]
12815 	if (is_greater(abs(H[n1][n1]-l1,contextptr),abs(H[n1][n1]-l2,contextptr),contextptr))
12816 	  francis_schur_iterate(H,eps,l1,n_orig,n1,n2,P,compute_P,contextptr);
12817 	else
12818 	  francis_schur_iterate(H,eps,l2,n_orig,n1,n2,P,compute_P,contextptr);
12819       }
12820       return true;
12821     }
12822     for (int niter=0;n2-n1>2 && niter<maxiter;niter++){
12823       // make 0 below subdiagonal
12824       for (int i=2;i<n_orig;i++){
12825 	vecteur & Hi=H[i];
12826 	for (int j=0;j<i-1;j++){
12827 	  Hi[j]=0;
12828 	}
12829       }
12830       if (debug_infolevel>=2)
12831 	CERR << CLOCK()*1e-6 << " qr iteration number " << niter << " " << '\n';
12832       if (debug_infolevel>=5)
12833 	H.dbgprint();
12834       // check if one subdiagonal element is sufficiently small, if so
12835       // we can increase n1 or decrease n2 or split
12836       for (int i=n1;i<n2-1;++i){
12837 	gen ratio=abs(H[i+1][i]/H[i][i],contextptr);
12838 	ratio=evalf_double(ratio,1,contextptr);
12839 	if (ratio.type==_DOUBLE_ && fabs(ratio._DOUBLE_val)<eps){
12840 	  if (debug_infolevel>2)
12841 	    CERR << "Francis split " << n1 << " " << i+1 << " " << n2 << '\n';
12842 	  // submatrices n1..i and i+1..n2-1
12843 	  if (!francis_schur(H,n1,i+1,P,maxiter,eps,true,complex_schur,compute_P,true,contextptr))
12844 	    return false;
12845 	  return francis_schur(H,i+1,n2,P,maxiter,eps,true,complex_schur,compute_P,true,contextptr);
12846 	}
12847       }
12848       // now H is proper hessenberg (indices n1 to n2-1)
12849       // find eigenvalues l1 and l2 of last 2x2 matrix, they will be taken as shfits
12850       // FIXME for complex matrices, direct reflection with eigenvector of l1 or l2
12851       if (complex_schur){
12852 	gen l1,l2;
12853 	l1=H[n2-1][n2-1];
12854 	if (n2-n1>=2){
12855 	  // take the closest eigenvalue of the last 2*2 block
12856 	  eigenval2(H,n2,l1,l2,contextptr);
12857 	  if (is_greater(abs(l1-H[n2-1][n2-1],contextptr),abs(l2-H[n2-1][n2-1],contextptr),contextptr))
12858 	    l1=l2;
12859 	}
12860 	//  FIXME? if H[n1][n1]-l1 is almost zero and H[n1][n1+1] also -> precision problem
12861 	francis_schur_iterate(H,eps,l1,n_orig,n1,n2,P,compute_P,contextptr);
12862       }
12863       else
12864 	francis_schur_iterate_real(H,n_orig,n1,n2,P,compute_P,contextptr);
12865       if (n1==100)
12866 	dbg_schur(H,P);
12867       // CERR << H << '\n';
12868       // chase the bulge: Hessenberg reduction on 2 subdiagonals
12869       hessenberg_ortho(H,P,n1,n2,compute_P,3,0.0,contextptr); // <- improve
12870     } // end for loop on niter
12871     return false;
12872   }
12873 
12874   // trn(P)*H*P=orig matrix
hessenberg_schur(std_matrix<gen> & H,std_matrix<gen> & P,int maxiter,double eps,GIAC_CONTEXT)12875   void hessenberg_schur(std_matrix<gen> & H,std_matrix<gen> & P,int maxiter,double eps,GIAC_CONTEXT){
12876     int n_orig=int(H.size()),n=n_orig,nitershift0=0;
12877     bool real=true,is_double=true;
12878     for (int i=0;real && i<n;i++){
12879       vecteur &Hi=H[i];
12880       for (int j=0;j<n;j++){
12881 	gen Hij=Hi[j];
12882 	if (is_double){
12883 	  if (Hij.type==_DOUBLE_ || Hij.type==_FLOAT_)
12884 	    continue;
12885 	  if (Hij.type==_CPLX &&
12886 	      (Hij._CPLXptr->type==_DOUBLE_ || Hij._CPLXptr->type==_FLOAT_)
12887 	      && ((Hij._CPLXptr+1)->type==_DOUBLE_ || (Hij._CPLXptr+1)->type==_FLOAT_)
12888 	      )
12889 	    ;
12890 	  else
12891 	    is_double=false;
12892 	}
12893 	if (!is_zero(im(Hij,contextptr))){
12894 	  real=false;
12895 	  if (!is_double)
12896 	    break;
12897 	}
12898       }
12899     }
12900     if (is_double){
12901       if (real){
12902 	matrix_double H1,P1;
12903 	std_matrix_gen2std_matrix_giac_double(H,H1,true);
12904 	std_matrix_gen2std_matrix_giac_double(P,P1,true);
12905 	francis_schur(H1,0,n_orig,P1,maxiter,eps,false,true);
12906 	std_matrix_giac_double2std_matrix_gen(P1,P);
12907 	std_matrix_giac_double2std_matrix_gen(H1,H);
12908       }
12909       else {
12910 	matrix_complex_double H1,P1;
12911 	std_matrix_gen2std_matrix_complex_double(H,H1,true);
12912 	std_matrix_gen2std_matrix_complex_double(P,P1,true);
12913 	francis_schur(H1,0,n_orig,P1,maxiter,eps,false,true);
12914 	std_matrix_complex_double2std_matrix_gen(P1,P);
12915 	std_matrix_complex_double2std_matrix_gen(H1,H);
12916       }
12917       return;
12918     }
12919     else {
12920       if (francis_schur(H,0,n_orig,P,maxiter,std::sqrt(double(n_orig))*eps,false,!real,true,true,contextptr)){
12921 	return ;
12922       }
12923     }
12924     hessenberg_ortho(H,P,contextptr); // insure
12925     // make 0 below subdiagonal
12926     for (int i=2;i<n_orig;i++){
12927       for (int j=0;j<i-1;j++){
12928 	H[i][j]=0;
12929       }
12930     }
12931     gen shift=0,ratio,oldratio=0,maxi,absmaxi,tmp,abstmp;
12932     vecteur SHIFT;
12933     for (int niter=0;n>1 && niter<maxiter;niter++){
12934       if (debug_infolevel>=2)
12935 	CERR << CLOCK()*1e-6 << " qr iteration number " << niter << '\n';
12936       shift=0;
12937       gen test=abs(H[n-1][n-2],contextptr);
12938       ratio=test/abs(H[n-1][n-1],contextptr);
12939       bool Small=is_strictly_greater(0.01,ratio,contextptr);
12940       if (Small)
12941 	shift=H[n-1][n-1];
12942       else {
12943 	if (n==2 || is_strictly_greater(0.01,(ratio=abs(H[n-2][n-3]/H[n-2][n-2],contextptr)),contextptr)){
12944 	  // define shift according to the smallest eigenvalues
12945 	  // of the last 2x2 submatrix bloc
12946 	  gen a=H[n-2][n-2],b=H[n-2][n-1],c=H[n-1][n-2],d=H[n-1][n-1];
12947 	  gen delta=a*a-2*a*d+d*d+4*b*c;
12948 	  if (real && n==2 && is_strictly_positive(-delta,0))
12949 	    break;
12950 	  delta=sqrt(delta,contextptr);
12951 	  gen l1=(a+d+delta)/2,l2=(a+d-delta)/2;
12952 	  if (is_strictly_greater(abs(l1,contextptr),abs(l2,contextptr),contextptr))
12953 	    shift=l2;
12954 	  else
12955 	    shift=l1;
12956 	}
12957 	else {
12958 	  if (niter>=maxiter/4)
12959 	    shift=H[n-1][n-1]/2;
12960 	}
12961       }
12962       oldratio=ratio;
12963       qr_rq(H,P,shift,n,nitershift0,contextptr);
12964       if (real && !is_zero(im(shift,contextptr)))
12965 	SHIFT.push_back(shift);
12966       test=abs(H[n-1][n-2],contextptr);
12967       ratio=test/abs(H[n-1][n-1],contextptr);
12968       if (is_strictly_greater(gen(eps)/oldratio,1,contextptr) && is_strictly_greater(gen(eps)/ratio,1,contextptr)){
12969 	// eigenvalue has been found
12970 	niter=0;
12971 	oldratio=0;
12972 	n--;
12973 	if (real && !SHIFT.empty()){
12974 	  // int ni=SHIFT.size();
12975 	  for(int i=0;i<(int)SHIFT.size();++i)
12976 	    qr_rq(H,P,conj(SHIFT[i],contextptr),n,nitershift0,contextptr);
12977 	  for (int i=0;i<n-1;i++){
12978 	    vecteur & Pi=P[i];
12979 	    maxi=Pi.front();
12980 	    absmaxi=abs(maxi,contextptr);
12981 	    for (int j=1;j<n-1;j++){
12982 	      tmp=Pi[j];
12983 	      abstmp=abs(tmp,contextptr);
12984 	      if (abstmp>absmaxi){
12985 		absmaxi=abstmp;
12986 		maxi=tmp;
12987 	      }
12988 	    }
12989 	    tmp=absmaxi/maxi;
12990 	    multvecteur(tmp,Pi,Pi);
12991 	    multvecteur(tmp,H[i],H[i]);
12992 	    tmp=maxi/absmaxi;
12993 	    for (int j=0;j<n_orig;j++){
12994 	      gen & Hji= H[j][i];
12995 	      Hji = tmp*Hji;
12996 	    }
12997 	  }
12998 	  re(H,n-1,contextptr); re(P,n-1,contextptr);
12999 	  n--;
13000 	  SHIFT.clear();
13001 	} // end if (real)
13002       } // end eigenvalue detected
13003     } // end loop on n for 0 subdiagonal elements
13004   }
13005 
13006   // Reduction to Hessenberg form, see e.g. Cohen algorithm 2.2.9
13007   // (with C array indices)
13008   // general case
13009   // if modulo==-1 Schur reduction up to precision eps and maxiterations maxiter
13010   // if modulo<-1, using orthogonal/unitary matrices
mhessenberg(const matrice & M,matrice & h,matrice & p,int modulo,int maxiter,double eps,GIAC_CONTEXT)13011   bool mhessenberg(const matrice & M,matrice & h,matrice & p,int modulo,int maxiter,double eps,GIAC_CONTEXT){
13012     int n=int(M.size());
13013     if (!n || n!=mcols(M))
13014       return false; // setdimerr();
13015     bool modularize=!modulo && M[0][0].type==_MOD && (M[0][0]._MODptr+1)->type==_INT_;
13016     if (modularize)
13017       modulo=(M[0][0]._MODptr+1)->val;
13018     if (modulo>0){
13019       vector< vector<int> > H;
13020       if (!vecteur2vectvector_int(M,modulo,H))
13021 	return false;
13022       vector< vector<int> > P;
13023       if (!vecteur2vectvector_int(midn(n),modulo,P))
13024 	return false;
13025       mhessenberg(H,P,modulo,true);
13026       vectvector_int2vecteur(H,h);
13027       vectvector_int2vecteur(P,p);
13028       if (modularize){
13029 	h=*makemod(h,modulo)._VECTptr;
13030 	p=*makemod(p,modulo)._VECTptr;
13031       }
13032       return true;
13033     }
13034     std_matrix<gen> H,P(n,vecteur(n));
13035     for (int i=0;i<n;++i)
13036       P[i][i]=1;
13037     if (modulo<0){
13038 #ifdef HAVE_LIBMPFR
13039       matrice2std_matrix_gen(*evalf(gen(M),1,contextptr)._VECTptr,H);
13040 #else
13041       matrice2std_matrix_gen(*evalf_double(gen(M),1,contextptr)._VECTptr,H);
13042 #endif
13043     }
13044     else
13045       matrice2std_matrix_gen(M,H);
13046     if (modulo==-1)
13047       hessenberg_schur(H,P,maxiter,eps,contextptr);
13048     else {
13049       if (modulo<0)
13050 	hessenberg_ortho(H,P,contextptr);
13051       else
13052 	hessenberg(H,P,contextptr);
13053     }
13054     // store result
13055     std_matrix_gen2matrice_destroy(H,h);
13056     std_matrix_gen2matrice_destroy(P,p);
13057     return true;
13058   }
_hessenberg(const gen & g0,GIAC_CONTEXT)13059   gen _hessenberg(const gen & g0,GIAC_CONTEXT){
13060     if ( g0.type==_STRNG && g0.subtype==-1) return  g0;
13061     gen g(g0);
13062     int modulo=0;
13063     double eps=epsilon(contextptr);
13064     int maxiter=500;
13065     if (g.type==_VECT && g._VECTptr->size()>=2 && g.subtype==_SEQ__VECT){
13066       vecteur & v = *g._VECTptr;
13067       gen v1=v[1];
13068       if (v1.type==_INT_)
13069 	modulo=v1.val;
13070       else {
13071 	v1=evalf_double(v1,1,contextptr);
13072 	if (v1.type==_DOUBLE_){
13073 	  modulo=-1;
13074 	  eps=v1._DOUBLE_val;
13075 	  if (v.size()>2 && v[2].type==_INT_)
13076 	    maxiter=v[2].val;
13077 	}
13078       }
13079       g=v.front();
13080     }
13081     if (!is_squarematrix(g))
13082       return symbolic(at_hessenberg,g);
13083     matrice m(*g._VECTptr),h,p;
13084     if (!mhessenberg(m,h,p,modulo,maxiter,eps,contextptr))
13085       return gensizeerr(contextptr);
13086     if (modulo<0)
13087       return makesequence(_trn(p,contextptr),h); // p,h such that p*h*p^-1=orig
13088     else
13089       return makesequence(inv(p,contextptr),h); // p,h such that p*h*p^-1=orig
13090   }
13091   static const char _hessenberg_s []="hessenberg";
13092   static define_unary_function_eval (__hessenberg,&_hessenberg,_hessenberg_s);
13093   define_unary_function_ptr5( at_hessenberg ,alias_at_hessenberg,&__hessenberg,0,true);
13094 
trace(const vector<vector<int>> & N,int modulo)13095   int trace(const vector< vector<int> > & N,int modulo){
13096     longlong res=0;
13097     int n=int(N.size());
13098     for (int i=0;i<n;++i){
13099       res += N[i][i];
13100     }
13101     return res%modulo;
13102   }
13103 
13104   // Danilevsky algorithm
13105   // kind of row reduction to companion matrix
13106   // returns charpoly or minpoly
mod_pcar(std_matrix<gen> & N,vecteur & res,bool compute_pmin)13107   void mod_pcar(std_matrix<gen> & N,vecteur & res,bool compute_pmin){
13108     int n=int(N.size());
13109     if (n==1){
13110       res.resize(2);
13111       res[0]=1;
13112       res[1]=-N[0][0];
13113     }
13114     vecteur v(n),w(n);
13115     for (int k=0;k<n-1;++k){
13116       // search "pivot" on line k
13117       for (int j=k+1;j<n;++j){
13118 	if (!is_zero(N[k][j])){
13119 	  // swap columns and lines k+1 and j
13120 	  if (j>k+1){
13121 	    for (int i=k;i<n;++i)
13122 	      swapgen(N[i][k+1],N[i][j]);
13123 	    N[k+1].swap(N[j]);
13124 	  }
13125 	  break;
13126 	}
13127       }
13128       v=N[k];
13129       gen akk1=v[k+1];
13130       if (is_zero(akk1)){
13131 	// degenerate case, split N in two parts
13132 	vecteur part1(k+2),part2;
13133 	part1[0]=1;
13134 	for (int i=0;i<=k;++i){
13135 	  part1[i+1]=-N[k][k-i];
13136 	}
13137 	std_matrix<gen> N2(n-1-k);
13138 	for (int i=k+1;i<n;++i)
13139 	  N2[i-1-k]=vecteur(N[i].begin()+k+1,N[i].end());
13140 	mod_pcar(N2,part2,compute_pmin);
13141 	if (compute_pmin && part1==part2){
13142 	  res.swap(part1);
13143 	  return;
13144 	}
13145 	if (compute_pmin)
13146 	  res=lcm(part1,part2,0);
13147 	else
13148 	  res=operator_times(part1,part2,0);
13149 	return;
13150       }
13151       // multiply right by identity with line k+1 replaced by
13152       // -N[k]/a_{k,k+1} except on diagonal 1/a_{k,k+1}
13153       // this will replace line k by 0...010...0 (1 at column k+1)
13154       gen invakk1=inv(akk1,context0);
13155       for (int i=0;i<n;++i)
13156 	w[i]=(-invakk1*v[i]);
13157       w[k+1]=invakk1;
13158       // column operations
13159       for (int l=k;l<n;++l){
13160 	vecteur & Nl=N[l];
13161 	gen Nlk1=Nl[k+1];
13162 	for (int j=0;j<=k;++j){
13163 	  gen & Nlj=Nl[j];
13164 	  Nlj=Nlj+w[j]*Nlk1;
13165 	}
13166 	Nl[k+1]=invakk1*Nlk1;
13167 	for (int j=k+2;j<n;++j){
13168 	  gen & Nlj=Nl[j];
13169 	  Nlj=Nlj+w[j]*Nlk1;
13170 	}
13171       }
13172       // multiply left by identity with line k+1 replaced by original N[k]
13173       // line operations L_{k+1}=sum a_{k,i} L_i
13174       for (int j=0;j<n;++j){
13175 	gen coeff(0);
13176 	if (j>=1 && j<=k+1)
13177 	  coeff=v[j-1];
13178 	for (int i=k+1;i<n;++i){
13179 	  coeff += v[i]*N[i][j];
13180 	}
13181 	N[k+1][j]=coeff;
13182       }
13183     }
13184     // get charpoly
13185     res.resize(n+1);
13186     res[0]=1;
13187     for (int i=0;i<n;++i)
13188       res[1+i]=-N[n-1][n-1-i];
13189   }
13190 
13191   // Danilevsky algorithm
13192   // kind of row reduction to companion matrix
13193   // returns charpoly or minpoly
mod_pcar(vector<vector<int>> & N,int modulo,vector<int> & res,bool compute_pmin)13194   void mod_pcar(vector< vector<int> > & N,int modulo,vector<int> & res,bool compute_pmin){
13195     int n=int(N.size());
13196     if (n==1){
13197       res.resize(2);
13198       res[0]=1;
13199       res[1]=-N[0][0];
13200     }
13201     bool pseudo=false;
13202 #ifdef PSEUDO_MOD
13203     pseudo=(modulo<(1<<29)) && (2*modulo*double(modulo)*n<(1ULL<<63));
13204     int nbits=sizeinbase2(modulo);
13205     unsigned invp=((1ULL<<(2*nbits)))/modulo+1;
13206 #endif
13207     vector<int> v(n),w(n);
13208     for (int k=0;k<n-1;++k){
13209       // search "pivot" on line k
13210       for (int j=k+1;j<n;++j){
13211 	if (N[k][j]){
13212 	  // swap columns and lines k+1 and j
13213 	  if (j>k+1){
13214 	    for (int i=k;i<n;++i)
13215 	      swapint(N[i][k+1],N[i][j]);
13216 	    N[k+1].swap(N[j]);
13217 	  }
13218 	  break;
13219 	}
13220       }
13221       v=N[k];
13222       int akk1=v[k+1] % modulo;
13223       if (akk1==0){
13224 	// degenerate case, split N in two parts
13225 	vector<int> part1(k+2),part2;
13226 	part1[0]=1;
13227 	for (int i=0;i<=k;++i){
13228 	  part1[i+1]=smod(-N[k][k-i],modulo);
13229 	}
13230 	vector< vector<int> > N2(n-1-k);
13231 	for (int i=k+1;i<n;++i){
13232 	  N2[i-1-k]=vector<int>(N[i].begin()+k+1,N[i].end());
13233 	  if (pseudo){
13234 	    // if using pseudo-mod, we must reduce N2 % modulo
13235 	    // otherwise e.g. charpoly(graph("mcgee")) fails
13236 	    vector<int>::iterator it=N2[i-1-k].begin(),itend=N2[i-1-k].end();
13237 	    for (;it!=itend;++it)
13238 	      *it %= modulo;
13239 	  }
13240 	}
13241 	mod_pcar(N2,modulo,part2,compute_pmin);
13242 	if (compute_pmin && part1==part2){
13243 	  res.swap(part1);
13244 	  return;
13245 	}
13246 	if (compute_pmin){
13247 	  modpoly p1,p2,p12;
13248 	  vector_int2vecteur(part1,p1);
13249 	  vector_int2vecteur(part2,p2);
13250 	  environment env;
13251 	  env.modulo=modulo; env.moduloon=true;
13252 	  p12=lcm(p1,p2,&env);
13253 	  vecteur2vector_int(p12,modulo,res);
13254 	}
13255 	else
13256 	  mulsmall(part1.begin(),part1.end(),part2.begin(),part2.end(),modulo,res);
13257 	return;
13258       }
13259       // multiply right by identity with line k+1 replaced by
13260       // -N[k]/a_{k,k+1} except on diagonal 1/a_{k,k+1}
13261       // this will replace line k by 0...010...0 (1 at column k+1)
13262       longlong invakk1=invmod(akk1,modulo);
13263       for (int i=0;i<n;++i)
13264 	w[i]=(-invakk1*v[i])%modulo;
13265       w[k+1]=int(invakk1);
13266       if (debug_infolevel)
13267 	CERR << CLOCK()*1e-6 << " column" << k << '\n';
13268       // column operations
13269 #if 1
13270       for (int l=k;l<n;++l){
13271 	int * Nlj=&N[l].front();
13272 	int * wj=&w.front();
13273 	int * wend=wj+k;
13274 	longlong Nlk1=Nlj[k+1];
13275 #ifdef PSEUDO_MOD
13276 	if (pseudo){
13277 	  for (;wj<=wend;++wj,++Nlj){
13278 	    *Nlj=pseudo_mod(*Nlj+(*wj)*Nlk1,modulo,invp,nbits);
13279 	  }
13280 	}
13281 	else
13282 #endif
13283 	{
13284 	  for (;wj<=wend;++wj,++Nlj){
13285 	    *Nlj=(*Nlj+(*wj)*Nlk1)%modulo;
13286 	  }
13287 	}
13288 	*Nlj=(invakk1*Nlk1)%modulo;
13289 	++wj;++Nlj;
13290 	wend += (n-k);
13291 #ifdef PSEUDO_MOD
13292 	if (pseudo){
13293 	  for (;wj<wend;++wj,++Nlj){
13294 	    *Nlj=pseudo_mod(*Nlj+(*wj)*Nlk1,modulo,invp,nbits);
13295 	  }
13296 	}
13297 	else
13298 #endif
13299 	{
13300 	  for (;wj<wend;++wj,++Nlj){
13301 	    *Nlj=(*Nlj+(*wj)*Nlk1)%modulo;
13302 	  }
13303 	}
13304       }
13305 #else
13306       for (int l=k;l<n;++l){
13307 	vector<int> & Nl=N[l];
13308 	longlong Nlk1=Nl[k+1];
13309 	for (int j=0;j<=k;++j){
13310 	  int & Nlj=Nl[j];
13311 	  Nlj=(Nlj+w[j]*Nlk1)%modulo;
13312 	}
13313 	Nl[k+1]=(invakk1*Nlk1)%modulo;
13314 	for (int j=k+2;j<n;++j){
13315 	  int & Nlj=Nl[j];
13316 	  Nlj=(Nlj+w[j]*Nlk1)%modulo;
13317 	}
13318       }
13319 #endif
13320       if (debug_infolevel)
13321 	CERR << CLOCK()*1e-6 << " line" << k << '\n';
13322 #if 1
13323       // multiply left by identity with line k+1 replaced by original N[k]
13324       // line operations L_{k+1}=sum a_{k,i} L_i
13325       int j=0;
13326       for (;j<=n-4;j+=4){
13327 	longlong coeff0=0,coeff1=0,coeff2=0,coeff3=0;
13328 	if (j>=1 && j-1<=k)
13329 	  coeff0=v[j-1];
13330 	if (j<=k)
13331 	  coeff1=v[j];
13332 	if (j+1<=k)
13333 	  coeff2=v[j+1];
13334 	if (j+2<=k)
13335 	  coeff3=v[j+2];
13336 	vector<int> * Ni=&N[k+1];
13337 	int * vi=&v[k+1], * viend=vi+(n-k-1);
13338 	// NOTE: should take % for large modulo
13339 	for (;vi<viend;++vi,++Ni){
13340 	  longlong V=*vi;
13341 	  int * Nij=&(*Ni)[j];
13342 	  coeff0 += V*Nij[0];
13343 	  coeff1 += V*Nij[1];
13344 	  coeff2 += V*Nij[2];
13345 	  coeff3 += V*Nij[3];
13346 	}
13347 	N[k+1][j]=coeff0%modulo;
13348 	N[k+1][j+1]=coeff1%modulo;
13349 	N[k+1][j+2]=coeff2%modulo;
13350 	N[k+1][j+3]=coeff3%modulo;
13351       }
13352       for (;j<n;++j){
13353 	longlong coeff=0;
13354 	if (j>=1 && j<=k+1)
13355 	  coeff=v[j-1];
13356 	vector<int> * Ni=&N[k+1];
13357 	int * vi=&v[k+1], * viend=vi+(n-k-1);
13358 	for (;vi<viend;++vi,++Ni){
13359 	  coeff += longlong(*vi)*(*Ni)[j];
13360 	}
13361 	N[k+1][j]=coeff%modulo;
13362       }
13363 #else
13364       // multiply left by identity with line k+1 replaced by original N[k]
13365       // line operations L_{k+1}=sum a_{k,i} L_i
13366       for (int j=0;j<n;++j){
13367 	longlong coeff=0;
13368 	if (j>=1 && j<=k+1)
13369 	  coeff=v[j-1];
13370 	for (int i=k+1;i<n;++i){
13371 	  coeff += longlong(v[i])*N[i][j];
13372 	}
13373 	N[k+1][j]=coeff%modulo;
13374       }
13375 #endif
13376     }
13377     // get charpoly
13378     res.resize(n+1);
13379     res[0]=1;
13380     for (int i=0;i<n;++i)
13381       res[1+i]=smod(-N[n-1][n-1-i],modulo);
13382   }
13383 
mod_pcar(vector<vector<int>> & N,int modulo,bool & krylov,vector<int> & res,GIAC_CONTEXT,bool compute_pmin)13384   bool mod_pcar(vector< vector<int> > & N,int modulo,bool & krylov,vector<int> & res,GIAC_CONTEXT,bool compute_pmin){
13385     int n=int(N.size());
13386     if (krylov){ // try Krylov pmin
13387       vector< vector<int> > temp(n+1),ttemp;
13388       vector<int> & t0=temp[0];
13389       t0.reserve(n);
13390       for (int i=0;i<n;++i)
13391 	t0.push_back(std_rand()%modulo);
13392       // for very very large matrices (10^7 entries?)
13393       // it might be faster to compute
13394       // N, N^2, (N^2)^2, etc. and compute Nv, N^2(v,Nv), N^4(v,Nv,N^2v,N^3v)...
13395       for (int j=0;j<n;++j){
13396 	if (!multvectvector_int_vector_int(N,temp[j],modulo,temp[j+1]))
13397 	  return false;
13398       }
13399       if (debug_infolevel>2)
13400 	CERR << CLOCK()*1e-6 << " Charpoly mod " << modulo << " tran " << '\n';
13401       tran_vect_vector_int(temp,ttemp);
13402       vecteur pivots;
13403       longlong det;
13404       vector<int> permutation,maxrankcol;
13405       if (debug_infolevel>2)
13406 	CERR << CLOCK()*1e-6 << " Charpoly mod " << modulo << " rref " << '\n';
13407       smallmodrref(1,ttemp,pivots,permutation,maxrankcol,det,0,n,0,n+1,false/*full reduction */,0,modulo,2/* LU */,true,0,true,-1);
13408       if (debug_infolevel>2)
13409 	CERR << CLOCK()*1e-6 << " Charpoly mod " << modulo << " det=" << det << " " << '\n';
13410       // If rank==n-1 extract the min polynomial and find charpoly using the trace
13411       // if det==0 && rank<n-1 we will use Hessenberg
13412       // we could use recursive method
13413       // permute lines and columns of N with permutation
13414       // P*N*P^t =[[N11 N12]
13415       //           [N21 N22]] where N11 is rank*rank
13416       // where ttemp=K, P*K=L*U, L=[[L11,0],[L21,Id]] L11 rankxrank
13417       // find charpoly of N22-L21*L11^-1*N12
13418       int rank=det?n:(ttemp[n-2][n-2]?n-1:0);
13419       if (
13420 	  // false
13421 	  det || rank==n-1
13422 	  ){
13423 	// U*charpol=last column
13424 	for (int i=rank-1;i>=0;--i){
13425 	  // charpol[i]=LU[i,i]^(-1)*(bp[i]-sum(j>i)LU[i,j]*charpol[j])
13426 	  int res=0;
13427 	  vector<int> & li=ttemp[i];
13428 	  for (int j=i+1;j<rank;++j)
13429 	    mod(res,li[j],ttemp[j][rank],modulo);
13430 	  if (li[i]==0){ rank=0; break; }
13431 	  li[rank]=(invmod(li[i],modulo)*longlong(li[rank]-res))%modulo;
13432 	}
13433 	// the last column is the min poly
13434 	res.resize(rank+1);
13435 	for (int i=0;i<rank;++i)
13436 	  res[rank-i]=smod(-ttemp[i][rank],modulo);
13437 	res[0]=1;
13438 	if (rank==n)
13439 	  return true;
13440 	if (rank==n-1){
13441 	  if (compute_pmin)
13442 	    return true;
13443 	  vector<int> resx=res;
13444 	  resx.push_back(0);
13445 	  longlong t=trace(N,modulo)+res[1];
13446 	  // res[1]=-sum eigenvals, trace=sum eigenvals with multiplicities
13447 	  for (int i=0;i<=rank;++i)
13448 	    resx[i+1] = smod(resx[i+1]-t*res[i],modulo);
13449 	  res.swap(resx);
13450 	  // CERR << res << '\n';
13451 	  return true;
13452 	}
13453       }
13454       else {
13455 	krylov=false;
13456 	if (debug_infolevel>2)
13457 	  CERR << CLOCK()*1e-6 << " Singular, calling Hessenberg " << '\n';
13458       }
13459     }
13460 #if 1 // Danilevsky is faster than Hessenberg but slower than Krylov
13461     if (n*double(n)*modulo<double(1ULL<<63)){
13462       mod_pcar(N,modulo,res,compute_pmin);
13463       return true;
13464     }
13465 #endif
13466     if (compute_pmin)
13467       return false;
13468     mhessenberg(N,N,modulo,false); // Hessenberg reduction, don't compute P
13469     if (debug_infolevel>2)
13470       CERR << CLOCK()*1e-6 << " Hessenberg reduced" << '\n';
13471     vector<int> P0(1,1),P1;
13472     P0.reserve(n+1); P1.reserve(n+1);
13473     vector< vector<int> > P;
13474     P.reserve(n+1);
13475     P.push_back(P0);
13476     for (int m=1;m<=n;++m){
13477       longlong n=N[m-1][m-1];
13478       P1=P0;
13479       P1.push_back(0);
13480       for (int j=0;j<P0.size();++j){
13481 	P1[j+1] = (P1[j+1]-n*P0[j])%modulo;
13482       }
13483       P1.swap(P0);
13484       longlong t=1;
13485       for (int i=1;i<m;++i){
13486 	t=(t*N[m-i][m-i-1])%modulo;
13487 	longlong f=(t*N[m-i-1][m-1])%modulo;
13488 	const vector<int> & pmi=P[m-i-1];
13489 	int delta=int(P0.size()-pmi.size());
13490 	int * target=&P0[delta];
13491 	const int * ptr=&pmi[0], * ptrend=ptr+pmi.size();
13492 	for (;ptr!=ptrend;++target,++ptr){
13493 	  *target = (*target-f*(*ptr))%modulo;
13494 	}
13495 	// for (int j=0;j<pmi.size();++j) P0[j+delta]=(P0[j+delta]-f*pmi[j])%modulo;
13496       }
13497       P.push_back(P0);
13498     }
13499 #if 1
13500     // CERR << P0 << '\n';
13501     res=P0;
13502 #else
13503     modpoly p0(1,plus_one);
13504     modpoly pX(2,plus_one);
13505     vector< modpoly > p(1,p0);
13506     environment env;
13507     env.moduloon=true; env.modulo=modulo;
13508     for (int m=1;m<=n;++m){
13509       pX[1]=-N[m-1][m-1];
13510       p0=operator_times(pX,p0,&env);
13511       longlong t=1;
13512       for (int i=1;i<m;++i){
13513 	t=(t*N[m-i][m-i-1])%modulo;
13514 	p0=p0-operator_times(gen(int((t*N[m-i-1][m-1])%modulo)),p[m-i-1],&env);
13515       }
13516       p.push_back(p0);
13517     }
13518     vecteur2vector_int(p0,modulo,res);
13519 #endif
13520     // dbgtmp=p0;
13521     if (debug_infolevel>2)
13522       CERR << CLOCK()*1e-6 <<" Hessenberg charpoly " << '\n';
13523     return true;
13524   }
13525 
mod_pcar(const matrice & A,vector<vector<int>> & N,int modulo,bool & krylov,vector<int> & res,GIAC_CONTEXT,bool compute_pmin)13526   bool mod_pcar(const matrice & A,vector< vector<int> > & N,int modulo,bool & krylov,vector<int> & res,GIAC_CONTEXT,bool compute_pmin){
13527     if (debug_infolevel>2)
13528       CERR << CLOCK()*1e-6 << " Charpoly mod " << modulo << " A*v" << '\n';
13529     if (!vecteur2vectvector_int(A,modulo,N))
13530       return false;
13531     return mod_pcar(N,modulo,krylov,res,contextptr,compute_pmin);
13532   }
13533 
mpcar_int(const matrice & A,bool krylov,GIAC_CONTEXT,bool compute_pmin)13534   vecteur mpcar_int(const matrice & A,bool krylov,GIAC_CONTEXT,bool compute_pmin){
13535     int n=int(A.size());
13536     gen B=evalf_double(linfnorm(A,contextptr),0,contextptr);
13537     double Bd=B._DOUBLE_val;
13538     if (!Bd){
13539       modpoly charpol(n+1);
13540       charpol[0]=1;
13541       return charpol;
13542     }
13543     if (n>20){
13544       matrix_double H;
13545       if (matrice2std_matrix_double(A,H)){
13546 	vector<double> d;
13547 	// improve eigenvalues estimate
13548 	balance_krylov(H,d,5,1e-8);
13549 	giac_double Hd=linfnorm(H,d);
13550 	if (Hd<Bd)
13551 	  Bd=Hd;
13552       }
13553     }
13554     // max value of any coeff in the charpoly
13555     // max eigenval is <= sqrt(n)||A|| hence bound is in n (log(B)+log(n)/2)
13556     // we must add combinatorial (n k)<=2^n
13557     // or optimize comb(n,k)*(sqrt(n)||A||)^n
13558     // gives k<=n/(1+1/sqrt(n)B)
13559     double logbound=n/(1+1.0/std::sqrt(double(n))/Bd)*(std::log10(double(n))/2+std::log10(Bd))+n*std::log10(2.0),testvalue;
13560     double proba=proba_epsilon(contextptr),currentprob=1;
13561     gen currentp(init_modulo(n,logbound));
13562     gen pip(currentp);
13563     double pipd=std::log10(pip.val/2+1.0);
13564     vector<int> modpcar;
13565     vector< vector<int> > N;
13566     if (!mod_pcar(A,N,currentp.val,krylov,modpcar,contextptr,compute_pmin))
13567       return vecteur(1,gensizeerr(contextptr));
13568     modpoly charpol;
13569     vector_int2vecteur(modpcar,charpol);
13570     int initial_clock=CLOCK();
13571     int dbglevel=debug_infolevel;
13572     for (;pipd < (testvalue=logbound*charpol.size()/(n+1.0));){
13573       if (currentprob < proba &&  pipd<testvalue/1.33 && CLOCK()-initial_clock>min_proba_time*CLOCKS_PER_SEC)
13574 	break;
13575       if (n>10 && dbglevel<2 && CLOCK()-initial_clock>60*CLOCKS_PER_SEC)
13576 	dbglevel=2;
13577       if (dbglevel>1)
13578 	CERR << CLOCK()*1e-6 << " " << 100*pipd/testvalue << " % done" << (currentprob<proba?", stable.":", unstable.")<< '\n';
13579       currentp=nextprime(currentp.val+2);
13580       if (!mod_pcar(A,N,currentp.val,krylov,modpcar,contextptr,compute_pmin))
13581 	return vecteur(1,gensizeerr(contextptr));
13582       if (modpcar.size()<charpol.size())
13583 	continue;
13584       if (modpcar.size()>charpol.size()){
13585 	vector_int2vecteur(modpcar,charpol);
13586 	pip=currentp;
13587 	continue;
13588       }
13589       bool stable;
13590       int tmp;
13591       if (pip.type==_ZINT && (tmp=ichinrem_inplace(charpol,modpcar,pip,currentp.val)) ){
13592 	stable=tmp==2;
13593       } else {
13594 	modpoly newcharpol,currentcharpol;
13595 	vector_int2vecteur(modpcar,currentcharpol);
13596 	newcharpol=ichinrem(charpol,currentcharpol,pip,currentp);
13597 	stable=newcharpol==charpol;
13598 	charpol.swap(newcharpol);
13599       }
13600       if (stable)
13601 	currentprob=currentprob/currentp.val;
13602       else
13603 	currentprob=1.0;
13604       pip=pip*currentp;
13605       pipd += std::log10(double(currentp.val));
13606     }
13607     if (pipd<testvalue)
13608       *logptr(contextptr) << gettext("Probabilistic answer. Run proba_epsilon:=0 for a certified result. Error <") << proba << '\n';
13609     return charpol;
13610   } // end if (is_integer_matrix)
13611 
mpcar_hessenberg(const matrice & A,int modulo,GIAC_CONTEXT)13612   dense_POLY1 mpcar_hessenberg(const matrice & A,int modulo,GIAC_CONTEXT){
13613     int n=int(A.size());
13614     modpoly dbgtmp;
13615     bool krylov=true;
13616     if (modulo){
13617       vector<int> res; modpoly RES;
13618       vector< vector<int> > N;
13619       if (!mod_pcar(A,N,modulo,krylov,res,contextptr,false))
13620 	return vecteur(1,gensizeerr("Non integer cell in matrix"));
13621       vector_int2vecteur(res,RES);
13622       return RES;
13623     }
13624     if (is_integer_matrice(A))
13625       return mpcar_int(A,krylov,contextptr,false);
13626     matrice H,P;
13627     if (!mhessenberg(A,H,P,modulo,500,1e-10,contextptr))
13628       return vecteur(1,gensizeerr(contextptr));
13629     if (modulo)
13630       H=*makemod(H,modulo)._VECTptr;
13631     dense_POLY1 p0(1,plus_one),pX(2,plus_one);
13632     vector< dense_POLY1 > p(1,p0);
13633     for (int m=1;m<=n;++m){
13634       pX[1]=-H[m-1][m-1];
13635       p0=pX*p0;
13636       gen t(plus_one);
13637       for (int i=1;i<m;++i){
13638 	t=t*H[m-i][m-i-1];
13639 	p0=p0-t*H[m-i-1][m-1]*p[m-i-1];
13640       }
13641       p.push_back(p0);
13642     }
13643     // if (!is_zero(dbgtmp-p0)) CERR << dbgtmp-p0 << '\n';
13644     return p0;
13645   }
_pcar_hessenberg(const gen & g,GIAC_CONTEXT)13646   gen _pcar_hessenberg(const gen & g,GIAC_CONTEXT){
13647     if ( g.type==_STRNG && g.subtype==-1) return  g;
13648     if (!is_squarematrix(g)){
13649       if (g.type==_VECT && g._VECTptr->size()==2){
13650 	gen m=g._VECTptr->front(),x=g._VECTptr->back();
13651 	if (is_squarematrix(m))
13652 	  return symb_horner(mpcar_hessenberg(*m._VECTptr,0,contextptr),x);
13653       }
13654       return symbolic(at_pcar_hessenberg,g);
13655     }
13656     matrice m(*g._VECTptr);
13657     return mpcar_hessenberg(m,0,contextptr);
13658   }
13659   static const char _pcar_hessenberg_s []="pcar_hessenberg";
13660   static define_unary_function_eval (__pcar_hessenberg,&_pcar_hessenberg,_pcar_hessenberg_s);
13661   define_unary_function_ptr5( at_pcar_hessenberg ,alias_at_pcar_hessenberg,&__pcar_hessenberg,0,true);
13662 
13663 
13664   // Fadeev algorithm to compute the char poly of a matrix
13665   // B is a vector of matrices
13666   // the returned value is the vector of coeff of the char poly
13667   // see modpoly.h for polynomial operations on vecteur
mpcar(const matrice & a,vecteur & Bv,bool compute_Bv,bool convert_internal,GIAC_CONTEXT)13668   dense_POLY1 mpcar(const matrice & a,vecteur & Bv,bool compute_Bv,bool convert_internal,GIAC_CONTEXT){
13669     int n=int(a.size());
13670     gen modulo,fieldpmin;
13671 #ifndef NO_RTTI
13672     if (n && has_gf_coeff(a,modulo,fieldpmin)){
13673       gen tmp=_pcar(a,contextptr);
13674       if (tmp.type!=_VECT)
13675 	return vecteur(1,gensizeerr(contextptr));
13676       vecteur P=*tmp._VECTptr;
13677       // do Horner to compute Bv
13678       if (compute_Bv){
13679 	horner(P,a,0,Bv);
13680 	Bv[0]=midn(n);
13681       }
13682       return P;
13683     }
13684 #endif
13685     if (n && a[0]._VECTptr->front().type==_MOD){
13686       vecteur P(mpcar_hessenberg(a,0,contextptr));
13687       // do Horner to compute Bv
13688       if (compute_Bv){
13689 	horner(P,a,0,Bv);
13690 	Bv[0]=midn(n);
13691       }
13692       return P;
13693     }
13694     matrice A,Bi,Ai,I,lv;
13695     if (convert_internal){
13696       // convert a to internal form
13697       lv=alg_lvar(a);
13698       A = *(e2r(a,lv,contextptr)._VECTptr);
13699     }
13700     else
13701       A=a;
13702     midn(n,I);
13703     Bi=I; // B0=Id
13704     Bv.push_back(Bi);
13705     vecteur P;
13706     gen pk;
13707     P.push_back(1); // p0= 1
13708     for (int i=1;i<=n;++i){
13709       // for polynomial coefficients interpolate?
13710       mmult(A,Bi,Ai); // Ai = A*Bi
13711       pk = rdiv(-mtrace(Ai),i,contextptr);
13712       P.push_back(convert_internal?r2e(pk,lv,contextptr):pk);
13713       addvecteur( Ai,multvecteur(pk,I),Bi); // Bi = Ai+pk*I
13714       // COUT << i << ":" << Bi << '\n';
13715       if (i!=n)
13716 	Bv.push_back(convert_internal?r2e(Bi,lv,contextptr):Bi);
13717     }
13718     return P;
13719   }
13720 
mpcar(const matrice & a,vecteur & Bv,bool compute_Bv,GIAC_CONTEXT)13721   dense_POLY1 mpcar(const matrice & a,vecteur & Bv,bool compute_Bv,GIAC_CONTEXT){
13722     return mpcar(a,Bv,compute_Bv,false,contextptr);
13723   }
13724 
13725   gen _lagrange(const gen & g,GIAC_CONTEXT);
13726 
pcar_interp(const matrice & a,gen & g,GIAC_CONTEXT)13727   static gen pcar_interp(const matrice & a,gen & g,GIAC_CONTEXT){
13728     vecteur res;
13729     if (poly_pcar_interp(a,res,false,contextptr)){
13730       if (g.type==_VECT)
13731 	return res;
13732       return symb_horner(res,g);
13733     }
13734     int m=int(a.size());
13735     vecteur v1,v2,I(midn(m));
13736     int shift=-m/2;
13737     for (int j=0;j<=m;++j){
13738       v1.push_back(j-shift);
13739       v2.push_back(mdet(addvecteur(a,multvecteur(shift-j,I)),contextptr));
13740     }
13741     return _lagrange(makevecteur(v1,v2,g),contextptr);
13742   }
13743 
_pcar(const gen & a,GIAC_CONTEXT)13744   gen _pcar(const gen & a,GIAC_CONTEXT){
13745     if ( a.type==_STRNG && a.subtype==-1) return  a;
13746     vecteur Bv;
13747     matrice M;
13748     gen b(undef);
13749     if (!is_squarematrix(a)){
13750       if (a.type!=_VECT)
13751 	return symb_pcar(a);
13752       vecteur v=*a._VECTptr;
13753       int s=int(v.size());
13754       if (s<2 || !is_squarematrix(v.front()))
13755 	return gensizeerr(contextptr);
13756       matrice &m=*v.front()._VECTptr;
13757       if (v.back().type==_INT_ && v.back().val==_FADEEV){
13758 	vecteur res=mpcar(m,Bv,false,true,contextptr);
13759 	return s==2?res:symb_horner(res,v[1]);
13760       }
13761       if (v.back()==at_pmin && probabilistic_pmin(m,Bv,false,contextptr))
13762 	return s==2?Bv:symb_horner(Bv,v[1]);
13763       if (v.back()==at_lagrange || v.back()==at_interp)
13764 	return pcar_interp(m,s==2?vx_var:v[1],contextptr);
13765       if (v.back()==at_hessenberg || v.back()==at_pcar_hessenberg){
13766 	Bv=mpcar_hessenberg(m,0,contextptr);
13767 	return s==2?Bv:symb_horner(Bv,v[1]);
13768       }
13769       b=v[1];
13770       M=m;
13771     }
13772     else
13773       M=*a._VECTptr;
13774     // int n=M.size();
13775     // search for the best algorithm
13776     gen p=M[0][0];
13777     if (p.type==_USER){
13778       std_matrix<gen> m; vecteur w;
13779       matrice2std_matrix_gen(M,m);
13780       mod_pcar(m,w,true);
13781       if (is_undef(b))
13782 	return gen(w,_POLY1__VECT);
13783       return symb_horner(w,b);
13784     }
13785     if (p.type==_MOD && (p._MODptr+1)->type==_INT_){
13786       gen mg=unmod(M);
13787       if (mg.type==_VECT){
13788 	matrice M1=*mg._VECTptr;
13789 	vector< vector<int> > N;
13790 	int modulo=(p._MODptr+1)->val;
13791 	bool krylov=true;
13792 	vector<int> res;
13793 	if (mod_pcar(M1,N,modulo,krylov,res,contextptr,false)){
13794 	  vecteur w;
13795 	  vector_int2vecteur(res,w);
13796 	  w=*makemod(w,modulo)._VECTptr;
13797 	  if (is_undef(b))
13798 	    return gen(w,_POLY1__VECT);
13799 	  return symb_horner(w,b);
13800 	}
13801       }
13802     }
13803     if (is_integer_matrice(M)){
13804       vecteur res=mpcar_hessenberg(M,0,contextptr);
13805       if (is_undef(b))
13806 	return gen(res,_POLY1__VECT);
13807       return symb_horner(res,b);
13808     }
13809     if (is_fraction_matrice(M)){
13810       gen res=pcar_interp(M,is_undef(b)?vx_var:b,contextptr);
13811       return is_undef(b)?_e2r(res,contextptr):res;
13812     }
13813     vecteur res;
13814     if (poly_pcar_interp(M,res,false,contextptr))
13815       return res;
13816     res=mpcar(M,Bv,false,true,contextptr);
13817     if (is_undef(b))
13818       return res;
13819     return symb_horner(res,b);
13820   }
13821   static const char _pcar_s []="pcar";
13822   static define_unary_function_eval (__pcar,&_pcar,_pcar_s);
13823   define_unary_function_ptr5( at_pcar ,alias_at_pcar,&__pcar,0,true);
13824 
13825 #if 0
13826   static vecteur polymat2matpoly(const vecteur & v){
13827     if (v.empty() || v.front().type!=_VECT)
13828       return vecteur(1,gensizeerr(gettext("polymat2matpoly")));
13829     int l,c,s=v.size();
13830     mdims(*v.front()._VECTptr,l,c);
13831     vecteur mat;
13832     mat.reserve(l);
13833     for (int i=0;i<l;++i){
13834       vecteur ligne;
13835       ligne.reserve(c);
13836       for (int j=0;j<c;++j){
13837 	bool trim=true;
13838 	vecteur res;
13839 	res.reserve(s);
13840 	for (int k=0;k<s;++k){
13841 	  gen g=v[k];
13842 	  gen tmp=g[i][j];
13843 	  if (trim && is_zero(tmp,context0))
13844 	    continue;
13845 	  trim=false;
13846 	  res.push_back(tmp);
13847 	}
13848 	ligne.push_back(gen(res,_POLY__VECT));
13849       }
13850       mat.push_back(ligne);
13851     }
13852     return mat;
13853   }
13854 #endif
13855 
polymat2mat(const vecteur & v)13856   static vecteur polymat2mat(const vecteur & v){
13857     if (v.empty())
13858       return v;
13859     if (v.front().type!=_VECT)
13860       return vecteur(1,gensizeerr(gettext("polymat2mat")));
13861     int l,c,s=int(v.size());
13862     vecteur w(v);
13863     for (int i=0;i<s;++i)
13864       w[i]=mtran(*v[i]._VECTptr);
13865     mdims(*v.front()._VECTptr,l,c);
13866     vecteur mat;
13867     mat.reserve(l*s);
13868     for (int k=0;k<s;++k){
13869       gen & g=w[k];
13870       for (int i=0;i<l;++i){
13871 	mat.push_back(g[i]);
13872       }
13873     }
13874     return mat;
13875   }
13876 
13877   // dot product of a[0..a.size()-1] and b[pos..pos+a.size()-1]
generalized_dotvecteur(const vecteur & a,const vecteur & b,int pos)13878   gen generalized_dotvecteur(const vecteur & a,const vecteur & b,int pos){
13879     vecteur::const_iterator ita=a.begin(), itaend=a.end();
13880     vecteur::const_iterator itb=b.begin()+pos;
13881     gen res;
13882     for (;(ita!=itaend);++ita,++itb){
13883       res = res + (*ita)*(*itb);
13884     }
13885     return res;
13886   }
13887 
generalized_multmatvecteur(const matrice & a,const vecteur & b)13888   vecteur generalized_multmatvecteur(const matrice & a,const vecteur & b){
13889     vecteur::const_iterator ita=a.begin(), itaend=a.end();
13890     int s=int(b.size());
13891     int n=int(itaend-ita); // number of vectors stored in b=s/n
13892     vecteur res;
13893     res.reserve(s);
13894     for (int i=0;i<s;i+=n){
13895       for (ita=a.begin();ita!=itaend;++ita){
13896 	res.push_back(generalized_dotvecteur(*(ita->_VECTptr),b,i));
13897       }
13898     }
13899     return res;
13900   }
13901 
13902   // [almost] rational jordan block
rat_jordan_block(const vecteur & v,int n,bool pseudo)13903   matrice rat_jordan_block(const vecteur & v,int n,bool pseudo){
13904     if (n<1)
13905       return vecteur(1,gendimerr(gettext("rat_jordan_block")));
13906     int s=int(v.size())-1;
13907     // Size of the matrix is s*n
13908     vecteur ligne(s*n,zero);
13909     std_matrix<gen> M(s*n,ligne);
13910     for (int i=0;i<n;++i){
13911       // Fill the block-diagonal part with companion block
13912       for (int j=0;j<s;++j){
13913 	M[i*s+j][i*s+s-1]=-v[s-j];
13914 	if (j>0)
13915 	  M[i*s+j][i*s+j-1]=plus_one;
13916       }
13917       // Fill the upper diagonal with idn or a single 1
13918       if (i!=n-1){
13919 	if (pseudo)
13920 	  M[i*s][i*s+s+s-1]=1;
13921 	else {
13922 	  for (int j=0;j<s;++j){
13923 	    M[i*s+j][i*s+s+j]=1;
13924 	  }
13925 	}
13926       }
13927     }
13928     matrice res;
13929     std_matrix_gen2matrice_destroy(M,res);
13930     return res;
13931   }
13932 
_rat_jordan_block(const gen & args,GIAC_CONTEXT)13933   gen _rat_jordan_block(const gen &args,GIAC_CONTEXT){
13934     if (args.type==_STRNG && args.subtype==-1) return args;
13935     if (args.type==_VECT && args._VECTptr->size()==3){
13936       vecteur & v=*args._VECTptr;
13937       gen Px=_e2r(makevecteur(v[0],v[1]),contextptr);
13938       if (Px.type==_VECT && v[2].type==_INT_){
13939 	int n=v[2].val;
13940 	return rat_jordan_block(*Px._VECTptr,absint(n),n<0);
13941       }
13942     }
13943     return gensizeerr(contextptr);
13944   }
13945   static const char _rat_jordan_block_s []="rat_jordan_block";
13946   static define_unary_function_eval (__rat_jordan_block,&_rat_jordan_block,_rat_jordan_block_s);
13947   define_unary_function_ptr5( at_rat_jordan_block ,alias_at_rat_jordan_block,&__rat_jordan_block,0,true);
13948 
pseudo_rat_to_rat(const vecteur & v,int n)13949   matrice pseudo_rat_to_rat(const vecteur & v,int n){
13950     if (n<1)
13951       return vecteur(1,gendimerr(gettext("pseudo_rat_ro_rat")));
13952     matrice A(rat_jordan_block(v,n,true));
13953     if (is_undef(A)) return A;
13954     // lines of A are initial v
13955     vecteur q(v);
13956     int d=int(q.size())-1; // degree of the polynomial
13957     matrice res(midn(n*d));
13958     reverse(q.begin(),q.end());
13959     for (int j=1;j<n;++j){
13960       // compute Q(A) v_{j,0}
13961       vecteur QAvj0(n*d);
13962       for (int l=1;l<=d;++l){
13963 	int mmax=giacmin(l,j);
13964 	for (int m=1;m<=mmax;++m){
13965 	  QAvj0=addvecteur(QAvj0,multvecteur(q[l]*comb((unsigned long) l,(unsigned long)m),*res[(j-m)*d+(l-m)]._VECTptr));
13966 	}
13967       }
13968       // shift
13969       vecteur vj0=mergevecteur(vecteur(d),vecteur(QAvj0.begin(),QAvj0.begin()+(n-1)*d));
13970       // replace in res
13971       res[j*d]=vj0;
13972       // compute images by A, ..., A^[d-1]
13973       for (int l=1;l<d;++l){
13974 	vj0=multmatvecteur(A,vj0);
13975 	vecteur tmp(vj0);
13976 	int mmax=giacmin(l,j);
13977 	for (int m=1;m<=mmax;++m)
13978 	  tmp=subvecteur(tmp,multvecteur(comb((unsigned long) l,(unsigned long) m),*res[(j-m)*d+(l-m)]._VECTptr));
13979 	res[j*d+l]=tmp;
13980       }
13981     }
13982     return res;
13983   }
13984 
13985   // input trn(p)*d*p=original matrix, d upper triangular
13986   // output p*d*inv(p)=original matrix, d diagonal
schur_eigenvectors(matrice & p,matrice & d,double eps,GIAC_CONTEXT)13987   bool schur_eigenvectors(matrice &p,matrice & d,double eps,GIAC_CONTEXT){
13988     bool ans=true;
13989     int dim=int(p.size());
13990     matrice m(midn(dim));
13991     // columns of m are the vector of the basis of the Schur decomposition
13992     // in terms of the eigenvector
13993     for (int k=1;k<dim;++k){
13994       // compute column k of m
13995       for (int j=0;j<k;++j){
13996 	gen tmp=0;
13997 	for (int i=0;i<k;++i){
13998 	  tmp += d[i][k]*m[j][i];
13999 	}
14000 	if (!is_zero(tmp))
14001 	  tmp = tmp/(d[j][j]-d[k][k]);
14002 	(*m[j]._VECTptr)[k]=tmp;
14003       }
14004     }
14005     m=minv(m,contextptr);
14006     if (is_undef(m))
14007       return false;
14008     p=mmult(*_trn(p,contextptr)._VECTptr,m);
14009     // set d to its diagonal
14010     for (int i=0;i<dim;++i){
14011       vecteur & di= *d[i]._VECTptr;
14012       for (int j=0;j<dim;++j){
14013 	if (j==i) continue;
14014 #ifndef GIAC_HAS_STO_38
14015 	if (ans && j==i-1 && is_greater(abs(di[j]/di[j+1],contextptr),eps,contextptr)){
14016 	  *logptr(contextptr) << gettext("Low accuracy for Schur row ") << j << " " << d[i] << '\n';
14017 	  ans=false;
14018 	}
14019 #endif
14020 	di[j]=0;
14021       }
14022     }
14023     return ans;
14024   }
14025 
matrice_double2lapack(const matrix_double & H,double * A)14026   void matrice_double2lapack(const matrix_double & H,double * A){
14027     matrix_double::const_iterator it=H.begin(),itend=H.end();
14028     int rows=int(itend-it);
14029     for (int i = 0; it!=itend; ++i,++it){
14030       const vector<giac_double> & v =*it;
14031       vector<giac_double>::const_iterator jt=v.begin(),jtend=v.end();
14032       for (int j = 0; jt!=jtend;++j, ++jt){
14033 	A[i + j * rows] = *jt;
14034       }
14035     }
14036   }
14037 
lapack2matrice_double(double * A,int rows,int cols,matrix_double & R)14038   void lapack2matrice_double(double * A, int rows,int cols,matrix_double & R){
14039     R.resize(rows);
14040     for (int i=0;i<rows;++i){
14041       vector<giac_double> & r=R[i];
14042       r.resize(cols);
14043       for (int j=0;j<cols;++j)
14044 	r[j] = A[i + j * rows];
14045     }
14046   }
14047 
transpose_square_matrix(matrix_double & R)14048   void transpose_square_matrix(matrix_double & R){
14049     int n=int(R.size());
14050     for (int i=0;i<n;++i){
14051       for (int j=0;j<i;++j){
14052 	giac_double tmp=R[i][j];
14053 	R[i][j]=R[j][i];
14054 	R[j][i]=tmp;
14055       }
14056     }
14057   }
14058 
14059 #ifdef HAVE_LIBLAPACK
lapack_schur(matrix_double & H,matrix_double & P,bool compute_P,vecteur & eigenvalues)14060   bool lapack_schur(matrix_double & H,matrix_double & P,bool compute_P,vecteur & eigenvalues){
14061     if (!CAN_USE_LAPACK || int(H.size())<CALL_LAPACK)
14062       return false;
14063     /* int dgees_(char *jobvs, char *sort, L_fp select, integer *n,
14064        doublereal *a, integer *lda, integer *sdim, doublereal *wr,
14065        doublereal *wi, doublereal *vs, integer *ldvs, doublereal *work,
14066        integer *lwork, logical *bwork, integer *info)
14067        jobvs="n" or "v" (compute Schur vectors)
14068        sort="n" or "s" (sort eigenvals),
14069        select(real,imag) should return true if eigenval is selected
14070        n order of matrix A (==size(A))
14071        a input/output matrix (Schur form on output)
14072        lda leading dimension of A >= max(1,n)
14073        sdim (output) =0 if sort=="n" or number of eigenval selected if =="s"
14074        wr and wi (output) contains real and imaginary part of eigenvals
14075        vs (output) if jobs=="v: contains the orthogonal matrix
14076        ldvs leading dimension of vs (>=n if jobvs=="v")
14077        lwork >=3*n, dimension of the work array (should be larger for good results)
14078        bwork array of dimension n
14079        info ==0 success, <0 bad arg value, >0 runtime error
14080     */
14081     integer n=H.size(),sdim,ldvs=n,lwork=max(20,n)*n,info;
14082     doublef2c_real * Hlapack=new doublef2c_real[n*n], * Plapack=new doublef2c_real[n*n];
14083     doublef2c_real * Wreal=new doublef2c_real[n], * Wimag=new doublef2c_real[n], * work=new doublef2c_real[lwork];
14084     logical * bwork=new logical[n];
14085     char ch[2]={0,0};
14086     ch[0]=(compute_P?'v':'n');
14087     matrice_double2lapack(H,Hlapack);
14088     char ch2[]="n";
14089     dgees_(ch,ch2,0,&n,
14090 	   Hlapack,&n,&sdim,Wreal,
14091 	   Wimag,Plapack,&ldvs,work,&lwork,
14092 	   bwork,&info);
14093     lapack2matrice_double(Hlapack,n,n,H);
14094     if (compute_P){
14095       lapack2matrice_double(Plapack,n,n,P);
14096       transpose_square_matrix(P);
14097     }
14098     delete [] Hlapack; delete [] Plapack;
14099     eigenvalues.resize(n);
14100     for (int i=0;i<n;++i)
14101       eigenvalues[i]=gen(Wreal[i],Wimag[i]);
14102     delete [] Wreal; delete [] Wimag; delete [] work;
14103     delete [] bwork;
14104     return info==0;
14105   }
14106 
lapack_schur(std_matrix<gen> & H,std_matrix<gen> & P,bool compute_P,vecteur & eigenvalues,GIAC_CONTEXT)14107   bool lapack_schur(std_matrix<gen> & H,std_matrix<gen> & P,bool compute_P,vecteur & eigenvalues,GIAC_CONTEXT){
14108     if (!CAN_USE_LAPACK)
14109       return false;
14110   /* int zgees_(char *jobvs, char *sort, L_fp select, integer *n,
14111      doublecomplex *a, integer *lda, integer *sdim, doublecomplex *w,
14112      doublecomplex *vs, integer *ldvs, doublecomplex *work, integer *lwork,
14113      doublereal *rwork, logical *bwork, integer *info)
14114        jobvs="n" or "v" (compute Schur vectors)
14115        sort="n" or "s" (sort eigenvals),
14116        select(real,imag) should return true if eigenval is selected
14117        n order of matrix A (==size(A))
14118        a input/output matrix (Schur form on output)
14119        lda leading dimension of A >= max(1,n)
14120        sdim (output) =0 if sort=="n" or number of eigenval selected if =="s"
14121        w (output) contains eigenvals
14122        vs (output) if jobs=="v: contains the orthogonal matrix
14123        ldvs leading dimension of vs (>=n if jobvs=="v")
14124        lwork >=3*n, dimension of the work array (should be larger for good results)
14125        bwork array of dimension n
14126        info ==0 success, <0 bad arg value, >0 runtime error
14127     */
14128     integer n=H.size(),sdim,ldvs=n,lwork=max(20,n)*n,info;
14129     doublef2c_complex * Hlapack=new doublef2c_complex[n*n], * Plapack=new doublef2c_complex[n*n];
14130     doublef2c_complex * W=new doublef2c_complex[n], * work=new doublef2c_complex[lwork];
14131     doublef2c_real * rwork=new doublef2c_real[lwork];
14132     logical * bwork=new logical[n];
14133     matrix2zlapack(H,Hlapack,contextptr);
14134     char ch[2]={0,0};
14135     ch[0]=(compute_P?'v':'n');
14136     char ch2[]="n";
14137     zgees_(ch,ch2,0,&n,
14138 	   Hlapack,&n,&sdim,W,
14139 	   Plapack,&ldvs,work,&lwork,
14140 	   rwork,bwork,&info);
14141     zlapack2matrix(Hlapack,n,n,H);
14142     if (compute_P){
14143       zlapack2matrix(Plapack,n,n,P);
14144       P=P.transconjugate();
14145     }
14146     delete [] Hlapack; delete [] Plapack;
14147     eigenvalues.resize(n);
14148     for (int i=0;i<n;++i)
14149       eigenvalues[i]=gen(W[i].r,W[i].i);
14150     delete [] W; delete [] work; delete [] rwork;
14151     delete [] bwork;
14152     return info==0;
14153   }
14154 #else
14155 
lapack_schur(matrix_double & H,matrix_double & P,bool compute_P,vecteur & eigenvalues)14156   bool lapack_schur(matrix_double & H,matrix_double & P,bool compute_P,vecteur & eigenvalues){
14157     return false;
14158   }
14159 
lapack_schur(std_matrix<gen> & H,std_matrix<gen> & P,bool compute_P,vecteur & eigenvalues,GIAC_CONTEXT)14160   bool lapack_schur(std_matrix<gen> & H,std_matrix<gen> & P,bool compute_P,vecteur & eigenvalues,GIAC_CONTEXT){
14161     return false;
14162   }
14163 #endif // HAVE_LIBLAPACK
14164 
14165   // if jordan is false, errors for non diagonalizable matrices
14166   // if jordan is true, d is a matrix, not a vector
egv(const matrice & m0,matrice & p,vecteur & d,GIAC_CONTEXT,bool jordan,bool rational_jordan_form,bool eigenvalues_only)14167   bool egv(const matrice & m0,matrice & p,vecteur & d, GIAC_CONTEXT,bool jordan,bool rational_jordan_form,bool eigenvalues_only){
14168     matrice m=m0;
14169     if (m.size()==1){
14170       p=vecteur(1,vecteur(1,1));
14171       if (jordan)
14172 	d=m;
14173       else
14174 	d=*m.front()._VECTptr;
14175       return true;
14176     }
14177     if (has_num_coeff(m)){
14178       gen g=evalf(m,1,contextptr);
14179       if (g.type==_VECT)
14180 	m=*g._VECTptr;
14181     }
14182     bool numeric_matrix=is_fully_numeric(m);
14183     bool sym=(m==mtran(*conj(m,contextptr)._VECTptr));
14184     double eps=epsilon(contextptr);
14185     if (eps<1e-15) eps=1e-15;
14186     // check for symmetric numeric matrix
14187     if (numeric_matrix){
14188 #ifdef HAVE_LIBLAPACK
14189       if ( !is_zero(im(m,contextptr),contextptr) ){
14190 	// complex matrix, try hermitian
14191 	if (m==conj(mtran(m),contextptr)){
14192 	  // call to zheev
14193 	  // ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK,INFO)
14194 	  char JOBZ=eigenvalues_only?'N':'V';
14195 	  char UPLO='U';
14196 	  integer N=m.size();
14197 	  doublef2c_complex * A=new doublef2c_complex[N*N];
14198 	  matrice2zlapack(m,A,contextptr);
14199 	  integer LDA=N;
14200 	  double * W = new double[N];
14201 	  integer LWORK=max(10,N)*N,INFO;
14202 	  doublef2c_complex * WORK=new doublef2c_complex[LWORK];
14203 	  double * RWORK=new double[LWORK];
14204 	  zheev_( &JOBZ, &UPLO, &N, A, &LDA, W, WORK, &LWORK, RWORK,&INFO );
14205 	  delete [] WORK; delete [] RWORK;
14206 	  if (INFO){
14207 	    delete [] A; delete [] W;  return false;
14208 	  }
14209 	  d.resize(N);
14210 	  for (int i=0;i<N;++i){
14211 	    if (jordan){
14212 	      vecteur v(N);
14213 	      v[i]=W[i];
14214 	      d[i]=v;
14215 	    }
14216 	    else
14217 	      d[i]=W[i];
14218 	  }
14219 	  zlapack2matrice(A,N,N,p);
14220 	  delete [] A; delete [] W;
14221 	  return true;
14222 	}
14223 	if (int(m.size())>=CALL_LAPACK){
14224 	  // call to zgeev
14225 	  // ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR,WORK, LWORK, RWORK, INFO )
14226 	  char JOBVL=eigenvalues_only?'N':'V';
14227 	  char JOBVR=eigenvalues_only?'N':'V';
14228 	  integer N=m.size();
14229 	  doublef2c_complex * A=new doublef2c_complex[N*N];
14230 	  matrice2zlapack(m,A,contextptr);
14231 	  integer LDA=N;
14232 	  doublef2c_complex * W=new doublef2c_complex[N];
14233 	  doublef2c_complex * VL=new doublef2c_complex[N*N];
14234 	  doublef2c_complex * VR=new doublef2c_complex[N*N];
14235 	  integer LDVL=N,LDVR=N,LWORK=max(10,N)*N,INFO;
14236 	  double * RWORK=new double[LWORK];
14237 	  doublef2c_complex * WORK=new doublef2c_complex[LWORK];
14238 	  zgeev_(&JOBVL, &JOBVR, &N, A, &LDA, W, VL, &LDVL, VR,&LDVR, WORK, &LWORK, RWORK,&INFO );
14239 	  delete [] WORK; delete [] RWORK; delete [] A; delete [] VL;
14240 	  if (INFO){
14241 	    delete [] W; delete [] VR; return false;
14242 	  }
14243 	  zlapack2matrice(VR,N,N,p);
14244 	  d.resize(N);
14245 	  for (int i=0;i<N;++i){
14246 	    if (jordan){
14247 	      vecteur v(N);
14248 	      v[i]=gen(W[i].r,W[i].i);
14249 	      d[i]=v;
14250 	    }
14251 	    else
14252 	      d[i]=gen(W[i].r,W[i].i);
14253 	  }
14254 	  delete [] W; delete [] VR;
14255 	  return true;
14256 	}
14257       }
14258       if (sym){ // call to dsyev
14259 	// DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )
14260 	char JOBZ=eigenvalues_only?'N':'V';
14261 	char UPLO='U';
14262 	integer N=m.size();
14263 	double * A=new double[N*N];
14264 	matrice2lapack(m,A,contextptr);
14265 	integer LDA=N;
14266 	double * W = new double[N];
14267 	integer LWORK=max(10,N)*N,INFO;
14268 	double * WORK=new double[LWORK];
14269 	dsyev_( &JOBZ, &UPLO, &N, A, &LDA, W, WORK, &LWORK, &INFO );
14270 	delete [] WORK;
14271 	if (INFO){
14272 	  delete [] A; delete [] W;  return false;
14273 	}
14274 	d.resize(N);
14275 	for (int i=0;i<N;++i){
14276 	  if (jordan){
14277 	    vecteur v(N);
14278 	    v[i]=W[i];
14279 	    d[i]=v;
14280 	  }
14281 	  else
14282 	    d[i]=W[i];
14283 	}
14284 	lapack2matrice(A,N,N,p);
14285 	delete [] A; delete [] W;
14286 	return true;
14287       }
14288       if (int(m.size())>=CALL_LAPACK){
14289 	// call to dgeev
14290 	// DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR,LDVR, WORK, LWORK, INFO )
14291 	char JOBVL=eigenvalues_only?'N':'V';
14292 	char JOBVR=eigenvalues_only?'N':'V';
14293 	integer N=m.size();
14294 	double * A=new double[N*N];
14295 	matrice2lapack(m,A,contextptr);
14296 	integer LDA=N;
14297 	double * WR=new double[N];
14298 	double * WI=new double[N];
14299 	double * VL=new double[N*N];
14300 	double * VR=new double[N*N];
14301 	integer LDVL=N,LDVR=N,LWORK=max(10,N)*N,INFO=0;
14302 	double * WORK=new double[LWORK];
14303 	dgeev_(&JOBVL, &JOBVR, &N, A, &LDA, WR, WI, VL, &LDVL, VR,&LDVR, WORK, &LWORK, &INFO );
14304 	delete [] WORK; delete [] A; delete [] VL;
14305 	if (INFO){
14306 	  delete [] WR; delete [] WI; delete [] VR; return false;
14307 	}
14308 	lapack2matrice(VR,N,N,p);
14309 	p=mtran(p);
14310 	d.resize(N);
14311 	for (int i=0;i<N;++i){
14312 	  if (jordan){
14313 	    vecteur v(N);
14314 	    v[i]=gen(WR[i],WI[i]);
14315 	    d[i]=v;
14316 	    if (WI[i]!=0 && i!=N-1){
14317 	      v[i]=0;
14318 	      v[i+1]=gen(WR[i],-WI[i]);
14319 	      d[i+1]=v;
14320 	    }
14321 	  }
14322 	  else {
14323 	    d[i]=gen(WR[i],WI[i]);
14324 	    if (WI[i]!=0 && i!=N-1)
14325 	      d[i+1]=gen(WR[i],-WI[i]);
14326 	  }
14327 	  if (WI[i]==0 || i==N-1)
14328 	    continue;
14329 	  gen tmp=p[i]+cst_i*p[i+1];
14330 	  p[i]=tmp;
14331 	  p[i+1]=conj(tmp,contextptr);
14332 	  ++i;
14333 	}
14334 	p=mtran(p);
14335 	delete [] WR; delete [] WI; delete [] VR;
14336 	return true;
14337       }
14338 #endif // HAVE_LIBLAPACK
14339 #ifdef HAVE_LIBGSL
14340       if (sym){
14341 	gsl_matrix * a=matrice2gsl_matrix(m,contextptr);
14342 	int s=a->size1;
14343 	gsl_matrix * eigenvectors= gsl_matrix_alloc(s,s);
14344 	gsl_vector * eigenvalues =gsl_vector_alloc(s);
14345 	gsl_eigen_symmv_workspace * w=gsl_eigen_symmv_alloc(s);
14346 	gsl_eigen_symmv (a, eigenvalues,eigenvectors,w);
14347 	gsl_eigen_symmv_free(w);
14348 	p=gsl_matrix2matrice(eigenvectors);
14349 	d=gsl_vector2vecteur(eigenvalues);
14350 	if (jordan){
14351 	  for (int i=0;i<s;++i){
14352 	    vecteur tmp(s);
14353 	    tmp[i]=d[i];
14354 	    d[i]=tmp;
14355 	  }
14356 	}
14357 	gsl_matrix_free(eigenvectors);
14358 	gsl_vector_free(eigenvalues);
14359 	return true;
14360       } // end sym. matrix
14361 #endif // HAVE_LIBGSL
14362       std_matrix<gen> H,P;
14363       matrice2std_matrix_gen(m,H);
14364       int dim(int(H.size()));
14365       matrice pid(midn(dim));
14366       matrice2std_matrix_gen(pid,P);
14367       matrix_double H1,P1;
14368       if (!eigenvalues_only){
14369 	std_matrix_gen2std_matrix_giac_double(P,P1,false);
14370       }
14371       if (std_matrix_gen2std_matrix_giac_double(H,H1,false)){
14372 	bool ans=francis_schur(H1,0,dim,P1,2*SOLVER_MAX_ITERATE,eps,false,!eigenvalues_only);
14373 	if (eigenvalues_only){
14374 	  vecteur res;
14375 	  ans = ans && schur_eigenvalues(H1,res,eps,contextptr);
14376 	  if (!jordan)
14377 	    d=res;
14378 	  else {
14379 	    gen tmp=_diag(res,contextptr);
14380 	    if (tmp.type!=_VECT)
14381 	      return false;
14382 	    d=*tmp._VECTptr;
14383 	  }
14384 	  return ans;
14385 	}
14386 	else {
14387 	  std_matrix_giac_double2std_matrix_gen(H1,H);
14388 	  std_matrix_giac_double2std_matrix_gen(P1,P);
14389 	  // finish Schur with complex entries
14390 	  ans=francis_schur(H,0,dim,P,2*SOLVER_MAX_ITERATE,eps,true,true,true,true,contextptr);
14391 	  std_matrix_gen2matrice_destroy(P,p);
14392 	  std_matrix_gen2matrice_destroy(H,d);
14393 	  if (abs_calc_mode(contextptr)==38)
14394 	    return ans && schur_eigenvectors(p,d,eps,contextptr);
14395 	  schur_eigenvectors(p,d,eps,contextptr);
14396 	  return ans;
14397 	}
14398       }
14399       else {
14400 	matrix_complex_double H2;
14401 	bool ans;
14402 	if (matrice2std_matrix_complex_double(m,H2)){
14403 	  matrix_complex_double P2;
14404 	  matrice2std_matrix_complex_double(pid,P2);
14405 	  ans=francis_schur(H2,0,dim,P2,SOLVER_MAX_ITERATE,eps,false,true);
14406 	  std_matrix_complex_double2std_matrix_gen(P2,P);
14407 	  std_matrix_complex_double2std_matrix_gen(H2,H);
14408 	}
14409 	else
14410 	  ans=francis_schur(H,0,dim,P,SOLVER_MAX_ITERATE,dim*eps,false,true,true,true,contextptr);
14411 	std_matrix_gen2matrice_destroy(P,p);
14412 	std_matrix_gen2matrice_destroy(H,d);
14413 	return ans && schur_eigenvectors(p,d,eps,contextptr);
14414       }
14415     } // end if (numeric_matrix)
14416     int taille=int(m.size());
14417     vecteur lv;
14418     alg_lvar_halftan_tsimplify(m,lv,contextptr);
14419     numeric_matrix=has_num_coeff(m) && is_fully_numeric(evalf(m,1,contextptr));
14420     matrice mr=*(e2r(numeric_matrix?exact(m,contextptr):m,lv,contextptr)._VECTptr); // convert to internal form
14421     // vecteur lv;
14422     // matrice mr = m;
14423     matrice m_adj;
14424     vecteur p_car;
14425     p_car=mpcar(mr,m_adj,true,contextptr);
14426     p_car=common_deno(p_car)*p_car; // remove denominators
14427     // extension handling
14428     gen modulo,fieldpmin;
14429     if (has_mod_coeff(p_car,modulo)){
14430       modpoly pc=*unmod(p_car)._VECTptr;
14431       vector< facteur<modpoly> > vpc; vector<modpoly> qmat;
14432       environment env;
14433       env.modulo=modulo; env.moduloon=true; env.pn=modulo;
14434       if (ddf(pc,qmat,&env,vpc)){
14435 	int extdeg=1;
14436 	for (int j=0;j<int(vpc.size());++j){
14437 	  extdeg=lcm(extdeg,vpc[j].mult).val;
14438 	}
14439 #ifndef NO_RTTI
14440 	if (extdeg>1){
14441 	  *logptr(contextptr) << "Creating splitting field extension GF(" << modulo << "," << extdeg << ")" << '\n';
14442 	  gen tmp=_galois_field(makesequence(modulo,extdeg),contextptr);
14443 	  tmp=tmp[plus_two];
14444 	  tmp=eval(tmp[2],1,contextptr); // field generator
14445 	  p_car=tmp*p_car;
14446 	}
14447 #endif
14448       }
14449       else
14450 	*logptr(contextptr) << "Warning! Automatic extension not implemented. You can try to diagonalize the matrix * a non trivial element of GF(" << modulo << ",lcm of degrees of factor(" << symb_horner(p_car,vx_var) << "))" <<  '\n';
14451     }
14452 #ifndef NO_RTTI
14453     if (has_gf_coeff(p_car,modulo,fieldpmin)){
14454       factorization f;
14455       gen res=gf_list()[pow(modulo,gfsize(fieldpmin),contextptr)].g;
14456       if (galois_field * ptr=dynamic_cast<galois_field *>(res._USERptr)){
14457 	polynome P(1);
14458 	poly12polynome(p_car,1,P,1);
14459 	res=ptr->polyfactor(P,f);
14460 	int extdeg=1;
14461 	for (int i=0;i<int(f.size());++i){
14462 	  extdeg=lcm(extdeg,f[i].fact.lexsorted_degree()).val;
14463 	}
14464 	if (extdeg>1){
14465 	  extdeg *= gfsize(fieldpmin);
14466 	  *logptr(contextptr) << "Creating splitting field extension GF(" << modulo << "," << extdeg << ")" << '\n';
14467 	  gen tmp=_galois_field(makesequence(modulo,extdeg),contextptr);
14468 	  tmp=tmp[plus_two];
14469 	  tmp=eval(tmp[2],1,contextptr); // field generator
14470 	  p_car=tmp*p_car;
14471 	}
14472       }
14473     }
14474 #endif
14475     // factorizes p_car
14476     factorization f;
14477     polynome ppcar(poly1_2_polynome(p_car,1));
14478     polynome p_content(ppcar.dim);
14479     gen extra_div=1;
14480     if (!factor(ppcar,p_content,f,false,rational_jordan_form?false:withsqrt(contextptr),
14481 		//false,
14482 		complex_mode(contextptr),
14483 		1,extra_div))
14484       return false;
14485     // insure that extra extensions created in factor are reduced inside m_adj
14486     //clean_ext_reduce(m_adj);
14487     factorization::const_iterator f_it=f.begin(),f_itend=f.end();
14488     int total_char_found=0;
14489     for (;f_it!=f_itend;++f_it){
14490       // find roots of it->fact
14491       // works currently only for 1st order factors
14492       // vecteur v=solve(f_it->fact);
14493       vecteur v;
14494       const polynome & itfact=f_it->fact;
14495       vecteur w=polynome2poly1(itfact,1);
14496       int s=int(w.size());
14497       if (s<2)
14498 	continue;
14499       if (s==2)
14500 	v.push_back(rdiv(-w.back(),w.front(),contextptr));
14501       if (is_undef(v))
14502 	return false;
14503       gen x;
14504       vecteur cur_m_adj(m_adj),cur_lv(lv),new_m_adj,char_m;
14505       if (s>=3 && rational_jordan_form){
14506 	int mult=f_it->mult;
14507 	int qdeg=s-1;
14508 	int n=mult*qdeg; // number of vectors to find
14509 	// Divide cur_m_adj by w f_it->mult times
14510 	// Collect the remainders matrices in C
14511 	vecteur C,quo,rem;
14512 	int char_line=0,char_found=0,cycle_size=mult;
14513 	for (int i=0;i<mult;++i){
14514 	  DivRem(cur_m_adj,w,0,quo,rem);
14515 	  // rem is a polynomial made of matrices
14516 	  // we convert it to a matrix (explode the polys)
14517 	  if (rem.empty()){
14518 	    --cycle_size;
14519 	  }
14520 	  else {
14521 	    C=mergematrice(C,polymat2mat(rem));
14522 	    if (is_undef(C)) return false;
14523 	  }
14524 	  cur_m_adj=quo;
14525 	}
14526 	// char_line is the line where the reduction begins
14527 	vecteur Ccopy(C),pivots;
14528 	gen det;
14529 	for (;char_found<n;){
14530 	  // Reduce
14531 	  if (!mrref(Ccopy,C,pivots,det,0,int(Ccopy.size()),0,taille,
14532 		/* fullreduction */1,char_line,true,1,0,
14533 		     contextptr))
14534 	    return false;
14535 	  // Extract a non-0 line at char_line
14536 	  vecteur line=*C[char_line]._VECTptr;
14537 	  if (is_zero(vecteur(line.begin(),line.begin()+taille),contextptr)){
14538 	    // Keep lines 0 to char_line-1, remove last taille columns
14539 	    Ccopy=mtran(vecteur(C.begin(),C.begin()+char_line));
14540 	    if (signed(Ccopy.size())<taille)
14541 	      return false; // setdimerr();
14542 	    vecteur debut(Ccopy.begin(),Ccopy.end()-taille);
14543 	    debut=mtran(debut);
14544 	    // Cut first taille columns of the remainder of the matrix
14545 	    Ccopy=mtran(vecteur(C.begin()+char_line,C.end()));
14546 	    if (signed(Ccopy.size())<taille)
14547 	      return false; // setdimerr();
14548 	    vecteur fin(Ccopy.begin()+taille,Ccopy.end());
14549 	    fin=mtran(fin);
14550 	    Ccopy=mergevecteur(debut,fin);
14551 	    --cycle_size;
14552 	    continue;
14553 	  }
14554 	  Ccopy=vecteur(C.begin(),C.begin()+char_line);
14555 	  // make a bloc with line and A, A^2, ..., A^[qdeg-1]*line
14556 	  // and put them into Ccopy and in ptmp
14557 	  vecteur ptmp;
14558 	  for (int i=0;i<qdeg;++i){
14559 	    Ccopy.push_back(line);
14560 	    ptmp.push_back(line);
14561 	    line=generalized_multmatvecteur(mr,line);
14562 	  }
14563 	  // finish Ccopy by copying the remaining lines of C
14564 	  const_iterateur ittmp=C.begin()+char_line+1,ittmpend=C.end();
14565 	  for (;ittmp!=ittmpend;++ittmp)
14566 	    Ccopy.push_back(*ittmp);
14567 	  // update d (with a ratjord bloc)
14568 	  int taille_bloc=qdeg*cycle_size;
14569 	  matrice tmp=mtran(rat_jordan_block(w,cycle_size,false));
14570 	  tmp=mergematrice(vecteur(qdeg*cycle_size,vecteur(total_char_found)),tmp);
14571 	  tmp=mergematrice(tmp,vecteur(qdeg*cycle_size,vecteur(taille-total_char_found-taille_bloc)));
14572 	  if (is_undef(tmp)) return false;
14573 	  d=mergevecteur(d,tmp);
14574 	  // update p with ptmp
14575 	  matrice padd;
14576 	  for (int j=0;j<cycle_size;++j){
14577 	    for (int i=0;i<qdeg;++i){
14578 	      vecteur & ptmpi=*ptmp[i]._VECTptr;
14579 	      padd.push_back(vecteur(ptmpi.begin()+taille*j,ptmpi.begin()+taille*(j+1)));
14580 	    }
14581 	  }
14582 	  matrice AA(pseudo_rat_to_rat(w,cycle_size));
14583 	  if (is_undef(AA)) return false;
14584 	  padd=mmult(AA,padd);
14585 	  p=mergevecteur(p,padd);
14586 	  char_found += taille_bloc;
14587 	  total_char_found += taille_bloc;
14588 	  char_line += cycle_size;
14589 	}
14590 	continue;
14591       } // end if s>=3 and rational_jordan_form
14592       if (s>=3){ // recompute cur_m_adj using new extensions
14593 	cur_m_adj=*r2sym(m_adj,lv,contextptr)._VECTptr;
14594 	identificateur tmpx(" x");
14595 	vecteur ww(w.size());
14596 	for (unsigned i=0;i<w.size();++i)
14597 	  ww[i]=r2e(w[i],lv,contextptr);
14598 	gen wwx=horner(ww,tmpx);
14599 	v=solve(wwx,tmpx,complex_mode(contextptr),contextptr);
14600 	v=*apply(v,recursive_normal,contextptr)._VECTptr;
14601 	if (v.size()!=w.size()-1){
14602 	  gen m0num=evalf(m0,1,contextptr);
14603 	  if (m0num.type==_VECT
14604 	      && is_numericm(*m0num._VECTptr)
14605 	      // && lidnt(m0num).empty()
14606 	      ){
14607 	    *logptr(contextptr) << gettext("Unable to find exact eigenvalues. Trying approx") << '\n';
14608 	    return egv(*m0num._VECTptr,p,d,contextptr,jordan,false,eigenvalues_only);
14609 	  }
14610 	}
14611 	// compute new lv and update v and m_adj accordingly
14612 	cur_lv=alg_lvar(v);
14613 	alg_lvar(cur_m_adj,cur_lv);
14614 	cur_m_adj=*(e2r(cur_m_adj,cur_lv,contextptr)._VECTptr);
14615 	v=*(e2r(v,cur_lv,contextptr)._VECTptr);
14616       }
14617       const_iterateur it=v.begin(),itend=v.end();
14618       gen cur_m;
14619       for (;it!=itend;++it){
14620 	vecteur cur_m_adjx(cur_m_adj);
14621 	char_m.clear();
14622 	int n=f_it->mult;
14623 	x=r2sym(*it,cur_lv,contextptr);
14624 	if (eigenvalues_only && !jordan){
14625 	  d=mergevecteur(d,vecteur(n,x));
14626 	  total_char_found +=n;
14627 	  continue;
14628 	}
14629 	// compute Taylor expansion of m_adj at roots of it->fact
14630 	// at order n-1
14631 	for (;;){
14632 	  --n;
14633 	  if (n){
14634 	    cur_m=horner(cur_m_adjx,*it,0,new_m_adj);
14635 	    if (char_m.empty())
14636 	      char_m=mtran(*cur_m._VECTptr);
14637 	    else
14638 	      char_m=mergematrice(char_m,mtran(*cur_m._VECTptr));
14639 	    if (is_undef(char_m) || (!jordan && !is_zero(cur_m,contextptr)) ){
14640 #ifndef NO_STDEXCEPT
14641 	      throw(std::runtime_error("Not diagonalizable at eigenvalue "+x.print()));
14642 #endif
14643 	      return false;
14644 	    }
14645 	    cur_m_adjx=new_m_adj;
14646 	  }
14647 	  else {
14648 	    cur_m=horner(cur_m_adjx,*it);
14649 	    char_m=mergematrice(char_m,mtran(*cur_m._VECTptr));
14650 	    if (is_undef(char_m)) return false;
14651 	    break;
14652 	  }
14653 	}
14654 	n=f_it->mult;
14655 	if (n==1){
14656 	  char_m=mtran(*cur_m._VECTptr);
14657 	  iterateur ct=char_m.begin(),ctend=char_m.end();
14658 	  for (;ct!=ctend;++ct){
14659 	    if (!is_zero(*ct,contextptr))
14660 	      break;
14661 	  }
14662 	  if (ct==ctend)
14663 	    return false; // setsizeerr(gettext("egv/jordan bug"));
14664 	  // FIXME take 1st non-0 col as eigenvector
14665 	  *ct=*ct/lgcd(*ct->_VECTptr);
14666 	  gen eigenvector=r2sym(*ct,cur_lv,contextptr);
14667 	  if (is_fully_numeric(eigenvector) || numeric_matrix)
14668 	    eigenvector=_normalize(eigenvector,contextptr);
14669 	  p.push_back(eigenvector);
14670 	  if (jordan){
14671 	    vecteur vegv(taille,zero);
14672 	    if (total_char_found>taille)
14673 	      return false; // setsizeerr(gettext("Bug in egv/jordan"));
14674 	    vegv[total_char_found]=x;
14675 	    d.push_back(vegv);
14676 	  }
14677 	  else
14678 	    d.push_back(x);
14679 	  ++total_char_found;
14680 	  continue;
14681 	}
14682 	if (jordan){
14683 	  // back to external form
14684 	  char_m=*r2sym(char_m,cur_lv,contextptr)._VECTptr;
14685 	  int egv_found=0;
14686 	  int char_found=0;
14687 	  vecteur char_m_copy(char_m),pivots;
14688 	  gen det;
14689 	  for (;char_found<n;){
14690 	    if (!mrref(char_m_copy,char_m,pivots,det,0,taille,0,taille,
14691 		  /* fullreduction */1,egv_found,true,1,0,
14692 		       contextptr))
14693 	      return false;
14694 	    if (sym )
14695 	      char_m=gramschmidt(char_m,false,contextptr);
14696 	    char_m_copy.clear();
14697 	    // extract non-0 lines starting from line number egv_found
14698 	    vecteur vegv;
14699 	    int j=0;
14700 	    for (;j<egv_found;++j)
14701 	      char_m_copy.push_back(vecteur(char_m[j]._VECTptr->begin(),char_m[j]._VECTptr->end()-taille));
14702 	    for (;j<taille;++j){
14703 	      vegv=vecteur( char_m[j]._VECTptr->begin(),char_m[j]._VECTptr->begin()+taille);
14704 	      if (is_zero(vegv,contextptr) || (numeric_matrix && evalf(abs(vegv,contextptr),1,contextptr)._DOUBLE_val<10*taille*epsilon(contextptr)) )
14705 		break;
14706 	      // cycle found!
14707 	      // update char_m_copy with all the cycle except first vector
14708 	      char_m_copy.push_back(vecteur(char_m[j]._VECTptr->begin(),char_m[j]._VECTptr->end()-taille));
14709 	      // Store cycle
14710 	      const_iterateur c_it=char_m[j]._VECTptr->begin(),c_itend=char_m[j]._VECTptr->end();
14711 	      for (;c_it!=c_itend;c_it+=taille){
14712 		p.push_back(vecteur(c_it,c_it+taille)); // char vector
14713 		// update d
14714 		vegv=vecteur(taille,zero);
14715 		if (total_char_found>=taille)
14716 		  return false; // setsizeerr(gettext("Bug in egv/jordan"));
14717 		if (c_it==char_m[j]._VECTptr->begin()){
14718 		  vegv[total_char_found]=x;
14719 		  ++egv_found;
14720 		}
14721 		else {
14722 		  vegv[total_char_found-1]=1;
14723 		  vegv[total_char_found]=x;
14724 		}
14725 		++char_found;
14726 		++total_char_found;
14727 		d.push_back(vegv);
14728 	      }
14729 	    }
14730 	    for (;j<taille;++j){
14731 	      char_m_copy.push_back(vecteur(char_m[j]._VECTptr->begin()+taille,char_m[j]._VECTptr->end()));
14732 	    }
14733 	  }
14734 	} // end if (jordan)
14735 	else {
14736 	  d=mergevecteur(d,vecteur(n,x));
14737 	  // back to external form
14738 	  cur_m=r2sym(cur_m,cur_lv,contextptr);
14739 	  // column reduction
14740 	  matrice m_egv=mrref(mtran(*cur_m._VECTptr),contextptr);
14741 	  if (sym){
14742 	    // orthonormalize basis
14743 	    m_egv=gramschmidt(matrice(m_egv.begin(),m_egv.begin()+f_it->mult),false,contextptr);
14744 	  }
14745 	  // non zero rows of cur_m are eigenvectors
14746 	  const_iterateur m_it=m_egv.begin(),m_itend=m_egv.end();
14747 	  for (; m_it!=m_itend;++m_it){
14748 	    if (!is_zero(*m_it,contextptr))
14749 	      p.push_back(*m_it);
14750 	  }
14751 	}
14752       }
14753     } // end for factorization
14754     if (!p.empty()){
14755       if (!eigenvalues_only)
14756 	p=mtran(p);
14757       if (jordan)
14758 	d=mtran(d);
14759     }
14760     return true;
14761   }
megv(const matrice & e,GIAC_CONTEXT)14762   matrice megv(const matrice & e,GIAC_CONTEXT){
14763     matrice m;
14764     vecteur d;
14765     bool b=complex_mode(contextptr);
14766     complex_mode(true,contextptr);
14767     if (!egv(e,m,d,contextptr,false,false,false))
14768       *logptr(contextptr) << gettext("Low accuracy or not diagonalizable at some eigenvalue. Try jordan if the matrix is exact.") << '\n';
14769     complex_mode(b,contextptr);
14770     return m;
14771   }
14772 
symb_egv(const gen & a)14773   gen symb_egv(const gen & a){
14774     return symbolic(at_egv,a);
14775   }
_egv(const gen & a,GIAC_CONTEXT)14776   gen _egv(const gen & a,GIAC_CONTEXT){
14777     if ( a.type==_STRNG && a.subtype==-1) return  a;
14778     if (!is_squarematrix(a)){
14779       if (a.type==_VECT)
14780 	return gendimerr(contextptr);
14781       return symb_egv(a);
14782     }
14783     return megv(*a._VECTptr,contextptr);
14784   }
14785   static const char _egv_s []="egv";
14786   static define_unary_function_eval (__egv,&_egv,_egv_s);
14787   define_unary_function_ptr5( at_egv ,alias_at_egv,&__egv,0,true);
14788 
14789 
megvl(const matrice & e,GIAC_CONTEXT)14790   vecteur megvl(const matrice & e,GIAC_CONTEXT){
14791     matrice m;
14792     vecteur d;
14793     bool b=complex_mode(contextptr);
14794     complex_mode(true,contextptr);
14795     if (!egv(e,m,d,contextptr,true,false,true))
14796       *logptr(contextptr) << gettext("Low accuracy") << '\n';
14797     complex_mode(b,contextptr);
14798     return d;
14799   }
symb_egvl(const gen & a)14800   gen symb_egvl(const gen & a){
14801     return symbolic(at_egvl,a);
14802   }
_egvl(const gen & a,GIAC_CONTEXT)14803   gen _egvl(const gen & a,GIAC_CONTEXT){
14804     if ( a.type==_STRNG && a.subtype==-1) return  a;
14805     if (!is_squarematrix(a))
14806       return gendimerr(contextptr);
14807     return megvl(*a._VECTptr,contextptr);
14808   }
14809   static const char _egvl_s []="egvl";
14810   static define_unary_function_eval (__egvl,&_egvl,_egvl_s);
14811   define_unary_function_ptr5( at_egvl ,alias_at_egvl,&__egvl,0,true);
14812 
mjordan(const matrice & e,bool rational_jordan,GIAC_CONTEXT)14813   vecteur mjordan(const matrice & e,bool rational_jordan,GIAC_CONTEXT){
14814     matrice m;
14815     vecteur d;
14816     if (!egv(e,m,d,contextptr,true,rational_jordan,false))
14817       *logptr(contextptr) << gettext("Low accuracy") << '\n';
14818     return makevecteur(m,d);
14819   }
symb_jordan(const gen & a)14820   gen symb_jordan(const gen & a){
14821     return symbolic(at_jordan,a);
14822   }
jordan(const gen & a,bool rational_jordan,GIAC_CONTEXT)14823   gen jordan(const gen & a,bool rational_jordan,GIAC_CONTEXT){
14824     if (a.type==_VECT && a.subtype==_SEQ__VECT && a._VECTptr->size()==2 && is_squarematrix(a._VECTptr->front()) ){
14825       vecteur v(mjordan(*a._VECTptr->front()._VECTptr,rational_jordan,contextptr));
14826       if (is_undef(v))
14827 	return v;
14828       gen tmpsto=sto(v[0],a._VECTptr->back(),contextptr);
14829       if (is_undef(tmpsto)) return tmpsto;
14830       return v[1];
14831     }
14832     if (!is_squarematrix(a))
14833       return symb_jordan(a);
14834     vecteur v(mjordan(*a._VECTptr,rational_jordan,contextptr));
14835     if (is_undef(v))
14836       return v;
14837     if (xcas_mode(contextptr)==1)
14838       return v[1];
14839     else
14840       return gen(v,_SEQ__VECT);
14841   }
14842 
_jordan(const gen & a,GIAC_CONTEXT)14843   gen _jordan(const gen & a,GIAC_CONTEXT){
14844     if ( a.type==_STRNG && a.subtype==-1) return  a;
14845     bool mode=complex_mode(contextptr);
14846     complex_mode(true,contextptr);
14847     gen res=jordan(a,false,contextptr);
14848     complex_mode(mode,contextptr);
14849     return res;
14850   }
14851   static const char _jordan_s []="jordan";
14852   static define_unary_function_eval (__jordan,&_jordan,_jordan_s);
14853   define_unary_function_ptr5( at_jordan ,alias_at_jordan,&__jordan,0,true);
14854 
_rat_jordan(const gen & a,GIAC_CONTEXT)14855   gen _rat_jordan(const gen & a,GIAC_CONTEXT){
14856     if ( a.type==_STRNG && a.subtype==-1) return  a;
14857     return jordan(a,true,contextptr);
14858   }
14859   static const char _rat_jordan_s []="rat_jordan";
14860   static define_unary_function_eval (__rat_jordan,&_rat_jordan,_rat_jordan_s);
14861   define_unary_function_ptr5( at_rat_jordan ,alias_at_rat_jordan,&__rat_jordan,0,true);
14862 
diagonal_apply(const gen & g,const gen & x,const matrice & m,GIAC_CONTEXT)14863   matrice diagonal_apply(const gen & g,const gen & x,const matrice & m,GIAC_CONTEXT){
14864     if (!is_squarematrix(m))
14865       return vecteur(1,gensizeerr(contextptr));
14866     int n=int(m.size());
14867     matrice res;
14868     for (int i=0;i<n;++i){
14869       vecteur v=*m[i]._VECTptr;
14870       gen tmp=subst(g,x,v[i],false,contextptr);
14871       if (is_undef(tmp))
14872 	tmp=subst(g,x,v[i],true,contextptr);
14873       v[i]=tmp;
14874       res.push_back(v);
14875     }
14876     return res;
14877   }
14878 
analytic_apply(const gen & ux,const gen & x,const matrice & m,GIAC_CONTEXT)14879   matrice analytic_apply(const gen &ux,const gen & x,const matrice & m,GIAC_CONTEXT){
14880     if (!is_squarematrix(m))
14881       return vecteur(1,gensizeerr(contextptr));
14882     int n=int(m.size());
14883     matrice p,d,N,v(n),D;
14884     bool cplx=complex_mode(contextptr),sqrtb=withsqrt(contextptr);
14885     complex_mode(true,contextptr);
14886     withsqrt(true,contextptr);
14887     if (!egv(m,p,d,contextptr,true,false,false))
14888       return vecteur(1,gensizeerr(contextptr));
14889     complex_mode(cplx,contextptr);
14890     withsqrt(sqrtb,contextptr);
14891     if (int(p.size())!=n)
14892       return vecteur(1,gensizeerr(gettext("Unable to find all eigenvalues")));
14893     // search for distance of 1st non-zero non-diagonal element
14894     int dist=0;
14895     for (int i=0;i<n;++i){
14896       for (int j=0;j<n;++j){
14897 	const gen & g=d[i][j];
14898 	if (!is_zero(g,contextptr) && i!=j)
14899 	  dist=giacmax(dist,n-absint(i-j));
14900 	if (i==j)
14901 	  v[j]=g;
14902 	else
14903 	  v[j]=zero;
14904       }
14905       D.push_back(v);
14906     }
14907     identificateur y(" y");
14908     if (!dist) {// u(d) should be replaced with applying u to elements of d
14909       d=diagonal_apply(ux,x,d,contextptr);
14910       if (is_undef(d)) return d;
14911       return mmult(mmult(p,d),minv(p,contextptr));
14912     }
14913     N=subvecteur(d,D);
14914     vecteur pol;
14915     if (!taylor(ux,x,y,dist,pol,contextptr))
14916       return vecteur(1,gensizeerr(ux.print()+gettext(" is not analytic")));
14917     if (is_undef(pol.back()))
14918       pol.pop_back();
14919     reverse(pol.begin(),pol.end());
14920     // subst y with D (i.e. diagonal element by diagonal element)
14921     int pols=int(pol.size());
14922     for (int i=0;i<pols;++i){
14923       if (is_undef( (pol[i]=diagonal_apply(pol[i],y,D,contextptr)) ))
14924 	return gen2vecteur(pol[i]);
14925     }
14926     gen res=horner(pol,N);
14927     if (res.type!=_VECT)
14928       return vecteur(1,gensizeerr(contextptr));
14929     d=mmult(p,*res._VECTptr);
14930     d=mmult(d,minv(p,contextptr));
14931     return d;
14932   }
14933 
analytic_apply(const unary_function_ptr * u,const matrice & m,GIAC_CONTEXT)14934   matrice analytic_apply(const unary_function_ptr *u,const matrice & m,GIAC_CONTEXT){
14935     identificateur x(" x");
14936     gen ux=(*u)(x,contextptr);
14937     return analytic_apply(ux,x,m,contextptr);
14938   }
14939 
14940   // return a vector which elements are the basis of the ker of a
mker(const matrice & a,vecteur & v,int algorithm,GIAC_CONTEXT)14941   bool mker(const matrice & a,vecteur & v,int algorithm,GIAC_CONTEXT){
14942     v.clear();
14943     gen det;
14944     vecteur pivots;
14945     matrice res;
14946     if (!mrref(a,res,pivots,det,0,int(a.size()),0,int(a.front()._VECTptr->size()),
14947 	  /* fullreduction */1,0,true,algorithm,0,
14948 	       contextptr))
14949       return false;
14950     mdividebypivot(res,-1,contextptr);
14951     // put zero lines in res at their proper place, so that
14952     // non zero pivot are on the diagonal
14953     int s=int(res.size()),c=int(res.front()._VECTptr->size());
14954     matrice newres;
14955     newres.reserve(s);
14956     matrice::const_iterator it=res.begin(),itend=res.end();
14957     int i;
14958     for (i=0;(i<c) && (it!=itend);++i){
14959       if (it->_VECTptr->empty() || is_zero(((*(it->_VECTptr))[i]),contextptr)){
14960 	newres.push_back(vecteur(c,zero));
14961       }
14962       else {
14963 	newres.push_back(*it);
14964 	++it;
14965       }
14966     }
14967     for (;i<c;++i)
14968       newres.push_back(vecteur(c,zero));
14969     // now tranpose newres & resize, keep the ith line if it's ith coeff is 0
14970     // replace 0 by -1 to get an element of the basis
14971     matrice restran;
14972     mtran(newres,restran,int(res.front()._VECTptr->size()));
14973     it=restran.begin();
14974     itend=restran.end();
14975     bool modular=!pivots.empty() && pivots.front().type==_MOD;
14976     for (int i=0;it!=itend;++it,++i){
14977       if (is_zero((*(it->_VECTptr))[i],contextptr)){
14978 	(*(it->_VECTptr))[i]=modular?makemod(-1,*(pivots.front()._MODptr+1)):-1;
14979 	v.push_back(*it);
14980       }
14981     }
14982     return true;
14983   }
14984 
mker(const matrice & a,vecteur & v,GIAC_CONTEXT)14985   bool mker(const matrice & a,vecteur & v,GIAC_CONTEXT){
14986     return mker(a,v,1,contextptr);
14987   }
14988 
mker(const matrice & a,GIAC_CONTEXT)14989   vecteur mker(const matrice & a,GIAC_CONTEXT){
14990     vecteur v;
14991     if (!mker(a,v,contextptr))
14992       return vecteur(1,gendimerr(contextptr));
14993     return v;
14994   }
_ker(const gen & a,GIAC_CONTEXT)14995   gen _ker(const gen & a,GIAC_CONTEXT){
14996     if ( a.type==_STRNG && a.subtype==-1) return  a;
14997     if (!ckmatrix(a))
14998       return symb_ker(a);
14999     vecteur v;
15000     if (!mker(*a._VECTptr,v,contextptr))
15001       return vecteur(1,gendimerr(contextptr));
15002     return v;
15003   }
15004   static const char _ker_s []="ker";
15005   static define_unary_function_eval (__ker,&_ker,_ker_s);
15006   define_unary_function_ptr5( at_ker ,alias_at_ker,&__ker,0,true);
15007 
mimage(const matrice & a,vecteur & v,GIAC_CONTEXT)15008   bool mimage(const matrice & a, vecteur & v,GIAC_CONTEXT){
15009     matrice atran;
15010     mtran(a,atran);
15011     v.clear();
15012     gen det;
15013     vecteur pivots;
15014     matrice res;
15015     if (!mrref(atran,res,pivots,det,0,int(atran.size()),0,int(atran.front()._VECTptr->size()),
15016 	  /* fullreduction */1,0,true,1,0,
15017 	       contextptr))
15018       return false;
15019     matrice::const_iterator it=res.begin(),itend=res.end();
15020     for (int i=0;it!=itend;++it,++i){
15021       if (!is_zero(*(it),contextptr))
15022 	v.push_back(*it);
15023     }
15024     return true;
15025   }
15026 
mimage(const matrice & a,GIAC_CONTEXT)15027   vecteur mimage(const matrice & a,GIAC_CONTEXT){
15028     vecteur v;
15029     if (!mimage(a,v,contextptr))
15030       return vecteur(1,gendimerr(contextptr));
15031     return v;
15032   }
15033 
_image(const gen & a,GIAC_CONTEXT)15034   gen _image(const gen & a,GIAC_CONTEXT){
15035     if ( a.type==_STRNG && a.subtype==-1) return  a;
15036     if (!ckmatrix(a))
15037       return symb_image(a);
15038     vecteur v;
15039     if (!mimage(*a._VECTptr,v,contextptr))
15040       return gensizeerr(contextptr);
15041     return v;
15042   }
15043   static const char _image_s []="image";
15044   static define_unary_function_eval (__image,&_image,_image_s);
15045   define_unary_function_ptr5( at_image ,alias_at_image,&__image,0,true);
15046 
cross(const vecteur & v_orig,const vecteur & w_orig,GIAC_CONTEXT)15047   vecteur cross(const vecteur & v_orig,const vecteur & w_orig,GIAC_CONTEXT){
15048     vecteur v(v_orig),w(w_orig);
15049     int s1=int(v.size()),s2=int(w.size());
15050     bool vmat=ckmatrix(v),wmat=ckmatrix(w);
15051     if (vmat){
15052       if (s1!=1)
15053 	v=mtran(v);
15054       v=*v.front()._VECTptr;
15055       s1=int(v.size());
15056     }
15057     if (wmat){
15058       if (s2!=1)
15059 	w=mtran(w);
15060       w=*w.front()._VECTptr;
15061       s2=int(w.size());
15062     }
15063     if (s1==2){
15064       v.push_back(0);
15065       ++s1;
15066     }
15067     if (s2==2){
15068       w.push_back(0);
15069       ++s2;
15070     }
15071     if (s1!=3 || s2!=3)
15072       return vecteur(1,gendimerr(gettext("cross")));
15073     vecteur res;
15074     res.push_back(operator_times(v[1],w[2],contextptr)-operator_times(v[2],w[1],contextptr));
15075     res.push_back(operator_times(v[2],w[0],contextptr)-operator_times(v[0],w[2],contextptr));
15076     res.push_back(operator_times(v[0],w[1],contextptr)-operator_times(v[1],w[0],contextptr));
15077     if (vmat && wmat)
15078       return mtran(vecteur(1,res));
15079     return res;
15080   }
15081   /*
15082   vecteur cross(const vecteur & v_orig,const vecteur & w_orig){
15083     return cross(v_orig,w_orig,context0);
15084   }
15085   */
symb_cross(const gen & arg1,const gen & arg2)15086   gen symb_cross(const gen & arg1,const gen & arg2){
15087     return symbolic(at_cross,makesequence(arg1,arg2));
15088   }
symb_cross(const gen & args)15089   gen symb_cross(const gen & args){
15090     return symbolic(at_cross,args);
15091   }
complex2vecteur(const gen & g,GIAC_CONTEXT)15092   gen complex2vecteur(const gen & g,GIAC_CONTEXT){
15093     if (g.type!=_VECT){
15094       gen x,y;
15095       reim(g,x,y,contextptr);
15096       return makevecteur(x,y);
15097     }
15098     return g;
15099   }
15100 
cross(const gen & a,const gen & b,GIAC_CONTEXT)15101   gen cross(const gen & a,const gen & b,GIAC_CONTEXT){
15102     gen g1=remove_at_pnt(a);
15103     if (a.type==_VECT && a.subtype==_GGB__VECT)
15104       g1=a;
15105     gen g2=remove_at_pnt(b);
15106     if (b.type==_VECT && b.subtype==_GGB__VECT)
15107       g2=b;
15108     if (g1.type!=_VECT || g2.type!=_VECT){
15109       g1=complex2vecteur(g1,contextptr);
15110       g2=complex2vecteur(g2,contextptr);
15111       if (g1._VECTptr->size()==2 && g2._VECTptr->size()==2)
15112 	return g1._VECTptr->front()*g2._VECTptr->back()-g1._VECTptr->back()*g2._VECTptr->front();
15113       if (g1._VECTptr->size()==2)
15114 	g1=makevecteur(g1._VECTptr->front(),g1._VECTptr->back(),0);
15115       if (g2._VECTptr->size()==2)
15116 	g2=makevecteur(g2._VECTptr->front(),g2._VECTptr->back(),0);
15117     }
15118     if (is_undef(g1) || g1.type!=_VECT || is_undef(g2) || g2.type!=_VECT)
15119       return gensizeerr(gettext("cross"));
15120     if (g1.subtype==_VECTOR__VECT && g2.subtype==_VECTOR__VECT)
15121       return _vector(cross(vector2vecteur(*g1._VECTptr),g2,contextptr),contextptr);
15122     if (g1.subtype==_VECTOR__VECT)
15123       return cross(vector2vecteur(*g1._VECTptr),g2,contextptr);
15124     if (g2.subtype==_VECTOR__VECT)
15125       return cross(g1,vector2vecteur(*g2._VECTptr),contextptr);
15126     if (g1._VECTptr->size()==2 && g2._VECTptr->size()==2 && calc_mode(contextptr)==1)
15127       return g1._VECTptr->front()*g2._VECTptr->back()-g1._VECTptr->back()*g2._VECTptr->front();
15128     return cross(*g1._VECTptr,*g2._VECTptr,contextptr);
15129   }
15130   /*
15131   gen cross(const gen & a,const gen & b){
15132     return cross(a,b,context0);
15133   }
15134   */
_cross(const gen & args,GIAC_CONTEXT)15135   gen _cross(const gen &args,GIAC_CONTEXT){
15136     if (args.type==_STRNG && args.subtype==-1) return args;
15137     if (args.type!=_VECT)
15138       return symb_cross(args);
15139     if (args._VECTptr->size()!=2)
15140       return gendimerr(contextptr);
15141     gen res=cross(args._VECTptr->front(),args._VECTptr->back(),contextptr);
15142     if (res.type==_VECT)
15143       res.subtype=args._VECTptr->front().subtype;
15144     return res;
15145   }
15146   static const char _cross_s []="cross";
texprintascross(const gen & feuille,const char * sommetstr,GIAC_CONTEXT)15147   string texprintascross(const gen & feuille,const char * sommetstr,GIAC_CONTEXT){
15148     return texprintsommetasoperator(feuille," \\wedge ",contextptr);
15149   }
15150   static define_unary_function_eval4 (__cross,&_cross,_cross_s,0,texprintascross);
15151   define_unary_function_ptr5( at_cross ,alias_at_cross,&__cross,0,true);
15152 
printassize(const gen & feuille,const char * sommetstr,GIAC_CONTEXT)15153   static string printassize(const gen & feuille,const char * sommetstr,GIAC_CONTEXT){
15154     string res(sommetstr);
15155     if (xcas_mode(contextptr)>0)
15156       res="nops";
15157     return res+"("+feuille.print(contextptr)+")";
15158   }
symb_size(const gen & args)15159   gen symb_size(const gen & args){
15160     return symbolic(at_size,args);
15161   }
_size(const gen & args,GIAC_CONTEXT)15162   gen _size(const gen &args,GIAC_CONTEXT){
15163     if (args.type==_STRNG && args.subtype==-1) return args;
15164     if (args.type==_STRNG)
15165       return (int) args._STRNGptr->size();
15166     if (args.type==_SYMB){
15167       if (args._SYMBptr->feuille.type==_VECT)
15168 	return (int) args._SYMBptr->feuille._VECTptr->size();
15169       else
15170 	return 1;
15171     }
15172     if (args.type==_POLY)
15173       return int(args._POLYptr->coord.size());
15174     if (args.type!=_VECT)
15175       return 1;
15176     int s=(int) args._VECTptr->size();
15177     if (args.subtype==_SEQ__VECT){
15178       if (0 && s==2){
15179 	if (args._VECTptr->back()==-1)
15180 	  return tailles(args._VECTptr->front());
15181 	return int(taille(args._VECTptr->front(),0));
15182       }
15183       if (s==0)
15184 	return tailles(*_VARS(-2,contextptr)._VECTptr);
15185     }
15186     return s;
15187   }
15188   static const char _size_s []="size";
15189   static define_unary_function_eval2 (__size,&_size,_size_s,&printassize);
15190   define_unary_function_ptr5( at_size ,alias_at_size,&__size,0,true);
15191 
15192 #ifdef HAVE_LIBGSL
15193 
vecteur2gsl_vector(const_iterateur it,const_iterateur itend,gsl_vector * w,GIAC_CONTEXT)15194   int vecteur2gsl_vector(const_iterateur it,const_iterateur itend,gsl_vector * w,GIAC_CONTEXT){
15195 #ifdef DEBUG_SUPPORT
15196     if (itend-it!=signed(w->size))
15197       setsizeerr(gettext("vecteur.cc vecteur2gsl_vector"));
15198 #endif
15199     gen g;
15200     int res=GSL_SUCCESS;
15201     for (int i = 0; it!=itend; ++i,++it){
15202       g=it->evalf(1,contextptr);
15203       if (g.type==_DOUBLE_)
15204 	gsl_vector_set (w, i, g._DOUBLE_val);
15205       else {
15206 	gsl_vector_set (w, i, nan());
15207 	res=!GSL_SUCCESS;
15208       }
15209     }
15210     return res;
15211   }
15212 
vecteur2gsl_vector(const vecteur & v,gsl_vector * w,GIAC_CONTEXT)15213   int vecteur2gsl_vector(const vecteur & v,gsl_vector * w,GIAC_CONTEXT){
15214     const_iterateur it=v.begin(),itend=v.end();
15215     return vecteur2gsl_vector(it,itend,w,contextptr);
15216   }
15217   // this function allocate all space needed for the gsl_vector
vecteur2gsl_vector(const vecteur & v,GIAC_CONTEXT)15218   gsl_vector * vecteur2gsl_vector(const vecteur & v,GIAC_CONTEXT){
15219     const_iterateur it=v.begin(),itend=v.end();
15220     gsl_vector * w = gsl_vector_alloc (itend-it);
15221     vecteur2gsl_vector(it,itend,w,contextptr);
15222     return w;
15223   }
15224 
15225   // this function does not deallocate the gsl vector
15226   // call gsl_vector_free(v) for this
gsl_vector2vecteur(const gsl_vector * v)15227   vecteur gsl_vector2vecteur(const gsl_vector * v){
15228     vecteur res;
15229     int s=v->size;
15230     res.reserve(s);
15231     for (int i=0;i<s;++i)
15232       res.push_back(gsl_vector_get(v,i));
15233     return res;
15234   }
15235 
matrice2gsl_matrix(const matrice & m,gsl_matrix * w,GIAC_CONTEXT)15236   int matrice2gsl_matrix(const matrice & m,gsl_matrix * w,GIAC_CONTEXT){
15237     int s1=w->size1,s2=w->size2;
15238 #ifdef DEBUG_SUPPORT
15239     ckmatrix(m);
15240     if (mrows(m)!=s1 || mcols(m)!=s2)
15241       setdimerr();
15242 #endif
15243     gen g;
15244     const_iterateur it=m.begin(),itend=m.end();
15245     int res=GSL_SUCCESS;
15246     for (int i = 0; it!=itend; ++i,++it){
15247       if (it->type!=_VECT)
15248 	res=!GSL_SUCCESS;
15249       vecteur & v =*it->_VECTptr;
15250       const_iterateur jt=v.begin(),jtend=v.end();
15251       for (int j=0;jt!=jtend;++j,++jt){
15252 	g=evalf(*jt,1,contextptr);
15253 	if (g.type==_DOUBLE_)
15254 	  gsl_matrix_set(w,i,j,g._DOUBLE_val);
15255 	else {
15256 	  res=!GSL_SUCCESS;
15257 	  gsl_matrix_set(w,i,j,nan());
15258 	}
15259       }
15260     }
15261     return res;
15262   }
15263 
15264   // this function allocate all space needed for the gsl_matrix
matrice2gsl_matrix(const matrice & m,GIAC_CONTEXT)15265   gsl_matrix * matrice2gsl_matrix(const matrice & m,GIAC_CONTEXT){
15266     int n1=mrows(m),n2=mcols(m);
15267     gsl_matrix * w = gsl_matrix_alloc (n1,n2);
15268     matrice2gsl_matrix(m,w,contextptr);
15269     return w;
15270   }
15271 
15272   // this function does not deallocate the gsl vector
15273   // call gsl_matrix_free(v) for this
gsl_matrix2matrice(const gsl_matrix * v)15274   matrice gsl_matrix2matrice(const gsl_matrix * v){
15275     matrice res;
15276     int s1=v->size1,s2=v->size2;
15277     res.reserve(s1);
15278     for (int i=0;i<s1;++i){
15279       vecteur tmp;
15280       tmp.reserve(s2);
15281       for (int j=0;j<s2;++j){
15282 	tmp.push_back(gsl_matrix_get(v,i,j));
15283       }
15284       res.push_back(tmp);
15285     }
15286     return res;
15287   }
15288 
gsl_permutation2vecteur(const gsl_permutation * p,GIAC_CONTEXT)15289   vecteur gsl_permutation2vecteur(const gsl_permutation * p,GIAC_CONTEXT){
15290     int s=p->size;
15291     vecteur res(s);
15292     for (int i=0;i<s;++i)
15293       res[i]=(int)gsl_permutation_get(p,i)+(xcas_mode(contextptr)?1:0);
15294     return res;
15295   }
15296 #endif // HAVE_LIBGSL
15297 
mlu(const matrice & a0,vecteur & P,matrice & L,matrice & U,GIAC_CONTEXT)15298   bool mlu(const matrice & a0,vecteur & P,matrice & L,matrice & U,GIAC_CONTEXT){
15299     matrice a(a0);
15300     bool modular=false;
15301     if (!ckmatrix(a)){ // activate non-square matrix (instead of is_squarematrix)
15302       if (a.front().type==_VECT && !a.front()._VECTptr->empty() && (a.back()==at_irem || a.back()==at_ichinrem)){
15303 	modular=true;
15304 	a=*a.front()._VECTptr;
15305       }
15306       if (!ckmatrix(a)) return false; // setsizeerr(gettext("Expecting a square matrix"));
15307     }
15308     gen det;
15309     vecteur pivots;
15310     matrice res;
15311     int s=int(a.size()),C=int(a.front()._VECTptr->size());
15312     if (!mrref(a,res,pivots,det,0,s,0,C,
15313 	  /* fullreduction */0,0,false,(modular?3:0) /* algorithm */,2 /* lu */,
15314 	       contextptr))
15315       return false;
15316     if (pivots.empty())
15317       return false;
15318     gen tmp=pivots.back();
15319     if (tmp.type!=_VECT)
15320       return false; // setsizeerr();
15321     P=*tmp._VECTptr;
15322     // Make L and U from res
15323     L.reserve(s); U.reserve(s);
15324     for (int i=0;i<s;++i){
15325       vecteur & v=*res[i]._VECTptr;
15326       L.push_back(new ref_vecteur(s));
15327       vecteur & wl=*L.back()._VECTptr;
15328       for (int j=0;j<i && j<C;++j){ // L part
15329 	wl[j]=v[j];
15330       }
15331       wl[i]=1;
15332       U.push_back(new ref_vecteur(C));
15333       vecteur & wu=*U.back()._VECTptr;
15334       for (int j=i;j<C;++j){ // U part
15335 	wu[j]=v[j];
15336       }
15337     }
15338     return true;
15339   }
15340 
15341   // in: l= r rows, c cols
15342   // out: l= r,r and u=r rows, c cols
splitlu(matrice & l,matrice & u)15343   void splitlu(matrice & l,matrice & u){
15344     u=l;
15345     int r,c;
15346     mdims(l,r,c);
15347     for (int i=0;i<r;++i){
15348       vecteur li=*l[i]._VECTptr;
15349       li.resize(r);
15350       vecteur & ui=*u[i]._VECTptr;
15351       for (int j=0;j<i;++j){
15352 	ui[j]=0;
15353       }
15354       li[i]=1;
15355       for (int j=i+1;j<r;++j){
15356 	li[j]=0;
15357       }
15358       l[i]=li;
15359     }
15360   }
15361 
lu(const gen & args,GIAC_CONTEXT)15362   gen lu(const gen &args,GIAC_CONTEXT){
15363     if (args.type==_MAP){
15364       gen_map l_,u_; vector<int> permutation;
15365       gen l(l_),u(u_);
15366       if (!sparse_lu(*args._MAPptr,permutation,*l._MAPptr,*u._MAPptr))
15367 	return gensizeerr(contextptr);
15368       vecteur P;
15369       vector_int2vecteur(permutation,P);
15370       return makevecteur(P,l,u);
15371     }
15372     matrice L,U,P;
15373     if (abs_calc_mode(contextptr)!=38){
15374 #ifdef HAVE_LIBLAPACK
15375       if (ckmatrix(args) && is_fully_numeric(args) && int(args._VECTptr->size())>=CALL_LAPACK){
15376 
15377 	/* DGETRF( M, N, A, LDA, IPIV, INFO ), ZGETRF( M, N, A, LDA, IPIV, INFO )
15378 	 *  Purpose
15379 	 *  =======
15380 	 *
15381 	 *  DGETRF/ZGETRF computes an LU factorization of a general M-by-N matrix A
15382 	 *  using partial pivoting with row interchanges.
15383 	 *
15384 	 *  The factorization has the form
15385 	 *     A = P * L * U
15386 	 *  where P is a permutation matrix, L is lower triangular with unit
15387 	 *  diagonal elements (lower trapezoidal if m > n), and U is upper
15388 	 *  triangular (upper trapezoidal if m < n).
15389 	 *
15390 	 *  This is the right-looking Level 3 BLAS version of the algorithm.
15391 	 *
15392 	 *  Arguments
15393 	 *  =========
15394 	 *
15395 	 *  M       (input) INTEGER
15396 	 *          The number of rows of the matrix A.  M >= 0.
15397 	 *
15398 	 *  N       (input) INTEGER
15399 	 *          The number of columns of the matrix A.  N >= 0.
15400 	 *
15401 	 *  A       (input/output) DOUBLE PRECISION/COMPLEX array, dimension (LDA,N)
15402 	 *          On entry, the M-by-N matrix to be factored.
15403 	 *          On exit, the factors L and U from the factorization
15404 	 *          A = P*L*U; the unit diagonal elements of L are not stored.
15405 	 *
15406 	 *  LDA     (input) INTEGER
15407 	 *          The leading dimension of the array A.  LDA >= max(1,M).
15408 	 *
15409 	 *  IPIV    (output) INTEGER array, dimension (min(M,N))
15410 	 *          The pivot indices; for 1 <= i <= min(M,N), row i of the
15411 	 *          matrix was interchanged with row IPIV(i).
15412 	 */
15413 	integer M,N,LDA,INFO;
15414 	int m,n;
15415 	mdims(*args._VECTptr,m,n);
15416 	int mn=giacmin(m,n);
15417 	M=m; N=n;
15418 	LDA=M;
15419 	integer * IPIV=new integer[mn];
15420 	for (int i=0;i<mn;++i)
15421 	  P.push_back(i+1);
15422 	if (is_zero(im(args,contextptr))){
15423 	  double * A = new double[M*N];
15424 	  matrice2lapack(*args._VECTptr,A,contextptr);
15425 	  dgetrf_( &M, &N, A, &LDA, IPIV, &INFO );
15426 	  if (INFO){
15427 	    delete [] IPIV;
15428 	    delete [] A;
15429 	    return gensizeerr(gettext("LAPACK LU error"));
15430 	  }
15431 	  lapack2matrice(A,M,N,L);
15432 	  // get U from upper part of L and clear
15433 	  splitlu(L,U);
15434 	  // get P
15435 	  for (int i=1;i<mn;++i){
15436 	    if (IPIV[i-1]!=i)
15437 	      swapgen(P[i-1],P[IPIV[i-1]-1]);
15438 	  }
15439 	  if (array_start(contextptr)){
15440 	    for (int i=0;i<mn;++i)
15441 	      P[i] -= 1;
15442 	  }
15443 	  delete [] IPIV;
15444 	  delete [] A;
15445 	  return gen(makevecteur(P,L,U),_SEQ__VECT);
15446 	}
15447 	doublef2c_complex * A = new doublef2c_complex[M*N];
15448 	matrice2zlapack(*args._VECTptr,A,contextptr);
15449 	zgetrf_( &M, &N, A, &LDA, IPIV, &INFO );
15450 	if (INFO){
15451 	  delete [] IPIV;
15452 	  delete [] A;
15453 	  return gensizeerr(gettext("LAPACK LU error"));
15454 	}
15455 	zlapack2matrice(A,M,N,L);
15456 	// get U from upper part of L and clear
15457 	splitlu(L,U);
15458 	// get P
15459 	for (int i=1;i<mn;++i){
15460 	  if (IPIV[i-1]!=i)
15461 	    swapgen(P[i-1],P[IPIV[i-1]-1]);
15462 	}
15463 	if (array_start(contextptr)){
15464 	  for (int i=0;i<mn;++i)
15465 	    P[i] -= 1;
15466 	}
15467 	delete [] IPIV;
15468 	delete [] A;
15469 	return gen(makevecteur(P,L,U),_SEQ__VECT);
15470       } // end lapack call
15471 #endif
15472 #ifdef HAVE_LIBGSL
15473     bool gsl_lu = 0 && is_fully_numeric(args) && is_zero(im(args,contextptr),contextptr);
15474     if (gsl_lu){
15475       if (!is_squarematrix(args))
15476 	return gensizeerr(gettext("Expecting a square matrix"));
15477       gsl_matrix * m=matrice2gsl_matrix(*args._VECTptr,contextptr);
15478       int s1=m->size1;
15479       gsl_permutation * p=gsl_permutation_alloc (s1);
15480       int sign;
15481       gsl_linalg_LU_decomp (m, p,&sign);
15482       P=gsl_permutation2vecteur(p,contextptr);
15483       L.reserve(s1);
15484       U.reserve(s1);
15485       // get L and U
15486       for (int i=0;i<s1;++i){
15487 	vecteur l(s1),u(s1);
15488 	for (int j=0;j<i;++j){
15489 	  l[j]=gsl_matrix_get(m,i,j);
15490 	}
15491 	l[i]=1.0;
15492 	for (int j=i;j<s1;++j){
15493 	  u[j]=gsl_matrix_get(m,i,j);
15494 	}
15495 	L.push_back(l);
15496 	U.push_back(u);
15497       }
15498       gsl_permutation_free(p);
15499       gsl_matrix_free(m);
15500       return gen(makevecteur(P,L,U),_SEQ__VECT);
15501     }
15502 #endif // HAVE_LIBGSL
15503     } // end abs_calc_mode!=38
15504     if (args.type!=_VECT)
15505       return gentypeerr(contextptr);
15506     // Giac LU decomposition
15507     if (!mlu(*args._VECTptr,P,L,U,contextptr))
15508       return gendimerr(contextptr);
15509     if (array_start(contextptr)){ //xcas_mode(contextptr) || abs_calc_mode(contextptr)==38){
15510       int s=int(P.size());
15511       for (int i=0;i<s;++i){
15512 	P[i]=P[i]+1;
15513       }
15514     }
15515     return gen(makevecteur(P,L,U),_SEQ__VECT);
15516   }
15517   static const char _lu_s []="lu";
15518   static define_unary_function_eval (__lu,&lu,_lu_s);
15519   define_unary_function_ptr5( at_lu ,alias_at_lu,&__lu,0,true);
15520 
matrice2lapack(const matrice & m,double * A,GIAC_CONTEXT)15521   bool matrice2lapack(const matrice & m,double * A,GIAC_CONTEXT){
15522     const_iterateur it=m.begin(),itend=m.end();
15523     gen g;
15524     int rows=int(itend-it);
15525     for (int i = 0; it!=itend; ++i,++it){
15526       if (it->type!=_VECT)
15527 	return false;
15528       vecteur & v =*it->_VECTptr;
15529       const_iterateur jt=v.begin(),jtend=v.end();
15530       for (int j = 0; jt!=jtend;++j, ++jt){
15531 	g=evalf_double(*jt,1,contextptr);
15532 	if (g.type==_DOUBLE_)
15533 	  A[i + j * rows] = g._DOUBLE_val;
15534 	else
15535 	  return false;
15536       }
15537     }
15538     return true;
15539   }
15540 
lapack2matrice(double * A,unsigned rows,unsigned cols,matrice & R)15541   void lapack2matrice(double * A,unsigned rows,unsigned cols,matrice & R){
15542     R.reserve(rows);
15543     for (unsigned i=0;i<rows;++i){
15544       gen tmp(new ref_vecteur(cols));
15545       vecteur &r=*tmp._VECTptr;
15546       for (unsigned j=0;j<cols;++j)
15547 	r[j] = A[i + j * rows];
15548       R.push_back(tmp);
15549     }
15550   }
15551 
qr(const gen & args_orig,GIAC_CONTEXT)15552   gen qr(const gen &args_orig,GIAC_CONTEXT){
15553     gen args;
15554     int method=0; // use -1 to check built-in qr
15555 #if !defined(HAVE_LIBLAPACK) || !defined (HAVE_LIBGSL)
15556     method=-3;
15557 #endif
15558     if ( (args_orig.type==_VECT) && (args_orig._VECTptr->size()==2) && (args_orig._VECTptr->back().type==_INT_)){
15559       args=args_orig._VECTptr->front();
15560       method=args_orig._VECTptr->back().val;
15561     }
15562     else
15563       args=args_orig;
15564     if (!ckmatrix(args))
15565       return symbolic(at_qr,args);
15566     int rows = mrows(*args._VECTptr), cols = mcols(*args._VECTptr);
15567     if (rows < cols)
15568       method=-3;
15569     // if (!is_zero(im(args,contextptr),contextptr)) return gensizeerr(gettext("Complex entry!"));
15570     bool cplx=false;
15571     if (method<0 || !is_fully_numeric(evalf_double(args,1,contextptr)) || (cplx=!is_zero(im(args,contextptr),contextptr)) ){
15572       matrice r;
15573       if (is_fully_numeric(args)){
15574 	// qr decomposition using rotations, numerically stable
15575 	// but not suited to exact computations
15576 	matrice h=*args._VECTptr,p(midn(int(h.size())));
15577 	std_matrix<gen> H,P;
15578 	matrice2std_matrix_gen(h,H);
15579 	matrice2std_matrix_gen(p,P);
15580 	qr_ortho(H,P,true,contextptr);
15581 	std_matrix_gen2matrice_destroy(H,h);
15582 	std_matrix_gen2matrice_destroy(P,p);
15583 	if (method<=-3)
15584 	  return makevecteur(_trn(p,contextptr),h);
15585 	else
15586 	  return makevecteur(_trn(p,contextptr),h,midn(int(h.size())));
15587       }
15588       // qr decomposition using GramSchmidt (not numerically stable)
15589       matrice res(gramschmidt(*_trn(args,contextptr)._VECTptr,r,cplx || method==-1 || method==-3,contextptr));
15590       if (method<=-3)
15591 	return gen(makevecteur(_trn(res,contextptr),r),_SEQ__VECT);
15592       else
15593 	return gen(makevecteur(_trn(res,contextptr),r,midn(int(r.size()))),_SEQ__VECT);
15594     }
15595 #ifdef HAVE_LIBLAPACK
15596     if (!CAN_USE_LAPACK
15597 #ifndef POCKETCAS
15598 	|| dgeqrf_ == NULL
15599 	|| dorgqr_ == NULL
15600 #endif
15601 	|| &dgeqrf_ == NULL
15602 	|| &dorgqr_ == NULL)
15603       return gensizeerr(gettext("LAPACK not available"));
15604 
15605     const matrice &m = *args._VECTptr;
15606     integer info;
15607     double *A = new double[rows * cols];
15608     if (!matrice2lapack(m,A,contextptr))
15609       return gensizeerr(gettext("Lapack conversion error"));
15610     double *tau = new double[cols];
15611     integer lwork = -1;
15612     double worktmp;
15613     if (!is_zero(im(args,contextptr))){
15614       // complex QR decomposition, currently disabled above
15615     }
15616     // first call to determine optimum work vector size lwork
15617     dgeqrf_(&rows, &cols, A, &rows, tau, &worktmp, &lwork, &info);
15618     if (info){
15619       delete [] A;
15620       delete [] tau;
15621       return gensizeerr(gettext("LAPACK error ") + (-info));
15622     }
15623 
15624     lwork = (int)worktmp;
15625     double *work = new double[lwork];
15626 
15627     // second call, computes the QR-decomposition
15628     dgeqrf_(&rows, &cols, A, &rows, tau, work, &lwork, &info);
15629     if (info){
15630       delete [] A;
15631       delete [] tau;
15632       delete [] work;
15633       return gensizeerr(gettext("LAPACK error ") + (-info));
15634     }
15635 
15636     // load R from the upper right part of A
15637     matrice R;
15638     R.reserve(rows);
15639     for (int i=0;i<rows;++i){
15640       vecteur r(cols);
15641       for (int j=i;j<cols;++j)
15642 	r[j] = A[i + j * rows];
15643       R.push_back(r);
15644     }
15645 
15646     // compute Q and store it in A
15647     dorgqr_(&rows, &cols, &cols, A, &rows, tau, work, &lwork, &info);
15648     delete [] tau;
15649     delete [] work;
15650     if (info){
15651       delete [] A;
15652       return gensizeerr(gettext("LAPACK error ") + (-info));
15653     }
15654 
15655     // load Q from A
15656     matrice Q;
15657     Q.reserve(rows);
15658     for (int i=0;i<rows;++i){
15659       vecteur q(cols);
15660       for (int j=0;j<cols;++j)
15661 	q[j] = A[i + j * rows];
15662       Q.push_back(q);
15663     }
15664 
15665     delete [] A;
15666 
15667     // I prefer to get Q and R returned. Your mileage may vary.
15668     return gen(makevecteur(Q,R),_SEQ__VECT);
15669 #endif // HAVE_LIBLAPACK
15670 #ifdef HAVE_LIBGSL
15671     {
15672     gsl_matrix * m=matrice2gsl_matrix(*args._VECTptr,contextptr);
15673     int s1=m->size1,s2=m->size2;
15674     gsl_vector * tau=gsl_vector_alloc(giacmin(s1,s2));
15675     gsl_linalg_QR_decomp (m,tau);
15676     matrice R;
15677     R.reserve(s1);
15678     // get R
15679     for (int i=0;i<s1;++i){
15680       vecteur r(s2);
15681       for (int j=i;j<s2;++j){
15682 	r[j]=gsl_matrix_get(m,i,j);
15683       }
15684       R.push_back(r);
15685     }
15686     // get the list of tau_i,v_i
15687     vecteur Q;
15688     for (int i=0;i<signed(tau->size);++i){
15689       vecteur tmp(m->size2);
15690       tmp[i]=1.0;
15691       for (int j=i+1;j<signed(m->size2);++j)
15692 	tmp[j]=gsl_matrix_get(m,j,i);
15693       Q.push_back(makevecteur(gsl_vector_get(tau,i),tmp));
15694     }
15695     gsl_vector_free(tau);
15696     gsl_matrix_free(m);
15697     return gen(makevecteur(Q,R),_SEQ__VECT);
15698     //return R;
15699     }
15700 #endif // HAVE_LIBGSL
15701 
15702     return symbolic(at_qr,args);
15703   }
15704   static const char _qr_s []="qr";
15705   static define_unary_function_eval (__qr,&qr,_qr_s);
15706   define_unary_function_ptr5( at_qr ,alias_at_qr,&__qr,0,true);
15707 
thrownulllines(const matrice & res)15708   matrice thrownulllines(const matrice & res){
15709     int i=int(res.size())-1;
15710     for (;i>=0;--i){
15711       if (!is_zero(res[i],context0))
15712 	break;
15713     }
15714     return vecteur(res.begin(),res.begin()+i+1);
15715   }
_basis(const gen & args,GIAC_CONTEXT)15716   gen _basis(const gen &args,GIAC_CONTEXT){
15717     if (args.type==_STRNG && args.subtype==-1) return args;
15718     if (!ckmatrix(args))
15719       return symbolic(at_basis,args);
15720     matrice res=mrref(*args._VECTptr,contextptr);
15721     return gen(thrownulllines(res),_SET__VECT);
15722   }
15723   static const char _basis_s []="basis";
15724   static define_unary_function_eval (__basis,&_basis,_basis_s);
15725   define_unary_function_ptr5( at_basis ,alias_at_basis,&__basis,0,true);
15726 
sylvester(const vecteur & v1,const vecteur & v2,matrice & res)15727   void sylvester(const vecteur & v1,const vecteur & v2,matrice & res){
15728     int m=int(v1.size())-1;
15729     int n=int(v2.size())-1;
15730     if (m<0 || n<0){
15731       res.clear(); return;
15732     }
15733     res.resize(m+n);
15734     for (int i=0;i<n;++i){
15735       res[i]=new ref_vecteur(m+n);
15736       vecteur & w=*res[i]._VECTptr;
15737       for (int j=0;j<=m;++j)
15738 	w[i+j]=v1[j];
15739     }
15740     for (int i=0;i<m;++i){
15741       res[n+i]=new ref_vecteur(m+n);
15742       vecteur & w=*res[n+i]._VECTptr;
15743       for (int j=0;j<=n;++j)
15744 	w[i+j]=v2[j];
15745     }
15746   }
15747 
15748   // Sylvester matrix, in lines line0=v1 0...0, line1=0 v1 0...0, etc.
sylvester(const vecteur & v1,const vecteur & v2)15749   matrice sylvester(const vecteur & v1,const vecteur & v2){
15750     matrice res;
15751     sylvester(v1,v2,res);
15752     return res;
15753   }
15754 
_sylvester(const gen & args,GIAC_CONTEXT)15755   gen _sylvester(const gen &args,GIAC_CONTEXT){
15756     if (args.type==_STRNG && args.subtype==-1) return args;
15757     if (args.type!=_VECT || args._VECTptr->size()<2)
15758       return gensizeerr(contextptr);
15759     vecteur & v = *args._VECTptr;
15760     gen x(vx_var);
15761     if (v.size()>2)
15762       x=v[2];
15763     gen p1(_e2r(makesequence(v[0],x),contextptr));
15764     gen p2(_e2r(makesequence(v[1],x),contextptr));
15765     if (p1.type==_FRAC)
15766       p1=inv(p1._FRACptr->den,contextptr)*p1._FRACptr->num;
15767     if (p2.type==_FRAC)
15768       p2=inv(p2._FRACptr->den,contextptr)*p2._FRACptr->num;
15769     if (p1.type!=_VECT || p2.type!=_VECT)
15770       return gensizeerr(contextptr);
15771     vecteur & v1 =*p1._VECTptr;
15772     vecteur & v2 =*p2._VECTptr;
15773     return sylvester(v1,v2);
15774   }
15775   static const char _sylvester_s []="sylvester";
15776   static define_unary_function_eval (__sylvester,&_sylvester,_sylvester_s);
15777   define_unary_function_ptr5( at_sylvester ,alias_at_sylvester,&__sylvester,0,true);
15778 
_ibasis(const gen & args,GIAC_CONTEXT)15779   gen _ibasis(const gen &args,GIAC_CONTEXT){
15780     if (args.type==_STRNG && args.subtype==-1) return args;
15781     if ( (args.type!=_VECT) || (args._VECTptr->size()!=2) )
15782       return symbolic(at_basis,args);
15783     gen g=args._VECTptr->front(),h=args._VECTptr->back();
15784     if (!ckmatrix(g) || !ckmatrix(h))
15785       return gensizeerr(contextptr);
15786     vecteur & v1=*g._VECTptr;
15787     vecteur & v2=*h._VECTptr;
15788     if (v1.empty() || v2.empty())
15789       return vecteur(0);
15790     vecteur v=mker(mtran(mergevecteur(v1,v2)),contextptr);
15791     if (is_undef(v)) return v;
15792     // if v is not empty compute each corresponding vector of the basis
15793     int s=int(v1.size());
15794     int l=int(v1.front()._VECTptr->size());
15795     matrice res;
15796     const_iterateur it=v.begin(),itend=v.end();
15797     for (;it!=itend;++it){
15798       vecteur tmp(l);
15799       vecteur & i=*it->_VECTptr;
15800       for (int j=0;j<s;++j)
15801 	tmp=addvecteur(tmp,multvecteur(i[j],*v1[j]._VECTptr));
15802       res.push_back(tmp);
15803     }
15804     return gen(thrownulllines(mrref(res,contextptr)),_SET__VECT);
15805   }
15806   static const char _ibasis_s []="ibasis";
15807   static define_unary_function_eval (__ibasis,&_ibasis,_ibasis_s);
15808   define_unary_function_ptr5( at_ibasis ,alias_at_ibasis,&__ibasis,0,true);
15809 
sort_eigenvals(matrice & p,matrice & d,bool ascend,GIAC_CONTEXT)15810   void sort_eigenvals(matrice & p,matrice & d,bool ascend,GIAC_CONTEXT){
15811     matrice pt; mtran(p,pt);
15812     vecteur D; D.reserve(d.size());
15813     for (int i=0;i<int(d.size());++i){
15814       gen tmp=makevecteur(d[i][i],pt[i]);
15815       D.push_back(tmp);
15816     }
15817     gen_sort_f_context(D.begin(),D.end(),complex_sort,contextptr);
15818     if (!ascend)
15819       reverse(D.begin(),D.end());
15820     for (int i=0;i<int(D.size());++i){
15821       gen tmp=D[i];
15822       (*d[i]._VECTptr)[i]=tmp[0];
15823       pt[i]=tmp[1];
15824     }
15825     mtran(pt,p);
15826   }
15827 
_svd(const gen & args_orig,GIAC_CONTEXT)15828   gen _svd(const gen &args_orig,GIAC_CONTEXT){
15829     if (args_orig.type==_STRNG && args_orig.subtype==-1) return args_orig;
15830     gen args;
15831     int method=0; // use -1 to check built-in svd, -2 for svl (singular values only)
15832     if ( (args_orig.type==_VECT) && (args_orig._VECTptr->size()==2) && (args_orig._VECTptr->back().type==_INT_)){
15833       args=args_orig._VECTptr->front();
15834       method=args_orig._VECTptr->back().val;
15835     }
15836     else
15837       args=args_orig;
15838     if (!ckmatrix(args))
15839       return symbolic(at_svd,args);
15840     // if (!is_zero(im(args,contextptr),contextptr)) return gensizeerr(gettext("Complex entry!"));
15841     if (!has_num_coeff(args))
15842       *logptr(contextptr) << gettext("Warning: svd is implemented for numeric matrices") << '\n';
15843     gen argsf=args;
15844     bool real=is_zero(im(argsf,contextptr));
15845     if (real && method>=0 && is_fully_numeric( (argsf=evalf_double(args,1,contextptr)) )){
15846 #ifdef HAVE_LIBLAPACK
15847       if (!CAN_USE_LAPACK
15848 #ifndef POCKETCAS
15849 	  || dgeqrf_ == NULL
15850 	  || dorgqr_ == NULL
15851 #endif
15852 	  || &dgeqrf_ == NULL
15853 	  || &dorgqr_ == NULL)
15854 	return gensizeerr(gettext("LAPACK not available"));
15855 
15856       const matrice &m = *args._VECTptr;
15857       gen g;
15858       // const_iterateur it=m.begin(),itend=m.end();
15859       integer rows = mrows(m), cols = mcols(m);
15860       if (rows < cols)
15861 	return gendimerr(contextptr);
15862       double *A = new double[rows * cols];
15863       matrice2lapack(m,A,contextptr);
15864       integer info;
15865       char jobU = 'A', jobVT = 'A';
15866       double *S = new double[cols];
15867       double *U = new double[rows * rows];
15868       double *VT = new double[cols * cols];
15869       integer lwork = -1;
15870       double worktmp;
15871 
15872       // first call to determine optimum work vector size lwork
15873       dgesvd_(&jobU, &jobVT, &rows, &cols, A, &rows, S, U, &rows, VT, &cols, &worktmp, &lwork, &info);
15874       if (info){
15875 	delete [] A;
15876 	delete [] S;
15877 	delete [] U;
15878 	delete [] VT;
15879 	return gensizeerr(gettext("LAPACK error ") + (-info));
15880       }
15881 
15882       lwork = (int)worktmp;
15883       double *work = new double[lwork];
15884 
15885       // second call, computes the SVD
15886       dgesvd_(&jobU, &jobVT, &rows, &cols, A, &rows, S, U, &rows, VT, &cols, work, &lwork, &info);
15887       if (info){
15888 	delete [] A;
15889 	delete [] S;
15890 	delete [] U;
15891 	delete [] VT;
15892 	delete [] work;
15893 	setsizeerr(gettext("LAPACK error ") + (-info));
15894       }
15895 
15896       // load S
15897       vecteur s(cols);
15898       for (int j=0;j<cols;++j)
15899 	s[j] = S[j];
15900 
15901       // load U
15902       matrice mU;
15903       lapack2matrice(U,rows,rows,mU);
15904 
15905       // load VT
15906       matrice mVT;
15907       lapack2matrice(VT,cols,cols,mVT);
15908 
15909       delete [] A;
15910       delete [] S;
15911       delete [] U;
15912       delete [] VT;
15913       delete [] work;
15914 
15915       return gen(makevecteur(mU,s,mtran(mVT)),_SEQ__VECT);
15916 #endif // HAVE_LIBLAPACK
15917 #ifdef HAVE_LIBGSL
15918       if (1){
15919 	gsl_matrix * u=matrice2gsl_matrix(*args._VECTptr,contextptr);
15920 	int s1=u->size1,s2=u->size2;
15921 	gsl_vector * work=gsl_vector_alloc (s1);
15922 	gsl_matrix * v=gsl_matrix_alloc(s2,s2);
15923 	gsl_vector * s=gsl_vector_alloc(s1);
15924 	gsl_matrix * x=gsl_matrix_alloc(s1,s1);
15925 	switch(method){
15926 	case _GOLUB_REINSCH_MOD_DECOMP:
15927 	  gsl_linalg_SV_decomp_mod(u,x,v,s,work);
15928 	  break;
15929 	case _JACOBI_DECOMP:
15930 	  gsl_linalg_SV_decomp_jacobi(u,v,s);
15931 	  break;
15932 	default:
15933 	  gsl_linalg_SV_decomp (u, v,s,work);
15934 	  break;
15935 	}
15936 	gsl_vector_free(work);
15937 	gsl_matrix_free(x);
15938 	matrice U(gsl_matrix2matrice(u)),S(gsl_vector2vecteur(s)),V(gsl_matrix2matrice(v)); // A=U*S*tran(V)
15939 	gsl_matrix_free(u);
15940 	gsl_matrix_free(v);
15941 	gsl_vector_free(s);
15942 	return gen(makevecteur(U,S,V),_SEQ__VECT); // M=U*diag(S)*tran(V)
15943       }
15944 #endif // HAVE_LIBGSL
15945     }
15946     // non numeric code/also for complex
15947     if (!ckmatrix(argsf))
15948       return gensizeerr(contextptr);
15949     if (!lidnt(argsf).empty())
15950       *logptr(contextptr) << "Warning: SVD for symbolic matrix may fail!" << '\n';
15951     matrice M=*argsf._VECTptr;
15952     bool transposed=M.size()<M.front()._VECTptr->size();
15953     if (transposed){
15954       gen tM=_trn(M,contextptr);
15955       if (!ckmatrix(tM))
15956 	return gensizeerr(contextptr);
15957       M=*tM._VECTptr;
15958     }
15959     matrice tMM,p,d,Mp,invs,u;     vecteur svl;
15960     gen tMg=_trn(M,contextptr); // mtrn(*args._VECTptr,tm);
15961     if (!ckmatrix(tMg))
15962       return gensizeerr(contextptr);
15963     const matrice & tM=*tMg._VECTptr;
15964     if (M==tM){
15965       if (!egv(M,p,d,contextptr,true,false,false))
15966 	return gensizeerr(contextptr);
15967       mtran(p,u);
15968       for (unsigned i=0;i<d.size();++i){
15969 	vecteur vi=*d[i]._VECTptr;
15970 	gen & di=vi[i];
15971 	di=re(di,contextptr);
15972 	if (is_strictly_positive(-di,contextptr))
15973 	  u[i]=-u[i];
15974 	svl.push_back(abs(di,contextptr));
15975       }
15976       if (method==-2)
15977 	return svl;
15978       return gen(makevecteur(mtran(u),svl,p),_SEQ__VECT);
15979     }
15980     mmult(tM,M,tMM);
15981     if (!egv(tMM,p,d,contextptr,true,false,false))
15982       return gensizeerr(contextptr);
15983     // put 0 egvl at the beginning
15984     sort_eigenvals(p,d,true,contextptr);
15985     // should reorder eigenvalue (decreasing order)
15986     int s=int(d.size());
15987     gen svdmax2=d[s-1][s-1];
15988     gen eps=epsilon(contextptr);
15989     int smallsvl=0;
15990 #if 1
15991     gen smalleps=(s*s)*eps*svdmax2;
15992 #else
15993     for (int i=0;i<s-1;++i){
15994       if (is_greater(sqrt(eps,contextptr)*svdmax2,d[i][i],contextptr))
15995 	++smallsvl;
15996       else
15997 	break;
15998     }
15999     gen smalleps=s*pow(eps,inv(smallsvl?smallsvl:1,contextptr),contextptr)*svdmax2;
16000 #endif
16001     for (int i=0;i<s;++i){
16002       vecteur vi=*d[i]._VECTptr;
16003       gen & di=vi[i];
16004       di=re(di,contextptr);
16005       // replace this value by 0 if it is small
16006       if (is_greater(smalleps,di,contextptr)) {
16007 	di=0.0; smallsvl++;
16008       }
16009       di=sqrt(di,contextptr);
16010       svl.push_back(di);
16011       d[i]=vi;
16012     }
16013      if (smallsvl)
16014        *logptr(contextptr) << "Warning, ill-conditionned matrix, " << smallsvl << " small singular values were replaced by 0. Result is probably wrong." << '\n';
16015     if (method==-2){
16016       if (transposed){
16017 	int add0=int(M.size()-M.front()._VECTptr->size());
16018 	for (int i=0;i<add0;++i)
16019 	  svl.push_back(0);
16020       }
16021       return svl;
16022     }
16023     mmult(M,p,Mp);
16024 #if 0
16025     invs=d;
16026     for (int i=0;i<s;++i){
16027       invs[i]=*d[i]._VECTptr;
16028       gen & tmp=(*invs[i]._VECTptr)[i];
16029       tmp=inv(tmp,contextptr);
16030     }
16031     mmult(Mp,invs,u);
16032     int complete=u.size()-u.front()._VECTptr->size();
16033     if (complete>0){
16034       // complete u to a unitary matrix by adding columns
16035       matrice tu;
16036       unsigned n=u.size();
16037       // take random vectors from canonical basis
16038       while (1){
16039 	tu=*_trn(u,contextptr)._VECTptr;
16040 	vector<int> v(n);
16041 	for (unsigned i=0;i<n;++i)
16042 	  v[i]=i;
16043 	for (int i=0;i<complete;++i){
16044 	  int j=int((double(std_rand())*v.size())/RAND_MAX);
16045 	  vecteur tmp(n);
16046 	  tmp[v[j]]=1;
16047 	  tu.push_back(tmp);
16048 	  v.erase(v.begin()+j);
16049 	}
16050 	gen uqr=qr(makesequence(_trn(tu,contextptr),-1),contextptr);
16051 	if (uqr.type==_VECT && uqr._VECTptr->size()>=2 && is_squarematrix(uqr._VECTptr->front()) &&is_squarematrix((*uqr._VECTptr)[1]) ){
16052 	  u=*uqr._VECTptr->front()._VECTptr;
16053 	  tu=*_trn(u,contextptr)._VECTptr;
16054 	  vecteur r=*(*uqr._VECTptr)[1]._VECTptr;
16055 	  for (unsigned i=0;i<n;++i){
16056 	    tu[i]=divvecteur(*tu[i]._VECTptr,r[i][i]);
16057 	  }
16058 	  u=*_trn(tu,contextptr)._VECTptr;
16059 	  break;
16060 	}
16061       }
16062     }
16063 #else
16064     // M=u*s*trn(q), u and q unitary => tM*M=q*s^2*trn(q)
16065     // here tM*M=p*d^2*trn(p) so q=p is known, and u*s=M*q
16066     // since s is diagonal, u is obtained by dividing columns j of Mp by s[j]
16067     mtran(Mp,u);
16068     for (int i=0;i<s;++i){
16069       gen tmp=(*d[i]._VECTptr)[i];
16070       if (is_zero(tmp,contextptr)){ //is_greater(1e-8,tmp/(s*svdmax),contextptr)){
16071 	tmp=l2norm(*u[i]._VECTptr,contextptr);
16072       }
16073       if (!is_zero(tmp,contextptr)) tmp=inv(tmp,contextptr);
16074       u[i]=tmp*u[i];
16075     }
16076     reverse(u.begin(),u.end()); // put 0 SVD at the end
16077     mtran(u,Mp);
16078     // qr call required if 0 is a singular value
16079     gen tmp=qr(makesequence(Mp,-1),contextptr);
16080     if (tmp.type!=_VECT || tmp._VECTptr->size()!=3 || !ckmatrix(tmp._VECTptr->front()) || !ckmatrix(tmp[1]))
16081       return gensizeerr(contextptr);
16082     u=*tmp[0]._VECTptr;
16083     mtran(u,Mp);
16084     u=*tmp[1]._VECTptr;
16085     for (unsigned i=0;i<unsigned(u.size()) && int(i)<s;++i){
16086       if (is_strictly_positive(-u[i][i],contextptr))
16087 	Mp[i]=-Mp[i];
16088     }
16089     if (s<Mp.size()) Mp.erase(Mp.begin()+s,Mp.end());
16090     reverse(Mp.begin(),Mp.begin()+s);
16091     mtran(Mp,u);
16092 #endif
16093     if (transposed)
16094       return gen(makevecteur(p,svl,u),_SEQ__VECT);
16095     return gen(makevecteur(u,svl,p),_SEQ__VECT);
16096   }
16097   static const char _svd_s []="svd";
16098   static define_unary_function_eval (__svd,&_svd,_svd_s);
16099   define_unary_function_ptr5( at_svd ,alias_at_svd,&__svd,0,true);
16100 
_cholesky(const gen & _args,GIAC_CONTEXT)16101   gen _cholesky(const gen &_args,GIAC_CONTEXT){
16102     if (_args.type==_STRNG && _args.subtype==-1) return _args;
16103     if (!is_squarematrix(_args))
16104       return gensizeerr(contextptr);
16105     gen args;
16106     if (_args==_trn(_args,contextptr))
16107       args=_args;
16108     else
16109       args=(_args+_trn(_args,contextptr))/2;
16110 #ifdef HAVE_LIBGSL
16111     if (is_fully_numeric(args) && is_zero(im(args,contextptr),contextptr)){
16112       gsl_matrix * m=matrice2gsl_matrix(*args._VECTptr,contextptr);
16113       int s1=m->size1;
16114       int i=gsl_linalg_cholesky_decomp (m);
16115       if (i==GSL_EDOM)
16116 	return gensizeerr(gettext("Non positive definite"));
16117       // clear upper part
16118       for (i=0;i<s1;++i){
16119 	for (int j=i+1;j<s1;++j)
16120 	  gsl_matrix_set(m,i,j,0.0);
16121       }
16122       matrice LL(gsl_matrix2matrice(m));
16123       gsl_matrix_free(m);
16124       return LL;
16125     }
16126 #endif // HAVE_LIBGSL
16127     matrice &A=*args._VECTptr;
16128     int n=int(A.size()),j,k,l;
16129     std_matrix<gen> C(n,vecteur(n));
16130     for (j=0;j<n;j++) {
16131       gen s;
16132       for (l=j;l<n;l++) {
16133 	s=0;
16134 	for (k=0;k<j;k++) {
16135 	  if (is_zero(C[k][k],contextptr))
16136 	    return gensizeerr(gettext("Not invertible matrice"));
16137 	  //if (is_strictly_positive(-C[k][k])) setsizeerr(gettext("Not a positive define matrice"));
16138 	  s=s+C[l][k]*conj(C[j][k],contextptr)/C[k][k];
16139 	}
16140 	C[l][j]=ratnormal(A[l][j]-s,contextptr);
16141       }
16142     }
16143     for (k=0;k<n;k++) {
16144       gen c=normal(inv(sqrt(C[k][k],contextptr),contextptr),contextptr);
16145       for (j=k;j<n;j++) {
16146 	C[j][k]=C[j][k]*c;
16147       }
16148     }
16149     matrice Cmat;
16150     std_matrix_gen2matrice_destroy(C,Cmat);
16151     return Cmat;
16152 /*
16153     matrice & A = *args._VECTptr;
16154     int n=A.size(),j,k,l;
16155     // Use LU decomposition without line permutation
16156     matrice LU,pivots;
16157     gen det;
16158     mrref(A,LU,pivots,det,0,n,0,n,false,0,false,false,3,contextptr);
16159     if (is_zero(det)) return gensizeerr("Not a positive defined matrix");
16160     matrice D,L;
16161     for (int i=0;i<n;++i){
16162       vecteur v(n);
16163       v[i]=sqrt(LU[i][i]);
16164       D.push_back(v);
16165       vecteur w(n);
16166       w[i]=1;
16167       for (j=0;j<i;j++)
16168 	w[j]=LU[i][j];
16169       L.push_back(w);
16170     }
16171     return ckmultmatvecteur(L,D,contextptr);
16172 */
16173     /*
16174     std_matrix<gen> C(n,vecteur(n));
16175     for (j=0;j<n;++j){
16176       gen s;
16177       for (k=0;k<j;++k){
16178 	s=s+pow(C[j][k],2);
16179       }
16180       gen c2=A[j][j]-s;
16181       if (is_strictly_positive(-c2,contextptr))
16182 	return gensizeerr(contextptr"Not a positive defined matrix");
16183       gen c=normal(sqrt(c2,contextptr),contextptr);
16184       C[j][j]=c;
16185       for (l=j+1;l<n;++l){
16186 	s=0;
16187 	for (k=0;k<j;++k)
16188 	  s=s+C[l][k]*C[j][k];
16189 	C[l][j]=normal((A[l][j]-s)/c,contextptr);
16190       }
16191     }
16192     matrice Cmat;
16193     std_matrix_gen2matrice(C,Cmat);
16194     return Cmat;
16195     */
16196   }
16197   static const char _cholesky_s []="cholesky";
16198   static define_unary_function_eval (__cholesky,&_cholesky,_cholesky_s);
16199   define_unary_function_ptr5( at_cholesky ,alias_at_cholesky,&__cholesky,0,true);
16200 
l2norm(const vecteur & v,GIAC_CONTEXT)16201   gen l2norm(const vecteur & v,GIAC_CONTEXT){
16202     const_iterateur it=v.begin(),itend=v.end();
16203     gen res,r,i;
16204     for (;it!=itend;++it){
16205       reim(*it,r,i,contextptr);
16206       res += r*r+i*i;
16207     }
16208     return sqrt(res,contextptr);
16209   }
16210 
gramschmidt(const matrice & m,matrice & r,bool normalize,GIAC_CONTEXT)16211   matrice gramschmidt(const matrice & m,matrice & r,bool normalize,GIAC_CONTEXT){
16212     r.clear();
16213     vecteur v(m);
16214     int s=int(v.size());
16215     if (!s)
16216       return v;
16217     vecteur sc(1,dotvecteur(*conj(v[0],contextptr)._VECTptr,*v[0]._VECTptr));
16218     if (is_zero(sc.back()))
16219       return v;
16220     vecteur rcol0(s);
16221     rcol0[0]=1;
16222     r.push_back(rcol0);
16223     for (int i=1;i<s;++i){
16224       gen cl,coeff;
16225       vecteur rcol(s);
16226       rcol[i]=1;
16227       for (int j=0;j<i;++j){
16228 	coeff=rdiv(dotvecteur(*conj(v[j],contextptr)._VECTptr,*v[i]._VECTptr),sc[j],contextptr);
16229 	cl=cl+coeff*v[j];
16230 	rcol[j]=coeff;
16231       }
16232       v[i]=v[i]-cl;
16233       sc.push_back(dotvecteur(*conj(v[i],contextptr)._VECTptr,*v[i]._VECTptr));
16234       r.push_back(rcol);
16235       if (is_zero(sc.back(),contextptr))
16236 	break;
16237     }
16238     r=mtran(*conj(r,contextptr)._VECTptr); // transconjugate
16239     if (normalize){
16240       gen coeff;
16241       for (int i=0;i<s;++i){
16242 	if (is_zero(sc[i],contextptr))
16243 	  break;
16244 	coeff=sc[i]=sqrt(sc[i],contextptr);
16245 	v[i]=rdiv(v[i],coeff,contextptr);
16246       }
16247       for (int i=0;i<s;++i){
16248 	if (is_zero(sc[i],contextptr))
16249 	  break;
16250 	r[i]=sc[i]*r[i];
16251       }
16252     }
16253     return v;
16254   }
16255 
gramschmidt(const matrice & m,bool normalize,GIAC_CONTEXT)16256   matrice gramschmidt(const matrice & m,bool normalize,GIAC_CONTEXT){
16257     matrice r;
16258     return gramschmidt(m,r,normalize,contextptr);
16259   }
16260 
16261   // lll decomposition of M, returns S such that S=A*M=L*O
16262   // L is lower and O is orthogonal
lll(const matrice & M,matrice & L,matrice & O,matrice & A,GIAC_CONTEXT)16263   matrice lll(const matrice & M,matrice & L,matrice & O,matrice &A,GIAC_CONTEXT){
16264     if (!ckmatrix(M))
16265       return vecteur(1,gensizeerr(contextptr));
16266     matrice res(M);
16267     int n=int(res.size());
16268     if (!n)
16269       return res;
16270     int c=int(res[0]._VECTptr->size());
16271     if (c<n)
16272       return vecteur(1,gendimerr(contextptr));
16273     A=midn(c);
16274     A=vecteur(A.begin(),A.begin()+n);
16275     int k=0;
16276     for (;k<n;){
16277       if (!k){ // push first vector
16278 	vecteur tmp(c);
16279 	tmp[0]=1;
16280 	L.push_back(tmp);
16281 	O.push_back(res.front());
16282 	++k;
16283 	continue;
16284       }
16285       // Find new vector in L,O
16286       vecteur tmp(c);
16287       gen Otmp(res[k]);
16288       for (int j=0;j<k;++j){
16289 	// tmp[j]=dotvecteur(res[j],res[k])/dotvecteur(res[j],res[j]);
16290 	tmp[j]=dotvecteur(conj(O[j],contextptr),Otmp)/dotvecteur(conj(O[j],contextptr),O[j]);
16291 	Otmp=subvecteur(*Otmp._VECTptr,multvecteur(tmp[j],*O[j]._VECTptr));
16292       }
16293       tmp[k]=1;
16294       L.push_back(tmp);
16295       O.push_back(Otmp);
16296       // Compare norm of O[k] and O[k-1]
16297       for (int j=k-1;j>=0;--j){
16298 	gen alpha=dotvecteur(conj(O[j],contextptr),res[k])/dotvecteur(conj(O[j],contextptr),O[j]);
16299 	alpha=_round(alpha,contextptr);
16300 	res[k]=subvecteur(*res[k]._VECTptr,multvecteur(alpha,*res[j]._VECTptr));
16301 	A[k]=subvecteur(*A[k]._VECTptr,multvecteur(alpha,*A[j]._VECTptr));
16302 	L[k]=subvecteur(*L[k]._VECTptr,multvecteur(alpha,*L[j]._VECTptr));
16303       }
16304       gen lastalpha=dotvecteur(conj(O[k-1],contextptr),res[k])/dotvecteur(conj(O[k-1],contextptr),O[k-1]);
16305       if (ck_is_greater(dotvecteur(conj(O[k],contextptr),O[k]),(gen(3)/4-lastalpha*conj(lastalpha,contextptr))*dotvecteur(conj(O[k-1],contextptr),O[k-1]),contextptr)){
16306 	// Ok, continue the reduction
16307 	++k;
16308       }
16309       else {
16310 	swapgen(res[k],res[k-1]);
16311 	swapgen(A[k],A[k-1]);
16312 	--k;
16313 	L.pop_back();
16314 	L.pop_back();
16315 	O.pop_back();
16316 	O.pop_back();
16317       }
16318     }
16319     return res;
16320   }
lll(const matrice & m,GIAC_CONTEXT)16321   matrice lll(const matrice & m,GIAC_CONTEXT){
16322     matrice L,O,A;
16323     return lll(m,L,O,A,contextptr);
16324   }
_lll(const gen & g,GIAC_CONTEXT)16325   gen _lll(const gen & g,GIAC_CONTEXT){
16326     if ( g.type==_STRNG && g.subtype==-1) return  g;
16327     if (g.type!=_VECT)
16328       return gensizeerr(contextptr);
16329     matrice L,O,A;
16330     matrice S=lll(*g._VECTptr,L,O,A,contextptr);
16331     return gen(makevecteur(S,A,L,O),_SEQ__VECT);
16332   }
16333   static const char _lll_s []="lll";
16334   static define_unary_function_eval (__lll,&_lll,_lll_s);
16335   define_unary_function_ptr5( at_lll ,alias_at_lll,&__lll,0,true);
16336 
16337   static const char _lll_reduce_s []="lll_reduce";
16338   static define_unary_function_eval (__lll_reduce,&_lll,_lll_reduce_s);
16339   define_unary_function_ptr5( at_lll_reduce ,alias_at_lll_reduce,&__lll_reduce,0,true);
16340 
16341   // Utilities for Hermite and Smith normal forms
rem(const gen & p,const gen & q,environment * env)16342   static gen rem(const gen & p,const gen & q,environment * env){
16343     if (is_zero(p))
16344       return p;
16345     if (!env)
16346       return smod(p,q);
16347     if (p.type==_POLY || q.type==_POLY){
16348       if (p.type!=_POLY)
16349 	return p;
16350       if (q.type!=_POLY)
16351 	return 0;
16352       return *p._POLYptr % *q._POLYptr;
16353     }
16354     vecteur R=operator_mod(gen2vecteur(p),gen2vecteur(q),env);
16355     if (R.size()==1)
16356       return R.front();
16357     else
16358       return gen(R,_POLY1__VECT);
16359   }
16360 
quo(const gen & p,const gen & q,environment * env)16361   static gen quo(const gen & p,const gen & q,environment * env){
16362     if (is_zero(p))
16363       return p;
16364     if (!env)
16365       return (p-smod(p,q))/q;
16366     if (p.type==_POLY || q.type==_POLY){
16367       if (p.type!=_POLY)
16368 	return zero;
16369       if (q.type!=_POLY)
16370 	return q;
16371       return *p._POLYptr % *q._POLYptr; // FIXME mod computation
16372     }
16373     vecteur Q=operator_div(gen2vecteur(p),gen2vecteur(q),env);
16374     if (Q.size()==1)
16375       return Q.front();
16376     else
16377       return gen(Q,_POLY1__VECT);
16378   }
16379 
16380   // w=(c1*v1+c2*v2)/c smod modulo
modlinear_combination(const gen & c1,const vecteur & v1,const gen & c2,const vecteur & v2,const gen & c,vecteur & w,environment * env,int cstart,int cend)16381   void modlinear_combination(const gen & c1,const vecteur & v1,const gen & c2,const vecteur & v2,const gen & c,vecteur & w,environment * env,int cstart,int cend){
16382     const_iterateur it1=v1.begin()+cstart,it1end=v1.end();
16383     if (cend && cend>=cstart && cend<it1end-v1.begin())
16384       it1end=v1.begin()+cend;
16385     const_iterateur it2=v2.begin()+cstart;
16386     iterateur jt=w.begin()+cstart;
16387     gen modulo=env->modulo;
16388     for (;it1!=it1end;++it1,++it2,++jt){
16389       *jt=smod(c1*(*it1)+c2*(*it2),modulo);
16390       *jt=quo(*jt,c,env);
16391     }
16392   }
16393 
egcd(const gen & a,const gen & b,gen & u,gen & v,gen & d,environment * env)16394   static void egcd(const gen & a,const gen & b,gen & u,gen & v,gen & d,environment * env){
16395     if (!env){
16396       egcd(a,b,u,v,d);
16397       return ;
16398     }
16399     if (is_zero(a)){
16400       u=0; v=1; d=b; return;
16401     }
16402     if (is_zero(b)){
16403       u=1; v=0; d=a; return;
16404     }
16405     if (a.type==_POLY || b.type==_POLY){
16406       if (a.type!=_POLY){
16407 	if (env && env->moduloon){
16408 	  d=1;
16409 	  u=invmod(a,env->modulo);
16410 	}
16411 	else {
16412 	  d=a;
16413 	  u=plus_one;
16414 	}
16415 	v=zero;
16416 	return;
16417       }
16418       if (b.type!=_POLY){
16419 	if (env && env->moduloon){
16420 	  d=1;
16421 	  v=invmod(b,env->modulo);
16422 	}
16423 	else {
16424 	  d=b;
16425 	  v=plus_one;
16426 	}
16427 	u=zero;
16428 	return;
16429       }
16430       polynome U,V,D;
16431       egcd(*a._POLYptr,*b._POLYptr,U,V,D);
16432       u=U; v=V; d=D;
16433       return;
16434     }
16435     if (a.type!=_VECT){
16436       if (env && env->moduloon){
16437 	d=1;
16438 	u=invmod(a,env->modulo);
16439       }
16440       else {
16441 	d=a;
16442 	u=plus_one;
16443       }
16444       v=zero;
16445       return;
16446     }
16447     if (b.type!=_VECT){
16448       if (env && env->moduloon){
16449 	d=1;
16450 	v=invmod(b,env->modulo);
16451       }
16452       else {
16453 	d=b;
16454 	v=plus_one;
16455       }
16456       u=zero;
16457       return;
16458     }
16459     modpoly U,V,D;
16460     egcd(*a._VECTptr,*b._VECTptr,env,U,V,D);
16461     if (U.size()==1)
16462       u=U.front();
16463     else
16464       u=gen(U,_POLY1__VECT);
16465     if (V.size()==1)
16466       v=V.front();
16467     else
16468       v=gen(V,_POLY1__VECT);
16469     if (D.size()==1)
16470       d=D.front();
16471     else
16472       d=gen(D,_POLY1__VECT);
16473   }
16474 
16475   // degree + 1 for poly, abs for integer, 1 otherwise
smith_deg(const gen & a,environment * env,GIAC_CONTEXT)16476   static gen smith_deg(const gen & a,environment * env,GIAC_CONTEXT){
16477     if (!env)
16478       return abs(a,contextptr);
16479     if (a.type!=_VECT)
16480       return is_zero(a,contextptr)?zero:plus_one;
16481     return int(a._VECTptr->size());
16482   }
16483 
16484 
16485   // If Aorig has integer coefficients, hermite
16486   // finds U and A such that A=U*Aorig with U invertible in Z and A
16487   // is upper triangular, with non zero coeff || <= |pivot|/2
hermite(const std_matrix<gen> & Aorig,std_matrix<gen> & U,std_matrix<gen> & A,environment * env,GIAC_CONTEXT)16488   bool hermite(const std_matrix<gen> & Aorig,std_matrix<gen> & U,std_matrix<gen> & A,environment * env,GIAC_CONTEXT){
16489     A=Aorig;
16490     int n=int(A.size());
16491     if (!n) return false;
16492     int m=int(A.front().size());
16493     matrice2std_matrix_gen(midn(n),U);
16494     gen u,v,d;
16495     vecteur B1(n),B2(m);
16496     int i0=0;
16497     for (int j=0;j<m ;j++ ){
16498       // Find non zero entry of smallest abs value in column j
16499       int k=-1;
16500       gen min_val=plus_inf,tmp,q;
16501       for (int i=i0;i<n;++i){
16502 	tmp=smith_deg(A[i][j],env,contextptr);
16503 	if (!is_zero(tmp,contextptr) && is_strictly_greater(min_val,tmp,contextptr)){
16504 	  k=i;
16505 	  min_val=tmp;
16506 	}
16507       }
16508       if (k>=0 && !is_zero(min_val,contextptr)){
16509 	if (i0!=k){ // Exchange lines i0 and k in A and U
16510 	  swap(A[i0],A[k]);
16511 	  swap(U[i0],U[k]);
16512 	}
16513 	for (int i=n-1;i>=0;--i){
16514 	  if (i==i0 || is_zero(A[i][j],contextptr) )
16515 	    continue;
16516 	  if (i<i0){
16517 	    // Above diag do: L_i <- L_i - q*L_j
16518 	    q=quo(A[i][j],A[i0][j],env);
16519 	    linear_combination(plus_one,U[i],-q,U[i0],plus_one,1,U[i],0.0,0);
16520 	    linear_combination(plus_one,A[i],-q,A[i0],plus_one,1,A[i],0.0,0);
16521 	  }
16522 	  else {
16523 	    // Below diag: we use Bezout u*a+v*b=d where a=coeff, b="pivot"
16524 	    // L_i0 <- v*L_i0 + u*L_i
16525 	    // L_i <- (-a * L_i0 + b * L_i)/d
16526 	    // This transformation is Z-invertible since det=(u*a+b*v)/d=1
16527 	    // it will cancel the leading coeff of L_i
16528 	    // We should use the smallest possible |u| and |v|
16529 	    gen a = A[i][j];
16530 	    gen b = A[i0][j];
16531 	    egcd(a,b,u,v,d,env);
16532 	    if (env && env->moduloon){
16533 	      modlinear_combination(v,U[i0],u,U[i],plus_one,B1,env,0,0);
16534 	      modlinear_combination(-a,U[i0],b,U[i],d,U[i],env,0,0);
16535 	      modlinear_combination(v,A[i0],u,A[i],plus_one,B2,env,0,0);
16536 	      modlinear_combination(-a,A[i0],b,A[i],d,A[i],env,0,0);
16537 	    }
16538 	    else {
16539 	      linear_combination(v,U[i0],u,U[i],plus_one,1,B1,0.0,0);
16540 	      linear_combination(-a,U[i0],b,U[i],d,1,U[i],0.0,0);
16541 	      linear_combination(v,A[i0],u,A[i],plus_one,1,B2,0.0,0);
16542 	      linear_combination(-a,A[i0],b,A[i],d,1,A[i],0.0,0);
16543 	    }
16544 	    U[i0]=B1;
16545 	    A[i0]=B2;
16546 	  }
16547 	} // end for (column reduced)
16548 	// CERR << A << '\n';
16549 	if (!env && is_strictly_positive(-A[i0][i0],contextptr)){
16550 	  A[i0]=-A[i0];
16551 	  U[i0]=-U[i0];
16552 	}
16553 	++i0;
16554       }
16555     }
16556     return true;
16557   }
16558 
16559   // fonction ihermite
16560   // Forme normale de Hermite pour une matrice a coeff entiers
16561   // effectue la reduction sous forme echelonnee (de type Gauss)
16562   // d'une matrice d'entiers en utilisant uniquement des operations
16563   // de lignes inversibles dans les entiers, en d'autres termes si A0
16564   // est la matrice originale, on calcule une matrice U inversible dans Z
16565   // et une matrice A triangulaire superieure telles que
16566   //   A = U*A0
16567   // De plus les coefficients au-dessus de la diagonale de A sont en module
16568   // inferieurs au pivot de la colonne /2 .
16569   // exemple
16570   // A0:=[[9,-36,30], [-36,192,-180], [30,-180,180]];
16571   // U,A:=ihermite(A0);
16572   // U*A0-A (renvoie 0)
16573   // det(U) = 1 donc on passe aussi de A a A0 uniquement avec des
16574   // manipulations de ligne a coeffs entiers
16575   // Application: calcul d'une Z-base d'un noyau
16576   // Soit M la matrice dont on cherche le noyau
16577   // U,A:=ihermite(transpose(M)) -> A=U*transpose(M)
16578   // -> transpose(A)=M*transpose(U)
16579   // les colonnes nulles de transpose(A) correspondent aux colonnes
16580   // de transpose(U) dans Ker(M) -> les lignes nulles de A aux lignes de U
16581   // dans le noyau.
16582   // Exemple: M:=[[1,2,3],[4,5,6],[7,8,9]]
16583   // U,A:=ihermite(M) renvoie
16584   // [[-3,1,0],[4,-1,0],[-1,2,-1]],[[1,-1,-3],[0,3,6],[0,0,0]]
16585   // A[2]==0 donc base de Ker(M) composee de U[2], on a bien
16586   // M*U[2]==0
16587 
ihermite(const matrice & Aorig,matrice & U,matrice & A,GIAC_CONTEXT)16588   bool ihermite(const matrice & Aorig, matrice & U,matrice & A,GIAC_CONTEXT){
16589     std_matrix<gen> aorig,u,a;
16590     matrice2std_matrix_gen(Aorig,aorig);
16591     if (!hermite(aorig,u,a,0,contextptr))
16592       return false;
16593     std_matrix_gen2matrice_destroy(u,U);
16594     std_matrix_gen2matrice_destroy(a,A);
16595     return true;
16596   }
16597 
_ihermite(const gen & g,GIAC_CONTEXT)16598   gen _ihermite(const gen & g,GIAC_CONTEXT){
16599     if ( g.type==_STRNG && g.subtype==-1) return  g;
16600     if (g.type!=_VECT)
16601       return gensizeerr(contextptr);
16602     if (!is_integer_matrice(*g._VECTptr))
16603       return gensizeerr(gettext("Integer matrix expected"));
16604     matrice U,A;
16605     if (!ihermite(*g._VECTptr,U,A,contextptr))
16606       return gensizeerr(contextptr);
16607     // if (abs_calc_mode(contextptr)==38) return makevecteur(U,A);
16608     return gen(makevecteur(U,A),_SEQ__VECT);
16609   }
16610   static const char _ihermite_s []="ihermite";
16611   static define_unary_function_eval (__ihermite,&_ihermite,_ihermite_s);
16612   define_unary_function_ptr5( at_ihermite ,alias_at_ihermite,&__ihermite,0,true);
16613 
16614   // A=U*Aorig*V, U and V Z-invertible, A diagonal, A[i,i] divides A[i+1,i+1]
smith(const std_matrix<gen> & Aorig,std_matrix<gen> & U,std_matrix<gen> & A,std_matrix<gen> & V,environment * env,GIAC_CONTEXT)16615   bool smith(const std_matrix<gen> & Aorig,std_matrix<gen> & U,std_matrix<gen> & A,std_matrix<gen> & V,environment * env,GIAC_CONTEXT){
16616     A=Aorig;
16617     int n=int(A.size());
16618     if (!n) return false; // setsizeerr();
16619     int m=int(A.front().size());
16620     matrice2std_matrix_gen(midn(n),U);
16621     matrice2std_matrix_gen(midn(m),V);
16622     // FIXME: possible improvement if only A is computed
16623     // do ihermite, compute det,
16624     // and make computations below mod 2*det
16625     // It is also possible at increment step to divide by the pivot
16626     // the remaining coeffs of the matrix (and multiply back later)
16627     gen u,v,d;
16628     vecteur B1(n),B2(m);
16629     int i0=0,j0=0; // row below i0 and col below j0 done
16630     for (;j0<m && i0<n; ){
16631       bool increment=true;
16632       if (j0<m){
16633 	// Find non zero entry of smallest abs value in column j0
16634 	int k=-1;
16635 	gen min_val=plus_inf,tmp,q;
16636 	for (int i=i0;i<n;++i){
16637 	  tmp=smith_deg(A[i][j0],env,contextptr);
16638 	  if (!is_zero(tmp,contextptr) && is_strictly_greater(min_val,tmp,contextptr)){
16639 	    k=i;
16640 	    min_val=tmp;
16641 	  }
16642 	}
16643 	if (k>=0 && !is_zero(min_val,contextptr)){
16644 	  if (i0!=k){ // Exchange lines i0 and k in A and U
16645 	    swap(A[i0],A[k]);
16646 	    swap(U[i0],U[k]);
16647 	  }
16648 	  for (int i=n-1;i>i0;--i){
16649 	    if (is_zero(A[i][j0],contextptr) )
16650 	      continue;
16651 	    increment=false;
16652 	    // we use Bezout u*a+v*b=d where a=coeff, b="pivot"
16653 	    // L_i0 <- v*L_i0 + u*L_i
16654 	    // L_i <- (-a * L_i0 + b * L_i)/d
16655 	    // This transformation is Z-invertible since det=(U*a+b*v)/d=1
16656 	    // it will cancel the leading coeff of L_i
16657 	    // We should use the smallest possible |u| and |v|
16658 	    gen a = A[i][j0];
16659 	    gen b = A[i0][j0];
16660 	    egcd(b,a,v,u,d,env);
16661 	    if (env && env->moduloon){
16662 	      modlinear_combination(v,U[i0],u,U[i],plus_one,B1,env,0,0);
16663 	      modlinear_combination(-a,U[i0],b,U[i],d,U[i],env,0,0);
16664 	      modlinear_combination(v,A[i0],u,A[i],plus_one,B2,env,0,0);
16665 	      modlinear_combination(-a,A[i0],b,A[i],d,A[i],env,0,0);
16666 	    }
16667 	    else {
16668 	      linear_combination(v,U[i0],u,U[i],plus_one,1,B1,0.0,0);
16669 	      linear_combination(-a,U[i0],b,U[i],d,1,U[i],0.0,0);
16670 	      linear_combination(v,A[i0],u,A[i],plus_one,1,B2,0.0,0);
16671 	      linear_combination(-a,A[i0],b,A[i],d,1,A[i],0.0,0);
16672 	    }
16673 	    U[i0]=B1;
16674 	    A[i0]=B2;
16675 	  } // end for (row reduced)
16676 	  if (!env && is_strictly_positive(-A[i0][j0],contextptr)){
16677 	    A[i0]=-A[i0];
16678 	    U[i0]=-U[i0];
16679 	  }
16680 	} // end if k>=0 && !is_zero(min_val)
16681       } // end if (j0<m)
16682       if (i0<n){
16683 	// Column reduction
16684 	A=A.transpose();
16685 	// Find non zero entry of smallest abs value in transposed col i0
16686 	int k=-1;
16687 	gen min_val=plus_inf,tmp,q;
16688 	for (int i=j0;i<m;++i){
16689 	  tmp=smith_deg(A[i][i0],env,contextptr);
16690 	  if (!is_zero(tmp,contextptr) && is_strictly_greater(min_val,tmp,contextptr)){
16691 	    k=i;
16692 	    min_val=tmp;
16693 	  }
16694 	}
16695 	if (k>=0 && !is_zero(min_val,contextptr)){
16696 	  if (j0!=k){ // Exchange transposed rows j0 and k in A and V
16697 	    swap(A[j0],A[k]);
16698 	    swap(V[j0],V[k]);
16699 	  }
16700 	  for (int i=m-1;i>j0;--i){
16701 	    if (is_zero(A[i][i0],contextptr) )
16702 	      continue;
16703 	    increment=false;
16704 	    // we use Bezout u*a+v*b=d where a=coeff, b="pivot"
16705 	    // L_j0 <- v*L_j0 + u*L_i
16706 	    // L_i <- (-a * L_j0 + b * L_i)/d
16707 	    // This transformation is Z-invertible since det=(U*a+b*v)/d=1
16708 	    // it will cancel the leading coeff of L_i
16709 	    // We should use the smallest possible |u| and |v|
16710 	    gen a = A[i][i0];
16711 	    gen b = A[j0][i0];
16712 	    egcd(b,a,v,u,d,env);
16713 	    if (env && env->moduloon){
16714 	      modlinear_combination(v,V[j0],u,V[i],plus_one,B2,env,0,0);
16715 	      modlinear_combination(-a,V[j0],b,V[i],d,V[i],env,0,0);
16716 	      modlinear_combination(v,A[j0],u,A[i],plus_one,B1,env,0,0);
16717 	      modlinear_combination(-a,A[j0],b,A[i],d,A[i],env,0,0);
16718 	    }
16719 	    else {
16720 	      linear_combination(v,V[j0],u,V[i],plus_one,1,B2,0.0,0);
16721 	      linear_combination(-a,V[j0],b,V[i],d,1,V[i],0.0,0);
16722 	      linear_combination(v,A[j0],u,A[i],plus_one,1,B1,0.0,0);
16723 	      linear_combination(-a,A[j0],b,A[i],d,1,A[i],0.0,0);
16724 	    }
16725 	    V[j0]=B2;
16726 	    A[j0]=B1;
16727 	  } // end for (row reduced)
16728 	  if (!env && is_strictly_positive(-A[j0][i0],contextptr)){
16729 	    A[j0]=-A[j0];
16730 	    V[j0]=-V[j0];
16731 	  }
16732 	} // end if (k>=0 && !is_zero(min_val) )
16733 	// End column reduction
16734 	A=A.transpose();
16735       } // end if (i0<n)
16736       // Now check that all remaining elements are divisible by A[i0][j0]
16737       // otherwise replace A[i0] by A[i0]+A[i]
16738       if (i0<n && j0<m){
16739 	gen pivot=A[i0][j0];
16740 	int i=i0+1;
16741 	for (;i<n;++i){
16742 	  int j=j0+1;
16743 	  for (;j<m;++j){
16744 	    if (!is_zero(rem(A[i][j],pivot,env),contextptr))
16745 	      break;
16746 	  }
16747 	  if (j!=m)
16748 	    break;
16749 	}
16750 	if (i!=n){
16751 	  increment=false;
16752 	  A[i0]=addvecteur(A[i0],A[i]);
16753 	  U[i0]=addvecteur(U[i0],U[i]);
16754 	}
16755       }
16756       if (increment){
16757 	++i0;
16758 	++j0;
16759       }
16760     } // end for (;j0<m && i0<n;)
16761     V=V.transpose();
16762     return true;
16763   }
16764 
ismith(const matrice & Aorig,matrice & U,matrice & A,matrice & V,GIAC_CONTEXT)16765   bool ismith(const matrice & Aorig, matrice & U,matrice & A,matrice & V,GIAC_CONTEXT){
16766     std_matrix<gen> aorig,u,a,v;
16767     matrice2std_matrix_gen(Aorig,aorig);
16768     if (!smith(aorig,u,a,v,0,contextptr))
16769       return false;
16770     std_matrix_gen2matrice_destroy(u,U);
16771     std_matrix_gen2matrice_destroy(a,A);
16772     std_matrix_gen2matrice_destroy(v,V);
16773     return true;
16774   }
16775 
_ismith(const gen & g,GIAC_CONTEXT)16776   gen _ismith(const gen & g,GIAC_CONTEXT){
16777     if ( g.type==_STRNG && g.subtype==-1) return  g;
16778     if (g.type!=_VECT)
16779       return gensizeerr(contextptr);
16780     if (!is_integer_matrice(*g._VECTptr))
16781       return gensizeerr(gettext("Integer matrix expected"));
16782     matrice U,A,V;
16783     if (!ismith(*g._VECTptr,U,A,V,contextptr))
16784       return gensizeerr(contextptr);
16785     return gen(makevecteur(U,A,V),_SEQ__VECT);
16786   }
16787   static const char _ismith_s []="ismith";
16788   static define_unary_function_eval (__ismith,&_ismith,_ismith_s);
16789   define_unary_function_ptr5( at_ismith ,alias_at_ismith,&__ismith,0,true);
16790 
16791   //   ismith, calcule la forme normale de Smith d'une
16792   //   matrice, A0 a coefficients entiers
16793   //   U,A,V := ismith(A0);
16794   //   calcule U,V Z-inversibles et A=U*Aorig*V, A est diagonale avec
16795   //   A[i,i] divise A[i+1,i+1]
16796   //   Les A[i,i] s'appellent diviseurs elementaires et permettent entre
16797   //   autre de trouver la structure des groupes abeliens de type fini
16798 
16799   // FIXME: Hermite and Smith normal form, same code except for smod/iquo/egcd
16800   // For polynomials use egcd(a,b,env,u,v,d)
16801 
16802   // Read a CSV file (comma separated) with separator, newline, end of file
16803   // decsep = decimal separator (, -> .)
16804 #if !defined NSPIRE && !defined FXCG && !defined GIAC_HAS_STO_38
csv2gen(istream & i,char sep,char nl,char decsep,char eof,GIAC_CONTEXT)16805   matrice csv2gen(istream & i,char sep,char nl,char decsep,char eof,GIAC_CONTEXT){
16806     // return vecteur(1,gensizeerr(contextptr));
16807     vecteur res,line;
16808     size_t nrows=0,ncols=0;
16809     char c;
16810     string s;
16811     bool ok=true;
16812     for (;ok && i;){
16813       c=i.get();
16814       if (i.eof() || c==eof){
16815 	if (s.empty())
16816 	  break;
16817 	ok=false;
16818 	c=nl;
16819       }
16820       if (c=='%')
16821 	c=' ';
16822       if (c==sep || c==nl){
16823 	// remove spaces at beginning of s
16824 	while (!s.empty() && s[0]==' ')
16825 	  s=s.substr(1,s.size()-1);
16826 	// if sep==' ' remove spaces in i
16827 	if (sep==' '){
16828 	  char c2;
16829 	  for (;;){
16830 	    c2=i.get();
16831 	    if (i.eof() || c2!=' '){
16832 	      i.putback(c2);
16833 	      break;
16834 	    }
16835 	  }
16836 	}
16837 	// if 1st char is = or digit parse, else string
16838 	int ss=int(s.size());
16839 	if (s.empty())
16840 	  line.push_back(string2gen(s,false));
16841 	else {
16842 	  if (ss>2 && s[0]=='"' && s[1]=='=' && s[ss-1]=='"'){
16843 	    s=s.substr(1,ss-2);
16844 	    ss -= 2;
16845 	  }
16846 #ifdef NO_STDEXCEPT
16847 	  if (s[0]=='=' || s[0]=='-'){
16848 	    line.push_back(gen(s,contextptr));
16849 	  }
16850 	  else {
16851 	    if (s[0]==decsep ||(s[0]>='0' && s[0]<='9')){
16852 	      line.push_back(gen(s,contextptr));
16853 	    }
16854 	    else
16855 	      line.push_back(string2gen(s,s[0]=='"'));
16856 	  }
16857 #else
16858 	  try {
16859 	    if (s[0]=='=' || s[0]=='-'){
16860 	      line.push_back(gen(s,contextptr));
16861 	    }
16862 	    else {
16863 	      if (s[0]==decsep ||(s[0]>='0' && s[0]<='9')){
16864 		line.push_back(gen(s,contextptr));
16865 	      }
16866 	      else
16867 		line.push_back(string2gen(s,s[0]=='"'));
16868 	    }
16869 	  } catch (std::runtime_error & e){
16870 	    last_evaled_argptr(contextptr)=NULL;
16871 	    line.push_back(string2gen(e.what(),false));
16872 	  }
16873 #endif
16874 	}
16875 	s="";
16876 	if (c==nl){
16877 	  res.push_back(line);
16878 	  ncols=giacmax(int(ncols),int(line.size()));
16879 	  line.clear();
16880 	  nrows++;
16881 	  continue;
16882 	}
16883       } // end if c==sep || nl
16884       else  {
16885 	if (c==decsep)
16886 	  s += '.';
16887 	else
16888 	  s += c;
16889       }
16890     } // end reading stream
16891     // now make a matrix from res
16892     for (unsigned j=0;j<nrows;j++){
16893       res[j]=mergevecteur(*res[j]._VECTptr,vecteur(ncols-res[j]._VECTptr->size(),0));
16894     }
16895     return res;
16896   }
16897 
16898   // csv2gen(filename,sep,nl,decsep,eof[,string])
_csv2gen(const gen & g,GIAC_CONTEXT)16899   gen _csv2gen(const gen & g,GIAC_CONTEXT){
16900     if ( g.type==_STRNG && g.subtype==-1) return  g;
16901     char sep(';'),nl('\n'),eof(0),decsep(',');
16902     gen tmp,gs;
16903     bool isfile=true;
16904     int s=0;
16905     if (g.type==_VECT && !g._VECTptr->empty()){
16906       gs=g._VECTptr->front();
16907       s=int(g._VECTptr->size());
16908       tmp=g[s-1];
16909       if (tmp==at_string){
16910 	isfile=false;
16911 	--s;
16912       }
16913       if (s>1){
16914 	tmp=g[1];
16915 	if (tmp.type==_STRNG && !tmp._STRNGptr->empty())
16916 	  sep=(*tmp._STRNGptr)[0];
16917       }
16918       if (s>2){
16919 	tmp=g[2];
16920 	if (tmp.type==_STRNG && !tmp._STRNGptr->empty())
16921 	  nl=(*tmp._STRNGptr)[0];
16922       }
16923       if (s>3){
16924 	tmp=g[3];
16925 	if (tmp.type==_STRNG && !tmp._STRNGptr->empty())
16926 	  decsep=(*tmp._STRNGptr)[0];
16927       }
16928       if (s>4){
16929 	tmp=g[4];
16930 	if (tmp.type==_STRNG && !tmp._STRNGptr->empty())
16931 	  eof=(*tmp._STRNGptr)[0];
16932       }
16933     }
16934     else
16935       gs=g;
16936     if (gs.type!=_STRNG)
16937       return gensizeerr(gettext("Expecting file name to convert"));
16938     string file=*gs._STRNGptr;
16939     if (isfile){
16940 #ifdef EMCC
16941       istringstream i(fetch(file));
16942       return csv2gen(i,sep,nl,decsep,eof,contextptr);
16943 #else
16944       if (file.size()>4 && file.substr(0,4)=="http"){
16945 	string s=fetch(file);
16946 	istringstream i(s);
16947 	return csv2gen(i,sep,nl,decsep,eof,contextptr);
16948       }
16949       ifstream i(file.c_str());
16950       return csv2gen(i,sep,nl,decsep,eof,contextptr);
16951 #endif
16952     }
16953     else {
16954       // count [ ]
16955       int open=0,close=0,sp=0;
16956       for (size_t i=0;i<file.size();++i){
16957 	if (file[i]=='[')
16958 	  ++open;
16959 	if (file[i]==']')
16960 	  ++close;
16961 	if (file[i]==' ')
16962 	  ++sp;
16963       }
16964       if (file.size()<=20 && sp==0)
16965 	return eval(gen(file,contextptr),1,contextptr);
16966       if (open>=2 && absint(open-close)<=1)
16967 	return gen(file,contextptr);
16968 #ifdef HAVE_SSTREAM
16969       istringstream i(file.c_str());
16970 #else
16971       istrstream i(file.c_str());
16972 #endif
16973       if (s==1) // guess
16974 	csv_guess(file.c_str(),file.size(),sep,nl,decsep);
16975       return csv2gen(i,sep,nl,decsep,eof,contextptr);
16976     }
16977   }
16978   static const char _csv2gen_s []="csv2gen";
16979   static define_unary_function_eval (__csv2gen,&_csv2gen,_csv2gen_s);
16980   define_unary_function_ptr5( at_csv2gen ,alias_at_csv2gen,&__csv2gen,0,true);
16981 
16982 #endif
matpow(const matrice & m,const gen & n,GIAC_CONTEXT)16983   matrice matpow(const matrice & m,const gen & n,GIAC_CONTEXT){
16984     identificateur x("x");
16985     gen ux=symbolic(at_pow,gen(makevecteur(x,n),_SEQ__VECT));
16986     return analytic_apply(ux,x,m,contextptr);
16987   }
16988 
16989       // FIXME: pow should not always call egv stuff
_matpow(const gen & a,GIAC_CONTEXT)16990   gen _matpow(const gen & a,GIAC_CONTEXT){
16991     if ( a.type==_STRNG && a.subtype==-1) return  a;
16992     if (a.type==_VECT && a._VECTptr->size()==2 && ckmatrix(a._VECTptr->front()))
16993       return matpow(*a._VECTptr->front()._VECTptr,a._VECTptr->back(),contextptr);
16994     return gensizeerr(contextptr);
16995   }
16996   static const char _matpow_s []="matpow";
16997   static define_unary_function_eval (__matpow,&_matpow,_matpow_s);
16998   define_unary_function_ptr5( at_matpow ,alias_at_matpow,&__matpow,0,true);
16999 
17000   // EIGENVALUES for double coeff
eigenval2(matrix_double & H,int n2,giac_double & l1,giac_double & l2)17001   bool eigenval2(matrix_double & H,int n2,giac_double & l1, giac_double & l2){
17002     giac_double a=H[n2-2][n2-2],b=H[n2-2][n2-1],c=H[n2-1][n2-2],d=H[n2-1][n2-1];
17003     giac_double delta=a*a-2*a*d+d*d+4*b*c;
17004     if (delta<0){
17005       l1=(a+d)/2;
17006       l2=std::sqrt(-delta)/2;
17007       if (debug_infolevel>2)
17008 	CERR << "eigenval2([[" << a << "," << b << "],[" << c << "," << d << "]], delta=" << delta << " re " << l1 << " im " << l2 << '\n';
17009       return false;
17010     }
17011     delta=std::sqrt(delta);
17012     l1=(a+d+delta)/2;
17013     l2=(a+d-delta)/2;
17014     if (debug_infolevel>2)
17015       CERR << "eigenval2([[" << a << "," << b << "],[" << c << "," << d << "]], delta=" << delta << " , " << l1 << " and " << l2 << '\n';
17016     return true;
17017   }
17018 
trim(giac_double a,giac_double b,giac_double eps)17019   static inline giac_double trim(giac_double a,giac_double b,giac_double eps){
17020     if (eps && absdouble(a)<eps*absdouble(b))
17021       return 0;
17022     else
17023       return a;
17024   }
17025 
17026   // v=(c1*v1+c2*v2), begin at cstart
linear_combination(giac_double c1,const vector<giac_double> & v1,giac_double c2,const vector<giac_double> & v2,vector<giac_double> & v,int cstart,double eps)17027   void linear_combination(giac_double c1,const vector<giac_double> & v1,giac_double c2,const vector<giac_double> & v2,vector<giac_double> & v,int cstart,double eps){
17028     eps=0;
17029     if (cstart<0)
17030       cstart=0;
17031     vector<giac_double>::const_iterator it1=v1.begin()+cstart,it1end=v1.end(),it2=v2.begin()+cstart;
17032     vector<giac_double>::iterator jt1=v.begin()+cstart;
17033 #ifdef DEBUG_SUPPORT
17034     if (it1end-it1!=v2.end()-it2)
17035       setdimerr();
17036 #endif
17037     if (it2==jt1){
17038       linear_combination(c2,v2,c1,v1,v,cstart,eps);
17039       return;
17040     }
17041     if (it1==jt1){
17042       for (;jt1!=it1end;++jt1,++it2){
17043 	*jt1=c1*(*jt1)+c2*(*it2); // trim(c1*(*jt1)+c2*(*it2),c1,eps);
17044       }
17045       return;
17046     }
17047     if (int(v.size())==it1end-it1){
17048       jt1=v.begin();
17049       for (int i=0;i<cstart;++i,++jt1)
17050 	*jt1=0;
17051       for (;it1!=it1end;++it1,++it2,++jt1)
17052 	*jt1=c1*(*it1)+c2*(*it2); // trim(c1*(*it1)+c2*(*it2),c1,eps);
17053       return;
17054     }
17055     v.clear();
17056     v.reserve(it1end-it1);
17057     for (int i=0;i<cstart;++i)
17058       v.push_back(0);
17059     for (;it1!=it1end;++it1,++it2)
17060       v.push_back(c1*(*it1)+c2*(*it2)); // trim(c1*(*it1)+c2*(*it2),c1,eps);
17061   }
17062 
17063   // exchange line i and m1 of H and P, exchange colums i and m1 of H
17064   // assumes i>m1
exchange(matrix_double & H,matrix_double & P,bool compute_P,int i,int m1,int already_zero)17065   void exchange(matrix_double & H,matrix_double &P,bool compute_P,int i,int m1,int already_zero){
17066     if (debug_infolevel>2)
17067       CERR << CLOCK()*1e-6 << " exchange" << '\n';
17068     H[i].swap(H[m1]);
17069     if (compute_P)
17070       P[i].swap(P[m1]);
17071     int n=int(H.size()),nstop=n;
17072     if (already_zero){
17073       nstop=i+already_zero+1;
17074       if (nstop>n)
17075 	nstop=n;
17076     }
17077     for (matrix_double::iterator it=H.begin(),itend=it+nstop;it!=itend;++it){
17078       giac_double * Hj=&it->front();
17079       swap_giac_double(Hj[i],Hj[m1]);
17080     }
17081   }
17082 
17083 #if 0
17084   void linear_combination(giac_double a,const vector<giac_double> & A,giac_double b,const vector<giac_double> & B,vector<giac_double> & C,int cstart){
17085     const giac_double * Aptr=&A.front()+cstart, * Bptr=&B.front()+cstart;
17086     giac_double * Cptr=&C.front()+cstart,* Cend=Cptr+(C.size()-cstart);
17087     for (;Cptr!=Cend;++Aptr,++Bptr,++Cptr){
17088       *Cptr=a*(*Aptr)+b*(*Bptr);
17089     }
17090   }
17091 
17092   void linear_combination(giac_double a,const vector<giac_double> & A,giac_double b,vector<giac_double> & C,int cstart){
17093     const giac_double * Aptr=&A.front()+cstart;
17094     giac_double * Cptr=&C.front()+cstart,* Cend=Cptr+(C.size()-cstart);
17095     for (;Cptr!=Cend;++Aptr,++Cptr){
17096       *Cptr=a*(*Aptr)+b*(*Cptr);
17097     }
17098   }
17099 #endif
17100 
17101   // H*w->v and w*H->vprime, assumes correct sizes (v already initialized)
17102   // assumes w[0]=w[1]=...=w[k-1]=0
householder_mult2(const matrix_double & H,const std::vector<giac_double> & w,vector<giac_double> & v,vector<giac_double> & vprime,int k,bool is_k_hessenberg)17103   void householder_mult2(const matrix_double & H,const std::vector<giac_double> & w,vector<giac_double> & v,vector<giac_double> & vprime,int k,bool is_k_hessenberg){
17104     int n=int(H.size());
17105     for (int j=0;j<n;++j)
17106       vprime[j]=0;
17107     int j=0;
17108     for (;j<=n-4;j+=4){
17109       const giac_double * H0jk=&H[j].front(),*H0jk1=H0jk+k,*H0jkend=H0jk+n,*wk=&w.front()+k;
17110       const giac_double * H1jk=&H[j+1].front();
17111       const giac_double * H2jk=&H[j+2].front();
17112       const giac_double * H3jk=&H[j+3].front();
17113       giac_double *vprimek=&vprime.front();
17114       giac_double res0=0.0,res1=0.0,res2=0.0,res3=0.0,wj0=w[j],wj1=w[j+1],wj2=w[j+2],wj3=w[j+3];
17115       if (is_k_hessenberg && k){
17116 	H0jk +=k-1;
17117 	H1jk +=k-1;
17118 	H2jk +=k-1;
17119 	H3jk +=k-1;
17120 	vprimek +=k-1;
17121       }
17122       for (;H0jk<H0jk1;++vprimek,++H0jk,++H1jk,++H2jk,++H3jk){
17123 	*vprimek += wj0*(*H0jk)+wj1*(*H1jk)+wj2*(*H2jk)+wj3*(*H3jk);;
17124       }
17125 #if 1
17126       H0jkend -= 8;
17127       for (;H0jk<=H0jkend;){
17128 	giac_double tmp0=(*H0jk),tmp1=(*H1jk),tmp2(*H2jk),tmp3(*H3jk),tmp(*wk);
17129 	*vprimek += wj0*tmp0+wj1*tmp1+wj2*tmp2+wj3*tmp3;
17130 	res0 += tmp0*tmp; res1 += tmp1*tmp; res2 += tmp2*tmp; res3 += tmp3*tmp;
17131 	++wk,++vprimek,++H3jk,++H2jk,++H1jk,++H0jk;
17132 	// 1
17133 	tmp0=*H0jk; tmp1=*H1jk; tmp2=*H2jk; tmp3=*H3jk; tmp=*wk;
17134 	*vprimek += wj0*tmp0+wj1*tmp1+wj2*tmp2+wj3*tmp3;
17135 	res0 += tmp0*tmp; res1 += tmp1*tmp; res2 += tmp2*tmp; res3 += tmp3*tmp;
17136 	++wk,++vprimek,++H3jk,++H2jk,++H1jk,++H0jk;
17137 	// 2
17138 	tmp0=*H0jk; tmp1=*H1jk; tmp2=*H2jk; tmp3=*H3jk; tmp=*wk;
17139 	*vprimek += wj0*tmp0+wj1*tmp1+wj2*tmp2+wj3*tmp3;
17140 	res0 += tmp0*tmp; res1 += tmp1*tmp; res2 += tmp2*tmp; res3 += tmp3*tmp;
17141 	++wk,++vprimek,++H3jk,++H2jk,++H1jk,++H0jk;
17142 	// 3
17143 	tmp0=*H0jk; tmp1=*H1jk; tmp2=*H2jk; tmp3=*H3jk; tmp=*wk;
17144 	*vprimek += wj0*tmp0+wj1*tmp1+wj2*tmp2+wj3*tmp3;
17145 	res0 += tmp0*tmp; res1 += tmp1*tmp; res2 += tmp2*tmp; res3 += tmp3*tmp;
17146 	++wk,++vprimek,++H3jk,++H2jk,++H1jk,++H0jk;
17147 	// 4
17148 	tmp0=*H0jk; tmp1=*H1jk; tmp2=*H2jk; tmp3=*H3jk; tmp=*wk;
17149 	*vprimek += wj0*tmp0+wj1*tmp1+wj2*tmp2+wj3*tmp3;
17150 	res0 += tmp0*tmp; res1 += tmp1*tmp; res2 += tmp2*tmp; res3 += tmp3*tmp;
17151 	++wk,++vprimek,++H3jk,++H2jk,++H1jk,++H0jk;
17152 	// 5
17153 	tmp0=*H0jk; tmp1=*H1jk; tmp2=*H2jk; tmp3=*H3jk; tmp=*wk;
17154 	*vprimek += wj0*tmp0+wj1*tmp1+wj2*tmp2+wj3*tmp3;
17155 	res0 += tmp0*tmp; res1 += tmp1*tmp; res2 += tmp2*tmp; res3 += tmp3*tmp;
17156 	++wk,++vprimek,++H3jk,++H2jk,++H1jk,++H0jk;
17157 	// 6
17158 	tmp0=*H0jk; tmp1=*H1jk; tmp2=*H2jk; tmp3=*H3jk; tmp=*wk;
17159 	*vprimek += wj0*tmp0+wj1*tmp1+wj2*tmp2+wj3*tmp3;
17160 	res0 += tmp0*tmp; res1 += tmp1*tmp; res2 += tmp2*tmp; res3 += tmp3*tmp;
17161 	++wk,++vprimek,++H3jk,++H2jk,++H1jk,++H0jk;
17162 	// 7
17163 	tmp0=*H0jk; tmp1=*H1jk; tmp2=*H2jk; tmp3=*H3jk; tmp=*wk;
17164 	*vprimek += wj0*tmp0+wj1*tmp1+wj2*tmp2+wj3*tmp3;
17165 	res0 += tmp0*tmp; res1 += tmp1*tmp; res2 += tmp2*tmp; res3 += tmp3*tmp;
17166 	++wk,++vprimek,++H3jk,++H2jk,++H1jk,++H0jk;
17167       }
17168       H0jkend += 8;
17169 #endif
17170       for (;H0jk!=H0jkend;++wk,++vprimek,++H3jk,++H2jk,++H1jk,++H0jk){
17171 	giac_double tmp0=(*H0jk),tmp1=(*H1jk),tmp2(*H2jk),tmp3(*H3jk),tmp(*wk);
17172 	*vprimek += wj0*tmp0+wj1*tmp1+wj2*tmp2+wj3*tmp3;
17173 	res0 += tmp0*tmp; res1 += tmp1*tmp; res2 += tmp2*tmp; res3 += tmp3*tmp;
17174       }
17175       v[j]=res0;
17176       v[j+1]=res1;
17177       v[j+2]=res2;
17178       v[j+3]=res3;
17179     }
17180     for (;j<n;++j){
17181       const giac_double * H0jk=&H[j].front(),*H0jk1=H0jk+k,*H0jkend=H0jk+n,*wk=&w.front()+k;
17182       giac_double *vprimek=&vprime.front();
17183       giac_double res=0.0,wj0=w[j];
17184       if (is_k_hessenberg && k){
17185 	H0jk +=k-1;
17186 	vprimek +=k-1;
17187       }
17188       for (;H0jk<H0jk1;++vprimek,++H0jk){
17189 	*vprimek += wj0*(*H0jk);
17190       }
17191       for (;H0jk!=H0jkend;++wk,++vprimek,++H0jk){
17192 	register giac_double tmp0=(*H0jk);
17193 	*vprimek += wj0*tmp0;
17194 	res += tmp0*(*wk);
17195       }
17196       v[j]=res;
17197     }
17198   }
17199 
17200 
17201   // H*w->v, assumes correct sizes (v already initialized)
17202   // assumes w[0]=w[1]=...=w[k-1]=0
householder_mult(const matrix_double & H,const std::vector<giac_double> & w,vector<giac_double> & v,int k)17203   void householder_mult(const matrix_double & H,const std::vector<giac_double> & w,vector<giac_double> & v,int k){
17204     int n=int(H.size());
17205     for (int j=0;j<n;++j){
17206       vector<giac_double>::const_iterator it=H[j].begin()+k,itend=H[j].end(),jt=w.begin()+k;
17207       giac_double res=0.0;
17208       for (;it!=itend;++jt,++it)
17209 	res += (*it)*(*jt);
17210       v[j]=res;
17211     }
17212   }
17213 
17214   // w*H->v, assumes correct sizes (v already initialized)
17215   // assumes w[0]=w[1]=...=w[k-1]=0
householder_mult(const std::vector<giac_double> & w,const matrix_double & H,vector<giac_double> & v,int k,bool is_k_hessenberg,int jstart,int jend,int deltarow=0,int cstart=0,int cend=0)17216   void householder_mult(const std::vector<giac_double> & w,const matrix_double & H,vector<giac_double> & v,int k,bool is_k_hessenberg,int jstart,int jend,int deltarow=0,int cstart=0,int cend=0){
17217     int n=int(H.size())-deltarow;
17218     if (cend<=cstart)
17219       cend=int(H.front().size());
17220     int c=cend-cstart;
17221     v.resize(c);
17222     for (int j=0;j<c;++j)
17223       v[j]=0;
17224     int j=jstart; // at least k
17225 #if 1
17226     // if H is hessenberg up to column k, we can start at H[j][k-1] instead of H[j][0]
17227     for (;j<=jend-8;j+=8){
17228       giac_double wj0=w[j],wj1=w[j+1],wj2=w[j+2],wj3=w[j+3],wj4=w[j+4],wj5=w[j+5],wj6=w[j+6],wj7=w[j+7];
17229       const giac_double * Hjk0=&H[j+deltarow][cstart],* Hjk1=&H[j+deltarow+1][cstart],* Hjk2=&H[j+deltarow+2][cstart],* Hjk3=&H[j+deltarow+3][cstart],* Hjk4=&H[j+deltarow+4][cstart],* Hjk5=&H[j+deltarow+5][cstart],* Hjk6=&H[j+deltarow+6][cstart],* Hjk7=&H[j+deltarow+7][cstart];
17230       giac_double * vk=&v.front(),*vkend=vk+c;
17231       // if H is hessenberg up to column k, we can start at H[j][k-1] instead of H[j][0]
17232       if (is_k_hessenberg && k){
17233 	Hjk0 += k-1;
17234 	Hjk1 += k-1;
17235 	Hjk2 += k-1;
17236 	Hjk3 += k-1;
17237 	Hjk4 += k-1;
17238 	Hjk5 += k-1;
17239 	Hjk6 += k-1;
17240 	Hjk7 += k-1;
17241 	vk += k-1;
17242       }
17243       vkend -= 8;
17244       for (;vk<=vkend;){
17245 	*vk += wj0*(*Hjk0)+wj1*(*Hjk1)+wj2*(*Hjk2)+wj3*(*Hjk3)+wj4*(*Hjk4)+wj5*(*Hjk5)+wj6*(*Hjk6)+wj7*(*Hjk7);;
17246 	++vk; ++Hjk0; ++Hjk1; ++Hjk2; ++Hjk3; ++Hjk4; ++Hjk5; ++Hjk6; ++Hjk7;
17247 	// 1
17248 	*vk += wj0*(*Hjk0)+wj1*(*Hjk1)+wj2*(*Hjk2)+wj3*(*Hjk3)+wj4*(*Hjk4)+wj5*(*Hjk5)+wj6*(*Hjk6)+wj7*(*Hjk7);;
17249 	++vk; ++Hjk0; ++Hjk1; ++Hjk2; ++Hjk3; ++Hjk4; ++Hjk5; ++Hjk6; ++Hjk7;
17250 	// 2
17251 	*vk += wj0*(*Hjk0)+wj1*(*Hjk1)+wj2*(*Hjk2)+wj3*(*Hjk3)+wj4*(*Hjk4)+wj5*(*Hjk5)+wj6*(*Hjk6)+wj7*(*Hjk7);;
17252 	++vk; ++Hjk0; ++Hjk1; ++Hjk2; ++Hjk3; ++Hjk4; ++Hjk5; ++Hjk6; ++Hjk7;
17253 	// 3
17254 	*vk += wj0*(*Hjk0)+wj1*(*Hjk1)+wj2*(*Hjk2)+wj3*(*Hjk3)+wj4*(*Hjk4)+wj5*(*Hjk5)+wj6*(*Hjk6)+wj7*(*Hjk7);;
17255 	++vk; ++Hjk0; ++Hjk1; ++Hjk2; ++Hjk3; ++Hjk4; ++Hjk5; ++Hjk6; ++Hjk7;
17256 	// 4
17257 	*vk += wj0*(*Hjk0)+wj1*(*Hjk1)+wj2*(*Hjk2)+wj3*(*Hjk3)+wj4*(*Hjk4)+wj5*(*Hjk5)+wj6*(*Hjk6)+wj7*(*Hjk7);;
17258 	++vk; ++Hjk0; ++Hjk1; ++Hjk2; ++Hjk3; ++Hjk4; ++Hjk5; ++Hjk6; ++Hjk7;
17259 	// 5
17260 	*vk += wj0*(*Hjk0)+wj1*(*Hjk1)+wj2*(*Hjk2)+wj3*(*Hjk3)+wj4*(*Hjk4)+wj5*(*Hjk5)+wj6*(*Hjk6)+wj7*(*Hjk7);;
17261 	++vk; ++Hjk0; ++Hjk1; ++Hjk2; ++Hjk3; ++Hjk4; ++Hjk5; ++Hjk6; ++Hjk7;
17262 	// 6
17263 	*vk += wj0*(*Hjk0)+wj1*(*Hjk1)+wj2*(*Hjk2)+wj3*(*Hjk3)+wj4*(*Hjk4)+wj5*(*Hjk5)+wj6*(*Hjk6)+wj7*(*Hjk7);;
17264 	++vk; ++Hjk0; ++Hjk1; ++Hjk2; ++Hjk3; ++Hjk4; ++Hjk5; ++Hjk6; ++Hjk7;
17265 	// 7
17266 	*vk += wj0*(*Hjk0)+wj1*(*Hjk1)+wj2*(*Hjk2)+wj3*(*Hjk3)+wj4*(*Hjk4)+wj5*(*Hjk5)+wj6*(*Hjk6)+wj7*(*Hjk7);;
17267 	++vk; ++Hjk0; ++Hjk1; ++Hjk2; ++Hjk3; ++Hjk4; ++Hjk5; ++Hjk6; ++Hjk7;
17268       }
17269       vkend += 8;
17270       for (;vk!=vkend;++Hjk0,++Hjk1,++Hjk2,++Hjk3,++Hjk4,++Hjk5,++Hjk6,++Hjk7,++vk){
17271 	*vk += wj0*(*Hjk0)+wj1*(*Hjk1)+wj2*(*Hjk2)+wj3*(*Hjk3)+wj4*(*Hjk4)+wj5*(*Hjk5)+wj6*(*Hjk6)+wj7*(*Hjk7);;
17272       }
17273     }
17274 #endif
17275     for (;j<jend;j++){
17276       giac_double wj=w[j];
17277       const giac_double * Hjk=&H[j+deltarow][cstart];
17278       giac_double * vk=&v.front(),*vkend=vk+c;
17279       // if H is hessenberg up to column k, start at H[j][k-1] instead of H[j][0]
17280       if (is_k_hessenberg && k){
17281 	Hjk += k-1;
17282 	vk += k-1;
17283       }
17284       for (;vk!=vkend;++Hjk,++vk){
17285 	*vk += wj*(*Hjk);
17286       }
17287     }
17288   }
17289 
17290   // w*H->v, assumes correct sizes (v already initialized)
17291   // assumes w[0]=w[1]=...=w[k-1]=0
householder_mult(const std::vector<giac_double> & w,const matrix_double & H,vector<giac_double> & v,int k,bool is_k_hessenberg)17292   void householder_mult(const std::vector<giac_double> & w,const matrix_double & H,vector<giac_double> & v,int k,bool is_k_hessenberg){
17293     int n=int(H.size());
17294     householder_mult(w,H,v,k,is_k_hessenberg,k,n);
17295   }
17296 
17297   // P -> P - 2 w qprime
17298   // not used except possibly for 1 reflector if P is initially identity
hessenberg_p_pass1(matrix_double & P,const vector<giac_double> & w,const vector<giac_double> & qprime,int j,int jend,int n,int deltarow=0,int deltacol=0)17299   void hessenberg_p_pass1(matrix_double & P,const vector<giac_double> & w,const vector<giac_double> & qprime,int j,int jend,int n,int deltarow=0,int deltacol=0){
17300     int qstart=0;
17301     for (;qstart<n;++qstart){
17302       if (qprime[qstart])
17303 	break;
17304     }
17305     //qstart=0;
17306     for (;j<=jend-3;j+=3){
17307       const giac_double wj0=2*w[j], wj1=2*w[j+1], wj2=2*w[j+2];
17308       giac_double vk;//, wj3=2*w[j+3]
17309       giac_double * Pj0k=&P[j+deltarow][qstart+deltacol],* Pj1k=&P[j+deltarow+1][qstart+deltacol],* Pj2k=&P[j+deltarow+2][qstart+deltacol],*Pj0kend=Pj0k+(n-qstart);
17310       const giac_double *vprimek=&qprime[qstart];
17311 #if 1
17312       Pj0kend -= 8;
17313       for (;Pj0k<Pj0kend;){
17314 	vk=*vprimek;
17315 	*Pj0k -= wj0*vk;
17316 	*Pj1k -= wj1*vk;
17317 	*Pj2k -= wj2*vk;
17318 	// *Pj3k -= wj3*vk;
17319 	++Pj0k;++Pj1k;++Pj2k;++vprimek; // ++Pj3k;
17320 	// 1
17321 	vk=*vprimek;
17322 	*Pj0k -= wj0*vk;
17323 	*Pj1k -= wj1*vk;
17324 	*Pj2k -= wj2*vk;
17325 	// *Pj3k -= wj3*vk;
17326 	++Pj0k;++Pj1k;++Pj2k;++vprimek; // ++Pj3k;
17327 	// 2
17328 	vk=*vprimek;
17329 	*Pj0k -= wj0*vk;
17330 	*Pj1k -= wj1*vk;
17331 	*Pj2k -= wj2*vk;
17332 	// *Pj3k -= wj3*vk;
17333 	++Pj0k;++Pj1k;++Pj2k;;++vprimek; // ++Pj3k
17334 	// 3
17335 	vk=*vprimek;
17336 	*Pj0k -= wj0*vk;
17337 	*Pj1k -= wj1*vk;
17338 	*Pj2k -= wj2*vk;
17339 	// *Pj3k -= wj3*vk;
17340 	++Pj0k;++Pj1k;++Pj2k;++vprimek; // ++Pj3k;
17341 	// 4
17342 	vk=*vprimek;
17343 	*Pj0k -= wj0*vk;
17344 	*Pj1k -= wj1*vk;
17345 	*Pj2k -= wj2*vk;
17346 	// *Pj3k -= wj3*vk;
17347 	++Pj0k;++Pj1k;++Pj2k;++vprimek; // ++Pj3k;
17348 	// 5
17349 	vk=*vprimek;
17350 	*Pj0k -= wj0*vk;
17351 	*Pj1k -= wj1*vk;
17352 	*Pj2k -= wj2*vk;
17353 	// *Pj3k -= wj3*vk;
17354 	++Pj0k;++Pj1k;++Pj2k;++vprimek; // ++Pj3k;
17355 	// 6
17356 	vk=*vprimek;
17357 	*Pj0k -= wj0*vk;
17358 	*Pj1k -= wj1*vk;
17359 	*Pj2k -= wj2*vk;
17360 	// *Pj3k -= wj3*vk;
17361 	++Pj0k;++Pj1k;++Pj2k;;++vprimek;//++Pj3k
17362 	// 7
17363 	vk=*vprimek;
17364 	*Pj0k -= wj0*vk;
17365 	*Pj1k -= wj1*vk;
17366 	*Pj2k -= wj2*vk;
17367 	// *Pj3k -= wj3*vk;
17368 	++Pj0k;++Pj1k;++Pj2k;++vprimek; //++Pj3k;
17369       }
17370       Pj0kend += 8;
17371 #endif
17372       for (;Pj0k<Pj0kend;){
17373 	vk=*vprimek;
17374 	*Pj0k -= wj0*vk;
17375 	*Pj1k -= wj1*vk;
17376 	*Pj2k -= wj2*vk;
17377 	// *Pj3k -= wj3*vk;
17378 	++Pj0k;++Pj1k;++Pj2k;++vprimek;//++Pj3k;
17379       }
17380     }
17381     for (;j<jend;++j){
17382       giac_double wj=2*w[j];
17383       giac_double * Pjk=&P[j+deltarow][qstart+deltacol],*Pjkend=Pjk+(n-qstart);
17384       const giac_double *vprimek=&qprime[qstart];
17385       for (;Pjk!=Pjkend;++vprimek,++Pjk){
17386 	*Pjk -= wj*(*vprimek);
17387       }
17388     }
17389   }
17390 
17391   // H*w->v, assumes correct sizes
17392   // assumes w[0]=w[1]=...=w[k-1]=0 and H is identity except if rows and col >=k
householder_idn_mult(const matrix_double & H,const std::vector<giac_double> & w,vector<giac_double> & v,int k)17393   void householder_idn_mult(const matrix_double & H,const std::vector<giac_double> & w,vector<giac_double> & v,int k){
17394     v.resize(w.size());
17395     int n=int(H.size());
17396     std::copy(w.begin(),w.begin()+k,v.begin());
17397     int j=k;
17398     for (;j<=n-4;j+=4){
17399       vector<giac_double>::const_iterator it0=H[j].begin()+k,it1=H[j+1].begin()+k,it2=H[j+2].begin()+k,it3=H[j+3].begin()+k,itend=H[j].end(),jt=w.begin()+k;
17400       giac_double res0=0.0,res1=0.0,res2=0.0,res3=0.0;
17401       for (;it0!=itend;++jt,++it3,++it2,++it1,++it0){
17402 	giac_double tmp=*jt;
17403 	res0 += (*it0)*tmp;
17404 	res1 += (*it1)*tmp;
17405 	res2 += (*it2)*tmp;
17406 	res3 += (*it3)*tmp;
17407       }
17408       v[j]=res0;
17409       v[j+1]=res1;
17410       v[j+2]=res2;
17411       v[j+3]=res3;
17412     }
17413     for (;j<n;++j){
17414       vector<giac_double>::const_iterator it=H[j].begin()+k,itend=H[j].end(),jt=w.begin()+k;
17415       giac_double res=0.0;
17416       for (;it!=itend;++jt,++it)
17417 	res += (*it)*(*jt);
17418       v[j]=res;
17419     }
17420   }
17421 
17422   // P*wi->Pwi, assumes correct sizes
17423   // assumes w[0]=w[1]=...=w[k-1]=0 and P is identity except if rows and col >=k
householder_idnt_mult2(const matrix_double & P,const std::vector<giac_double> & w1,vector<giac_double> & w2,vector<giac_double> & Pw1,vector<giac_double> & Pw2,int k)17424   void householder_idnt_mult2(const matrix_double & P,const std::vector<giac_double> & w1,vector<giac_double> & w2,vector<giac_double> & Pw1,vector<giac_double> & Pw2,int k){
17425     Pw1.resize(w1.size());
17426     Pw2.resize(w2.size());
17427     int n=int(P.size());
17428     std::copy(w1.begin(),w1.begin()+k,Pw1.begin());
17429     std::copy(w2.begin(),w2.begin()+k,Pw2.begin());
17430     int j=k;
17431 #if 1
17432     for (;j<=n-2;j+=2){
17433       vector<giac_double>::const_iterator it0=P[j].begin()+k,it1=P[j+1].begin()+k,itend=P[j].end(),jt1=w1.begin()+k,jt2=w2.begin()+k;
17434       giac_double res10=0.0,res11=0.0,res20=0.0,res21=0.0;
17435       for (;it0!=itend;++jt1,++jt2,++it1,++it0){
17436 	giac_double j1=*jt1,j2=*jt2,i0=*it0,i1=*it1;
17437 	res10 += j1*i0;
17438 	res11 += j1*i1;
17439 	res20 += j2*i0;
17440 	res21 += j2*i1;
17441       }
17442       Pw1[j]=res10;
17443       Pw1[j+1]=res11;
17444       Pw2[j]=res20;
17445       Pw2[j+1]=res21;
17446     }
17447 #endif
17448     for (;j<n;++j){
17449       vector<giac_double>::const_iterator it=P[j].begin()+k,itend=P[j].end(),jt1=w1.begin()+k,jt2=w2.begin()+k;
17450       giac_double res1=0.0,res2=0.0;
17451       for (;it!=itend;++jt1,++jt2,++it){
17452 	res1 += (*it)*(*jt1);
17453 	res2 += (*it)*(*jt2);
17454       }
17455       Pw1[j]=res1;
17456       Pw2[j]=res2;
17457     }
17458   }
17459 
17460   // P->P-Pw1 w1* - Pw2 w2*
hessenberg_idnt_2p(matrix_double & P,const std::vector<giac_double> & Pw1,vector<giac_double> & Pw2,vector<giac_double> & w1,vector<giac_double> & w2)17461   void hessenberg_idnt_2p(matrix_double & P,const std::vector<giac_double> & Pw1,vector<giac_double> & Pw2,vector<giac_double> & w1,vector<giac_double> & w2){
17462     int qstart=0;
17463     int n=int(P.size()),jend=n;
17464     for (;qstart<n;++qstart){
17465       if (w1[qstart] || w2[qstart] || Pw1[qstart] || Pw2[qstart])
17466 	break;
17467     }
17468     int j=qstart;
17469 #if 1
17470     for (;j<=jend-2;j+=2){
17471       const giac_double wj10=2*Pw1[j], wj11=2*Pw1[j+1],wj20=2*Pw2[j],wj21=2*Pw2[j+1];
17472       giac_double * Pj0k=&P[j][qstart],* Pj1k=&P[j+1][qstart],*Pj0kend=Pj0k+(n-qstart);
17473       const giac_double *w1ptr=&w1[qstart], * w2ptr=&w2[qstart];
17474       for (;Pj0k<Pj0kend;){
17475 	giac_double w1k=*w1ptr,w2k=*w2ptr;
17476 	*Pj0k -= (wj10*w1k+wj20*w2k);
17477 	*Pj1k -= (wj11*w1k+wj21*w2k);
17478 	++Pj0k;++Pj1k;++w1ptr,++w2ptr;
17479       }
17480     }
17481 #endif
17482     for (;j<jend;++j){
17483       giac_double wj1=2*Pw1[j],wj2=2*Pw2[j];
17484       giac_double * Pjk=&P[j][qstart],*Pjkend=Pjk+(n-qstart);
17485       const giac_double *w1ptr=&w1[qstart],*w2ptr=&w2[qstart];
17486       for (;Pjk!=Pjkend;){
17487 	*Pjk -= (wj1*(*w1ptr)+wj2*(*w2ptr));
17488 	++w1ptr; ++w2ptr;++Pjk;
17489       }
17490     }
17491   }
17492 
qr_householder(matrix_double & H,int rstart,matrix_double & P,bool computeP,bool Pidn,bool transpose,int cstart=0,int cend=0,bool recurse=true,bool thin=true)17493   void qr_householder(matrix_double & H,int rstart,matrix_double & P,bool computeP,bool Pidn,bool transpose,int cstart=0,int cend=0,bool recurse=true,bool thin=true){
17494     // Let R be a Householder reflection with respect to w (normalized)
17495     // R=I-2 w w*
17496     // Then R H = H - 2 w (w*H) and R P = P - 2 w (w*P)
17497     // Application to qr
17498     // step k (k<=n-1), reduce column k by the reflector that swaps
17499     // the vector of column k row k to n scaled
17500     // with the k-th canonical vector
17501     // Ex. k=0, reflector swaps (a00,a10,...,an-10) with (1,0,0...) scaled
17502     // let alpha=sign(a00)*sqrt(sum_j=0..n-1 aj0^2),
17503     // swap u1=(a00,a10,...,an-10) u2=(alpha,0,...)
17504     // therefore w=(u1+u2) and normalize after
17505     // w=((a00+alpha),a10,...,an-10)
17506     // ||w||^2=(a00+alpha)^2+a10^2+...+an-10^2
17507     //        =(a00+alpha)^2+alpha^2-a00^2=2*alpha*(alpha+a00)
17508     // divide by r=sqrt(2*alpha*(alpha+a00))
17509     // For k=m, add m to all indices
17510     int n=int(H.size())-rstart,c=int(H.front().size()),cP=int(P.front().size());
17511     if (cstart>=c) return;
17512     if (cend<=0) cend=c;
17513     if (n<2)
17514       return;
17515     int lastcol=std::min(n,cend);
17516     if (debug_infolevel)
17517       CERR << CLOCK()*1e-6 << " Householder, computing H" << '\n';
17518 #ifndef GIAC_HAS_STO_38
17519     if (recurse && n>=c && cend-cstart>200){
17520       if (n<2*(cend-cstart))
17521 	thin=false;
17522       // if cstart, cend !=0, block-recursive version
17523       // H n rows, c1+c2 cols, n>=c1+c2, H=[A1|A2]=Q*[[R11,R12],[0,R22]]
17524       // A1 and A2 have n rows and c1, c2 columns
17525       // first step A1=Q1*[[R11],[0]] recursive call,
17526       // R11 c1 rows, c1 cols, R12 c1 rows, n-c1 cols, R22 c2 rows, n-c1 cols
17527       // tran(Q1)*A2=[[R12],[A22]]
17528       // A22=Q2*R22
17529       // [A1|A2]=Q1*[[R11,R12],[0,A22]]=Q1*[[Id,0],[0,Q2]]*[[R11,R12],[0,R22]]
17530       // tran(Q)=[[Id,0],[0,tran(Q2)]]*tran(Q1)
17531       // If tran(Q1)=[[Q11],[Q12]] then tran(Q)=[[Q11],[tran(Q2)*Q12]]
17532       // Q12 has n-c1 rows, Q2 has n-c2 rows
17533       int c1=(cend-cstart)/2,c2=cend-cstart-c1;
17534       qr_householder(H,rstart,P,true,true,true,cstart,cstart+c1,/* recurse*/ false,/* thin */false); // P is Q1
17535       //transpose_double(P); // P is tran(Q1)
17536       // R11 is in place in H, R21=0 also
17537       // temporary storage to compute tran(Q1)*A2
17538       // tranA2 c2 rows, n cols
17539       matrix_double tranA2; tranA2.reserve(giacmax(c2,n-c1));
17540       transpose_double(H,rstart,rstart+n,cstart+c1,cend,tranA2);
17541       matrix_double R(n,vector<giac_double>(n-c1));
17542       mmult_double(P,tranA2,R); // R n rows, c2 cols, n-c1 cols reserved for later use as tranQ12
17543       // QR on A22 stored in rows c1..n-1 of R
17544       // matrix_double Q2(n-c1,vector<giac_double>(n-c1));
17545       matrix_double & Q2 =tranA2; Q2.resize(n-c1);
17546       if (thin){
17547 	qr_householder(R,c1,Q2,false,true,true,0,0,/* recurse */true,thin);
17548       }
17549       else {
17550 	double_idn(Q2);
17551 	qr_householder(R,c1,Q2,computeP,true,true,0,0,/* recurse */true,/* thin */false);
17552 	// transpose_double(Q2);
17553       }
17554       for (int i=0;i<n;++i){
17555 	std::copy(R[i].begin(),R[i].end(),H[rstart+i].begin()+c1);
17556       }
17557       if (!thin){
17558 	// P is tran(Q1), Q12
17559 	matrix_double tmp;
17560 	transpose_double(P,c1,n,0,0,R); // R as tranQ12: n rows, n-c1 cols
17561 	// tran(Q2)*Q12
17562 	mmult_double(Q2,R,tmp); // tmp n-c1 rows, n cols
17563 	for (int i=0;i<n-c1;++i){
17564 	  swap(tmp[i],P[i+c1]);
17565 	}
17566       }
17567       if (!transpose)
17568 	transpose_double(P);
17569       if (debug_infolevel)
17570 	CERR << CLOCK()*1e-6 << " Householder end" << '\n';
17571       return;
17572     }
17573 #endif // GIAC_HAS_STO_38
17574     vector<giac_double> w(n),q(cend-cstart);
17575     // save w to compute P all at once at the end, this could also be done
17576     // inside the lower diagonal bloc of H
17577     vector<giac_double> Pw((lastcol*(2*n-lastcol+1))/2);
17578     int nreflectors=0;
17579     giac_double * Pwptr=&Pw.front();
17580     for (int m=cstart;m<lastcol;++m){
17581       giac_double alpha=0;
17582       for (int j=m;j<n;++j){
17583 	giac_double Hjm=H[j-cstart+rstart][m];
17584 	alpha += Hjm*Hjm;
17585       }
17586       alpha=std::sqrt(alpha);
17587       giac_double Hmm=H[m-cstart+rstart][m];
17588       if (alpha<=1e-15*absdouble(Hmm)){
17589 	Pwptr += n-m;
17590 	continue;
17591       }
17592       if (Hmm<0)
17593 	alpha=-alpha;
17594       giac_double r=std::sqrt(2*alpha*(alpha+Hmm));
17595       *Pwptr=w[m]=(Hmm+alpha)/r;
17596       ++Pwptr;
17597       for (int j=m+1;j<n;++Pwptr,++j){
17598 	*Pwptr=w[j]=H[j-cstart+rstart][m]/r;
17599       }
17600       ++nreflectors;
17601       householder_mult(w,H,q,m,true,m,n,rstart,cstart,cend);
17602       hessenberg_p_pass1(H,w,q,m,n,cend-cstart,rstart,cstart);
17603     }
17604     if (computeP){
17605       if (debug_infolevel)
17606 	CERR << CLOCK()*1e-6 << " Householder, computing P" << '\n';
17607       Pwptr=&Pw.front();
17608       if (Pidn){
17609 	// IMPROVE: if P is identity at the beginning, it is faster
17610 	// to compute (I-w_n w_n*) ... (I-w_1 w_1*) from left to right than
17611 	// starting from the right
17612 	// Indeed w_k has k first coord=0, therefore (I-w_n w_n*) ... (I-w_k w_k*)
17613 	// has only rows and columns k..n different from identity
17614 	// sum(k^2,k,1,n)=n^3/3 compared to sum(k*n,k,1,n)=n^3/2 operations
17615 	// (and also less cache misses)
17616 	int m=nreflectors-1;
17617 	vector<giac_double> w1(n),w2(n),Pw1(n),Pw2(n);
17618 	for (;m>=1;m-=2){
17619 	  // 2 operations P(I-w1w1*)(I-w2w2*)=P-2Pw1(w1*-2<w1|w2>w2*)-2Pw2 w2*
17620 	  for (int i=0;i<m-1;++i)
17621 	    w1[i]=w2[i]=0;
17622 	  w1[m-1]=0;
17623 	  Pwptr=&Pw[((m-1)*(2*n-m+2))/2];
17624 	  for (int i=m-1;i<n;++Pwptr,++i)
17625 	    w2[i]=*Pwptr;
17626 	  for (int i=m;i<n;++Pwptr,++i)
17627 	    w1[i]=*Pwptr;
17628 	  householder_idnt_mult2(P,w1,w2,Pw1,Pw2,m-1);
17629 	  double w1w2=2*dotvecteur(w1,w2);
17630 	  for (unsigned i=0;i<w1.size();++i){
17631 	    w1[i]-=w1w2*w2[i];
17632 	  }
17633 	  hessenberg_idnt_2p(P,Pw1,Pw2,w1,w2);
17634 	}
17635 	for (;m>=0;--m){
17636 	  for (int i=0;i<m;++i)
17637 	    w[i]=0;
17638 	  Pwptr=&Pw[0]; // m==0 here!
17639 	  for (int i=m;i<n;++Pwptr,++i)
17640 	    w[i]=*Pwptr;
17641 	  // householder_mult(P,w,qprime,m+1);
17642 	  householder_idn_mult(P,w,q,m);
17643 	  hessenberg_p_pass1(P,q,w,m,n,n);
17644 	}
17645 	if (debug_infolevel)
17646 	  CERR << CLOCK()*1e-6 << " Householder end" << '\n';
17647 	if (!transpose)
17648 	  transpose_double(P);
17649 	return;
17650       } // end P==identity
17651       for (int m=0;m<n-1;++m){
17652 	for (int i=0;i<m;++i)
17653 	  w[i]=0;
17654 	for (int i=m;i<n;++Pwptr,++i)
17655 	  w[i]=*Pwptr;
17656 	householder_mult(w,P,q,m,false);
17657 	hessenberg_p_pass1(P,w,q,m,n,n);
17658       }
17659     }
17660     if (debug_infolevel)
17661       CERR << CLOCK()*1e-6 << " Householder end" << '\n';
17662     if (!transpose)
17663       transpose_double(P);
17664   }
17665 
17666   // QR reduction, P is orthogonal and should be initialized to identity
17667   // trn(P)*H=original, Givens method
qr_ortho(std_matrix<gen> & H,std_matrix<gen> & P,bool computeP,GIAC_CONTEXT)17668   void qr_ortho(std_matrix<gen> & H,std_matrix<gen> & P,bool computeP,GIAC_CONTEXT){
17669     matrix_double H1;
17670     if (epsilon(contextptr)>=1e-15 && std_matrix_gen2std_matrix_giac_double(H,H1,true)){
17671       matrix_double P1;
17672       std_matrix_gen2std_matrix_giac_double(P,P1,true);
17673       // count 0 in H under the diagonal
17674       // if less than 20% Householder else Givens
17675       int count1=0,count2=0,L=int(H.size()),C=int(H.front().size());
17676       for (int i=1;i<L;++i){
17677 	const vector<giac_double> & Hi=H1[i];
17678 	for (int j=0;j<i && j<C;++count2,++j){
17679 	  if (Hi[j]==0.0)
17680 	    ++count1;
17681 	}
17682       }
17683       if (count1<=0.2*count2)
17684 	qr_householder(H1,0,P1,computeP,true,true,0,0,/* recurse */ true,/* thin */false);
17685       else
17686 	qr_givens(H1,0,P1,computeP,true,true,0,0,threads>1);
17687       std_matrix_giac_double2std_matrix_gen(P1,P);
17688       std_matrix_giac_double2std_matrix_gen(H1,H);
17689       return;
17690     }
17691     int n=int(H.size()),lastcol=std::min(n-1,int(H.front().size()));
17692     gen t,tn,tc,tabs,u,un,uc,tmp1,tmp2,norme;
17693     vecteur v1,v2;
17694     for (int m=0;m<lastcol;++m){
17695       if (debug_infolevel>=5)
17696 	CERR << "// Givens reduction line " << m << '\n';
17697       // check for a non zero coeff in the column m below ligne m
17698       int i=m;
17699       gen pivot=0;
17700       int pivotline=0;
17701       for (;i<n;++i){
17702 	t=H[i][m];
17703 	tabs=abs(t,contextptr);
17704 	if (is_strictly_greater(tabs,pivot,contextptr)){
17705 	  pivotline=i;
17706 	  pivot=tabs;
17707 	}
17708       }
17709       if (is_zero(pivot)) //not found
17710 	continue;
17711       i=pivotline;
17712       // exchange lines
17713       if (i>m){
17714 	swap(H[i],H[m]);
17715 	swap(P[i],P[m]);
17716       }
17717       // now coeff at line m column m is H[m][m]=t!=0
17718       // creation of zeros in lines i=m+1 and below
17719       for (i=m+1;i<n;++i){
17720 	// line operation
17721 	t=H[m][m];
17722 	if (is_zero(t)){
17723 	  swap(H[i],H[m]);
17724 	  swap(P[i],P[m]);
17725 	  t=H[m][m];
17726 	}
17727 	u=H[i][m];
17728 	if (is_zero(u))
17729 	  continue;
17730 	uc=conj(u,contextptr);
17731 	tc=conj(t,contextptr);
17732 	norme=sqrt(u*uc+t*tc,contextptr);
17733 	un=u/norme; tn=t/norme; uc=conj(un,contextptr);	tc=conj(tn,contextptr);
17734 	if (debug_infolevel>=3)
17735 	  CERR << "// i=" << i << " " << u <<'\n';
17736 	// H[m]=un*H[i]+tn*H[m] and H[i]=tn*H[i]-un*H[m];
17737 	linear_combination(uc,H[i],tc,H[m],plus_one,1,v1,1e-12,0);
17738 	linear_combination(tn,H[i],-un,H[m],plus_one,1,v2,1e-12,0);
17739 	swap(H[m],v1);
17740 	swap(H[i],v2);
17741 	linear_combination(uc,P[i],tc,P[m],plus_one,1,v1,1e-12,0);
17742 	linear_combination(tn,P[i],-un,P[m],plus_one,1,v2,1e-12,0);
17743 	swap(P[m],v1);
17744 	swap(P[i],v2);
17745       }
17746     }
17747   }
17748 
hessenberg_householder(matrix_double & H,matrix_double & P,bool compute_P)17749   void hessenberg_householder(matrix_double & H,matrix_double & P,bool compute_P){
17750     // Let R be a Householder reflection with respect to w (normalized)
17751     // R=I-2 w w*
17752     // Then R H R = H - 2 w q' -2 q w*
17753     // where v = Hw and q = v- scalar_product(w,v) w
17754     // and v'=wH and q'=v'-scalar_product(v',w) w*
17755     // # operations: 2n+2n^2 *, n+2n^2+,
17756     // And R P = P - 2 w (w*P)
17757     // # operations: 2n^2 *, 2n^2 +
17758     // Application to Hessenberg
17759     // step k (k<=n-2), reduce column k by the reflector that swaps
17760     // the vector of column k row k+1 to n scaled
17761     // with the k+1-th canonical vector
17762     // Ex. k=0, reflector swaps (0,a10,...,an-10) with (0,1,0...) scaled
17763     // let alpha=sign(a10)*sqrt(sum_j=1..n-1 aj0^2),
17764     // swap u1=(0,a10,...,an-10) u2=(0,alpha,0,...)
17765     // therefore w=(u1+u2) and normalize after
17766     // w=(0,(a10+alpha),a20,...,a-10)
17767     // ||w||^2=(a10+alpha)^2+a20^2+...+an-10^2
17768     //        =(a10+alpha)^2+alpha^2-a10^2=2*alpha*(alpha+a10)
17769     // divide by r=sqrt(2*alpha*(alpha+a10))
17770     // For k=m, add m to all indices
17771     int n=int(H.size());
17772     if (n<3)
17773       return;
17774     vector<giac_double> w(n),q(n),qprime(n);
17775     vector<giac_double> Pw((n*(n-1))/2); // save w to compute P all at once at the end
17776     giac_double * Pwptr=&Pw.front();
17777     for (int m=0;m<n-2;++m){
17778       giac_double alpha=0;
17779       for (int j=m+1;j<n;++j){
17780 	giac_double Hjm=H[j][m];
17781 	alpha += Hjm*Hjm;
17782       }
17783       alpha=std::sqrt(alpha);
17784       if (alpha<=1e-15*absdouble(H[m][m])){
17785 	Pwptr += n-m-1;
17786 	continue;
17787       }
17788       if (H[m+1][m]<0)
17789 	alpha=-alpha;
17790       giac_double r=std::sqrt(2*alpha*(alpha+H[m+1][m]));
17791       w[m]=0;
17792       *Pwptr=w[m+1]=(H[m+1][m]+alpha)/r;
17793       ++Pwptr;
17794       for (int j=m+2;j<n;++Pwptr,++j){
17795 	*Pwptr=w[j]=H[j][m]/r;
17796       }
17797 #if 1
17798       householder_mult2(H,w,q,qprime,m+1,true);
17799 #else
17800       householder_mult(H,w,q,m+1);
17801       householder_mult(w,H,qprime,m+1,true);
17802 #endif
17803       giac_double sp=dotvecteur(w,q);
17804       for (int j=0;j<n;++j){
17805 	q[j] -= sp*w[j];
17806 	qprime[j] -= sp*w[j];
17807       }
17808       // adjust H
17809       int j=0;
17810       for (;j<=m-2;j+=3){
17811 	giac_double qj=2*q[j],qj1=2*q[j+1],qj2=2*q[j+2];
17812 	giac_double * Hjk=&H[j][m+1],* Hjk1=&H[j+1][m+1],* Hjk2=&H[j+2][m+1],*wk=&w[m+1],*wkend=wk+(n-m-1);
17813 	for (;wk!=wkend;++Hjk,++Hjk1,++Hjk2,++wk){
17814 	  giac_double tmp=*wk;
17815 	  (*Hjk) -= qj* tmp;
17816 	  (*Hjk1) -= qj1* tmp;
17817 	  (*Hjk2) -= qj2* tmp;
17818 	}
17819       }
17820       for (;j<=n-3;j+=3){
17821 	giac_double wj0=2*w[j],wj1=2*w[j+1],qj0=2*q[j],qj1=2*q[j+1], wj2=2*w[j+2],qj2=2*q[j+2],tmpq,tmpw;
17822 	giac_double * Hj0k=&H[j][m],*Hj1k=&H[j+1][m],*Hj2k=&H[j+2][m],*wk=&w[m],*wkend=wk+(n-m),*qprimek=&qprime[m];
17823 	wkend-=8;
17824 	for (;wk<=wkend;){
17825 	  tmpq=*qprimek; tmpw=*wk;
17826 	  (*Hj0k) -= wj0*tmpq+qj0*tmpw;
17827 	  (*Hj1k) -= wj1*tmpq+qj1*tmpw;
17828 	  (*Hj2k) -= wj2*tmpq+qj2*tmpw;
17829 	  ++Hj0k,++Hj1k;++Hj2k;++qprimek,++wk;
17830 	  // 1
17831 	  tmpq=*qprimek; tmpw=*wk;
17832 	  (*Hj0k) -= wj0*tmpq+qj0*tmpw;
17833 	  (*Hj1k) -= wj1*tmpq+qj1*tmpw;
17834 	  (*Hj2k) -= wj2*tmpq+qj2*tmpw;
17835 	  ++Hj0k,++Hj1k;++Hj2k;++qprimek,++wk;
17836 	  // 2
17837 	  tmpq=*qprimek; tmpw=*wk;
17838 	  (*Hj0k) -= wj0*tmpq+qj0*tmpw;
17839 	  (*Hj1k) -= wj1*tmpq+qj1*tmpw;
17840 	  (*Hj2k) -= wj2*tmpq+qj2*tmpw;
17841 	  ++Hj0k,++Hj1k;++Hj2k;++qprimek,++wk;
17842 	  // 3
17843 	  tmpq=*qprimek; tmpw=*wk;
17844 	  (*Hj0k) -= wj0*tmpq+qj0*tmpw;
17845 	  (*Hj1k) -= wj1*tmpq+qj1*tmpw;
17846 	  (*Hj2k) -= wj2*tmpq+qj2*tmpw;
17847 	  ++Hj0k,++Hj1k;++Hj2k;++qprimek,++wk;
17848 	  // 4
17849 	  tmpq=*qprimek; tmpw=*wk;
17850 	  (*Hj0k) -= wj0*tmpq+qj0*tmpw;
17851 	  (*Hj1k) -= wj1*tmpq+qj1*tmpw;
17852 	  (*Hj2k) -= wj2*tmpq+qj2*tmpw;
17853 	  ++Hj0k,++Hj1k;++Hj2k;++qprimek,++wk;
17854 	  // 5
17855 	  tmpq=*qprimek; tmpw=*wk;
17856 	  (*Hj0k) -= wj0*tmpq+qj0*tmpw;
17857 	  (*Hj1k) -= wj1*tmpq+qj1*tmpw;
17858 	  (*Hj2k) -= wj2*tmpq+qj2*tmpw;
17859 	  ++Hj0k,++Hj1k;++Hj2k;++qprimek,++wk;
17860 	  // 6
17861 	  tmpq=*qprimek; tmpw=*wk;
17862 	  (*Hj0k) -= wj0*tmpq+qj0*tmpw;
17863 	  (*Hj1k) -= wj1*tmpq+qj1*tmpw;
17864 	  (*Hj2k) -= wj2*tmpq+qj2*tmpw;
17865 	  ++Hj0k,++Hj1k;++Hj2k;++qprimek,++wk;
17866 	  // 7
17867 	  tmpq=*qprimek; tmpw=*wk;
17868 	  (*Hj0k) -= wj0*tmpq+qj0*tmpw;
17869 	  (*Hj1k) -= wj1*tmpq+qj1*tmpw;
17870 	  (*Hj2k) -= wj2*tmpq+qj2*tmpw;
17871 	  ++Hj0k,++Hj1k;++Hj2k;++qprimek,++wk;
17872 	}
17873 	wkend+=8;
17874 	for (;wk!=wkend;){
17875 	  tmpq=*qprimek; tmpw=*wk;
17876 	  (*Hj0k) -= wj0*tmpq+qj0*tmpw;
17877 	  (*Hj1k) -= wj1*tmpq+qj1*tmpw;
17878 	  (*Hj2k) -= wj2*tmpq+qj2*tmpw;
17879 	  ++Hj0k,++Hj1k;++Hj2k;++qprimek,++wk;
17880 	}
17881       }
17882       for (;j<n;++j){
17883 	giac_double wj=2*w[j],qj=2*q[j];
17884 	giac_double * Hjk=&H[j][m],*wk=&w[m],*wkend=wk+(n-m),*qprimek=&qprime[m];
17885 	for (;wk!=wkend;++Hjk,++qprimek,++wk){
17886 	  (*Hjk) -= wj*(*qprimek)+qj*(*wk);
17887 	}
17888       }
17889     }
17890     if (compute_P){
17891       if (debug_infolevel)
17892 	CERR << CLOCK()*1e-6 << " Householder, computing P" << '\n';
17893       if (is_identity(P)){
17894 	// IMPROVE: if P is identity at the beginning, it is probably faster
17895 	// to compute (I-w_n w_n*) ... (I-w_1 w_1*) from left to right than
17896 	// starting from the right like now
17897 	// Indeed w_k has k first coord=0, therefore (I-w_n w_n*) ... (I-w_k w_k*)
17898 	// has only rows and columns k..n different from identity
17899 	// sum(k^2,k,1,n)=n^3/3 compared to sum(k*n,k,1,n)=n^3/2 operations
17900 	// (and also less cache misses)
17901 	int m=n-3;
17902 	vector<giac_double> w1(n),w2(n),Pw1(n),Pw2(n);
17903 	for (;m>=1;m-=2){
17904 	  // 2 operations P(I-w1w1*)(I-w2w2*)=P-2Pw1(w1*-2<w1|w2>w2*)-2Pw2 w2*
17905 	  for (int i=0;i<m;++i)
17906 	    w1[i]=w2[i]=0;
17907 	  w1[m]=0;
17908 	  Pwptr=&Pw[((m-1)*(2*n-(m-1)-1))/2];
17909 	  for (int i=m;i<n;++Pwptr,++i)
17910 	    w2[i]=*Pwptr;
17911 	  for (int i=m+1;i<n;++Pwptr,++i)
17912 	    w1[i]=*Pwptr;
17913 	  householder_idnt_mult2(P,w1,w2,Pw1,Pw2,m);
17914 	  double w1w2=2*dotvecteur(w1,w2);
17915 	  for (unsigned i=0;i<w1.size();++i){
17916 	    w1[i]-=w1w2*w2[i];
17917 	  }
17918 	  hessenberg_idnt_2p(P,Pw1,Pw2,w1,w2);
17919 	}
17920 	for (;m>=0;--m){
17921 	  for (int i=0;i<=m;++i)
17922 	    w[i]=0;
17923 	  Pwptr=&Pw[(m*(2*n-m-1))/2];
17924 	  for (int i=m+1;i<n;++Pwptr,++i)
17925 	    w[i]=*Pwptr;
17926 	  // householder_mult(P,w,qprime,m+1);
17927 	  householder_idn_mult(P,w,qprime,m+1);
17928 	  hessenberg_p_pass1(P,qprime,w,m+1,n,n);
17929 	}
17930 	return;
17931       }
17932       Pwptr=&Pw.front();
17933       for (int m=0;m<n-2;++m){
17934 	for (int i=0;i<=m;++i)
17935 	  w[i]=0;
17936 	for (int i=m+1;i<n;++Pwptr,++i)
17937 	  w[i]=*Pwptr;
17938 	householder_mult(w,P,qprime,m+1,false);
17939 	int jstart=m+1;
17940 	bool done=false;
17941 	if (!done)
17942 	  hessenberg_p_pass1(P,w,qprime,jstart,n,n);
17943       }
17944     }
17945   }
17946 
17947   struct thread_hessenberg_p_t {
17948     matrix_double * P;
17949     vector<double> * oper;
17950     int cstart,cend;
17951   };
17952 
bi_tri_linear_combination(giac_double u,giac_double t,giac_double u2,giac_double t2,giac_double U,giac_double T,giac_double U2,giac_double T2,vector<giac_double> & p1,vector<giac_double> & p2,vector<giac_double> & p3,vector<giac_double> & P3,int cstart,int cend)17953   void bi_tri_linear_combination(giac_double u,giac_double t,giac_double u2,giac_double t2,giac_double U,giac_double T,giac_double U2,giac_double T2,vector<giac_double> & p1,vector<giac_double> & p2,vector<giac_double> & p3,vector<giac_double> & P3,int cstart,int cend){
17954     // p1=t*p1+u*p2 && p2=t*p2-u*p1 //bi_linear_combination_CA(u,H[m+2],t,H[m+1],m,nH);
17955     // then p1=t2*p1+u2*p3 && p3=t2*p3-u2*p1 // bi_linear_combination_CA(u2,H[m+3],t2,H[m+1],m,nH);
17956     // then same with uppercase
17957     // 8 read (4 always at the same location)/4 write for 2
17958     vector<giac_double>::iterator p1p=p1.begin()+cstart,p1e=cend<=0?p1.end():p1.begin()+cend,p2p=p2.begin()+cstart,p3p=p3.begin()+cstart,P3p=P3.begin()+cstart;
17959     p1e-=2;
17960     for (;p1p<=p1e;){
17961       giac_double p1_,p2_,p3_;
17962       p1_=*p1p;
17963       p2_=*p2p;
17964       p3_=t*p1_+u*p2_;
17965       p1_=t*p2_-u*p1_; // stored in p2_ renamed p1_ for second stage
17966       p2_=*p3p;
17967       *p1p=t2*p3_+u2*p2_;
17968       p2_=t2*p2_-u2*p3_; // stored in p3_ renamed p2_ for second stage
17969       p3_=*P3p;
17970       *p3p=T*p2_-U*p1_; // stored in p2 alias p3p at second stage
17971       p2_=T*p1_+U*p2_;
17972       *p2p=T2*p2_+U2*p3_;
17973       *P3p=T2*p3_-U2*p2_;
17974       ++P3p,++p3p,++p2p,++p1p;
17975       p1_=*p1p;
17976       p2_=*p2p;
17977       p3_=t*p1_+u*p2_;
17978       p1_=t*p2_-u*p1_; // stored in p2_ renamed p1_ for second stage
17979       p2_=*p3p;
17980       *p1p=t2*p3_+u2*p2_;
17981       p2_=t2*p2_-u2*p3_; // stored in p3_ renamed p2_ for second stage
17982       p3_=*P3p;
17983       *p3p=T*p2_-U*p1_; // stored in p2 alias p3p at second stage
17984       p2_=T*p1_+U*p2_;
17985       *p2p=T2*p2_+U2*p3_;
17986       *P3p=T2*p3_-U2*p2_;
17987       ++P3p,++p3p,++p2p,++p1p;
17988     }
17989     p1e+=2;
17990     for (;p1p!=p1e;){
17991       giac_double p1_,p2_,p3_;
17992       p1_=*p1p;
17993       p2_=*p2p;
17994       p3_=t*p1_+u*p2_;
17995       p1_=t*p2_-u*p1_; // stored in p2_ renamed p1_ for second stage
17996       p2_=*p3p;
17997       *p1p=t2*p3_+u2*p2_;
17998       p2_=t2*p2_-u2*p3_; // stored in p3_ renamed p2_ for second stage
17999       p3_=*P3p;
18000       *p3p=T*p2_-U*p1_; // stored in p2 alias p3p at second stage
18001       p2_=T*p1_+U*p2_;
18002       *p2p=T2*p2_+U2*p3_;
18003       *P3p=T2*p3_-U2*p2_;
18004       ++P3p,++p3p,++p2p,++p1p;
18005     }
18006   }
18007 
18008   // called from schur in pass2 (after initial reduction to Hessenberg)
do_hessenberg_p(matrix_double & P,vector<giac_double> & oper,int cstart,int cend)18009   void do_hessenberg_p(matrix_double &P,vector<giac_double> & oper,int cstart,int cend){
18010     int opindex=0;
18011     while (opindex<=int(oper.size())-3){
18012       int optype=int(oper[opindex]); // 3 for 3 lines per op, 2 for 2 lines per op
18013       if (optype!=oper[opindex])
18014 	gensizeerr("Internal error");
18015       ++opindex;
18016       int firstrow=int(oper[opindex]);
18017       if (firstrow!=oper[opindex])
18018 	gensizeerr("Internal error");
18019       ++opindex;
18020       int n=int(oper[opindex]);
18021       if (n!=oper[opindex])
18022 	gensizeerr("Internal error");
18023       ++opindex;
18024       int m=firstrow;
18025       if (optype==-2){
18026 #if 1
18027 	bi_linear_combination_AC(oper[opindex],P[firstrow],oper[opindex+1],P[n],cstart,cend);
18028 #else
18029 	bi_linear_combination_CA(oper[opindex],P[firstrow],oper[opindex+1],P[n],cstart,cend);
18030 	// must swap from cstart to cend only!
18031 	vector<giac_double> & Pf=P[firstrow];
18032 	vector<giac_double> & Pn=P[n];
18033 	for (unsigned j=cstart;j<cend;++j){
18034 	  giac_double tmp=Pf[j];
18035 	  Pf[j]=Pn[j];
18036 	  Pn[j]=tmp;
18037 	}
18038 #endif
18039 	opindex+=2;
18040 	continue;
18041       }
18042       if (optype==2){
18043 	for (int m=firstrow;m<n-2;opindex+=2,++m)
18044 	  bi_linear_combination_CA(oper[opindex],P[m+2],oper[opindex+1],P[m+1],cstart,cend);
18045 	continue;
18046       }
18047       if (optype==-3){
18048 	tri_linear_combination(oper[opindex],P[n],oper[opindex+1],P[n+1],oper[opindex+2],P[n+2],oper[opindex+3],oper[opindex+4],oper[opindex+5],cstart,cend);
18049 	opindex+=6;
18050 	continue;
18051       }
18052       if (optype!=3)
18053 	gensizeerr("Internal error in do_hessenberg_p");
18054       if (int(oper.size())-opindex<4*(n-2-m))
18055 	gensizeerr("Internal error in do_hessenberg_p");
18056       if (debug_infolevel>2){
18057 	CERR << "flushing optype=3 " << m << " " << n ;
18058 	if (debug_infolevel>3)
18059 	  CERR << ":" << vector<giac_double>(&oper[opindex],&oper[opindex+4*(n-2-m)]);
18060 	CERR << '\n';  // << " on " << P << '\n';
18061       }
18062 #if 0
18063       for (;m<n-4;opindex+=8,m+=2){
18064 	if (oper[opindex]==0 && oper[opindex+1]==0)
18065 	  break;
18066 	bi_tri_linear_combination(oper[opindex],oper[opindex+1],oper[opindex+2],oper[opindex+3],oper[opindex+4],oper[opindex+5],oper[opindex+6],oper[opindex+7],P[m+1],P[m+2],P[m+3],P[m+4],cstart,cend);
18067       }
18068 #endif
18069       for (;m<n-2;opindex+=4,++m){
18070 	giac_double u=oper[opindex];
18071 	giac_double t=oper[opindex+1];
18072 	if (u==0 && t==0)
18073 	  continue;
18074 	giac_double u2=oper[opindex+2];
18075 	giac_double t2=oper[opindex+3];
18076 	// P[m+1]=t*P[m+1]+u*P[m+2] && P[m+2]=t*P[m+2]-u*P[m+1] // bi_linear_combination_CA(u,H[m+2],t,H[m+1],m,nH);
18077 	// then P[m+1]=t2*P[m+1]+u2*P[m+3] && P[m+3]=-u2*P[m+1]+t2*P[m+3] // bi_linear_combination_CA(u2,H[m+3],t2,H[m+1],m,nH);
18078 	if (m!=n-3)
18079 	  tri_linear_combination(u,P[m+2],t,P[m+1],u2,P[m+3],t2,cstart,cend);
18080 	else
18081 	  bi_linear_combination_CA(u,P[m+2],t,P[m+1],cstart,cend);
18082       }
18083     }
18084   }
18085 
do_hessenberg_p(void * ptr)18086   void * do_hessenberg_p(void *ptr){
18087     thread_hessenberg_p_t * p=(thread_hessenberg_p_t *)(ptr);
18088     matrix_double & P = *p->P;
18089     vector<double> & oper = *p->oper;
18090     int cstart=p->cstart;
18091     int cend=p->cend;
18092     do_hessenberg_p(P,oper,cstart,cend);
18093     return ptr;
18094 #if 0
18095     // cut P in smaller slices? (cache)
18096     double slicesize=P.size()*double(cend-cstart);
18097     if (slicesize<6e4)
18098       do_hessenberg_p(P,oper,cstart,cend);
18099     else {
18100       int cstep=int(std::ceil(6e4/P.size())),cstop;
18101       for (;cstart<cend;cstart=cstop){
18102 	cstop=cstart+cstep;
18103 	if (cstop>cend)
18104 	  cstop=cend;
18105 	do_hessenberg_p(P,oper,cstart,cstop);
18106       }
18107     }
18108     return ptr;
18109 #endif
18110   }
18111 
hessenberg_ortho3_flush_p(matrix_double & P,bool compute_P,vector<giac_double> & oper,bool force_flush)18112   void hessenberg_ortho3_flush_p(matrix_double & P,bool compute_P,vector<giac_double> & oper,bool force_flush){
18113     if (oper.empty()) return;
18114     if (!compute_P){
18115       oper.clear();
18116       return;
18117     }
18118     if (!force_flush){
18119       if (oper.size()<1000 || oper.size()<P.size()*(P.size()/5.))
18120 	return;
18121     }
18122     if (debug_infolevel>2)
18123       CERR << CLOCK()*1e-6 << "hessenberg_ortho3 compute P, flush size " << oper.size() << '\n';
18124     int nH=int(P.size());
18125     int cstart=0,cstep=nH;
18126 #ifdef HAVE_LIBPTHREAD
18127     int cend,nthreads=threads_allowed?threads:1;
18128     if (nthreads>1 && nH*oper.size()>1e6){
18129       pthread_t tab[nthreads-1];
18130       thread_hessenberg_p_t hessenbergparam[nthreads];
18131       cstep=int(std::ceil(cstep/double(nthreads)));
18132       for (int j=0;j<nthreads;++j){
18133 	cend=cstart+cstep;
18134 	if (cend>nH) cend=nH;
18135 	thread_hessenberg_p_t tmp={&P,&oper,cstart,cend};
18136 	hessenbergparam[j]=tmp;
18137 	cstart=cend;
18138 	bool res=true;
18139 	if (j<nthreads-1)
18140 	  res=pthread_create(&tab[j],(pthread_attr_t *) NULL,do_hessenberg_p,(void *) &hessenbergparam[j]);
18141 	if (res)
18142 	  do_hessenberg_p((void *)&hessenbergparam[j]);
18143       }
18144       for (int j=0;j<nthreads;++j){
18145 	void * ptr=(void *)&nthreads; // non-zero initialisation
18146 	if (j<nthreads-1)
18147 	  pthread_join(tab[j],&ptr);
18148       }
18149       oper.clear();
18150       if (debug_infolevel>2)
18151 	CERR << CLOCK()*1e-6 << "hessenberg_ortho3 end compute P " << '\n';
18152       return;
18153     }
18154 #endif
18155     thread_hessenberg_p_t tmp={&P,&oper,0,nH};
18156     do_hessenberg_p((void *)&tmp);
18157     if (debug_infolevel>2)
18158       CERR << CLOCK()*1e-6 << "hessenberg_ortho3 end compute P" << '\n';
18159     oper.clear();
18160   }
18161 
hessenberg_ortho(matrix_double & H,matrix_double & P,int firstrow,int n,bool compute_P,int already_zero,vector<giac_double> & oper)18162   void hessenberg_ortho(matrix_double & H,matrix_double & P,int firstrow,int n,bool compute_P,int already_zero,vector<giac_double> & oper){
18163     matrix_double::iterator Hbegin=H.begin();
18164     // vector<giac_double>::iterator Hiterator,Hjmptr,Hjiptr;
18165     int nH=int(H.size());
18166     if (n<0 || n>nH)
18167       n=nH;
18168     if (firstrow<0 || firstrow>n)
18169       firstrow=0;
18170     if (already_zero==2){
18171       oper.push_back(2);
18172       oper.push_back(firstrow);
18173       oper.push_back(n);
18174     }
18175     giac_double t,u,norme;
18176     for (int m=firstrow;m<n-2;++m){
18177       if (debug_infolevel>=5)
18178 	CERR << "// hessenberg reduction line " << m << '\n';
18179       // check for a non zero coeff in the column m below ligne m+1
18180       int i=m+1;
18181       int nend=i+already_zero;
18182       if (nend>n) nend=n;
18183       for (i=m+2;i<nend;++i){
18184 	u=H[i][m];
18185 	if (u==0){
18186 	  //CERR << "u=0"<<'\n';
18187 	  if (compute_P &&already_zero==2){
18188 	    oper.push_back(1);
18189 	    oper.push_back(0);
18190 	  }
18191 	  continue;
18192 	}
18193 	// line operation
18194 	t=H[m+1][m];
18195 	norme=std::sqrt(u*u+t*t);
18196 	u=u/norme; t=t/norme;
18197 	if (debug_infolevel>=5)
18198 	  CERR << "// i=" << i << " " << u <<'\n';
18199 	// H[m+1]=un*H[i]+tn*H[m+1] and H[i]=tn*H[i]-un*H[m+1];
18200 	bi_linear_combination_CA(u,H[i],t,H[m+1],m,nH);
18201 	// column operation:
18202 	int nstop=nend+already_zero-1;
18203 	if (nstop>nH)
18204 	  nstop=nH;
18205 	matrix_double::iterator Hjptr=H.begin(),Hjend=Hjptr+nstop;
18206 	for (;Hjptr!=Hjend;++Hjptr){
18207 	  giac_double *Hj=&Hjptr->front();
18208 	  giac_double &Hjm=Hj[m+1];
18209 	  giac_double & Hji=Hj[i];
18210 	  giac_double tmp=Hji;
18211 	  Hji=-u*Hjm+t*tmp;
18212 	  Hjm=t*Hjm+u*tmp;
18213 	}
18214 	if (compute_P){
18215 	  if (already_zero==2){
18216 	    oper.push_back(u);
18217 	    oper.push_back(t);
18218 	  }
18219 	  else {
18220 	    hessenberg_ortho3_flush_p(P,compute_P,oper,true);
18221 	    bi_linear_combination_CA(u,P[i],t,P[m+1],0,nH);
18222 	  }
18223 	}
18224       } // for i=m+2...
18225     } // for int m=firstrow ...
18226     if (debug_infolevel>2)
18227       CERR << CLOCK()*1e-6 << " hessenberg_ortho clean subdiagonal begin" << '\n';
18228     // make 0 below subdiagonal (i<nH all matrix, i<n only relevant lines/column)
18229     int nstop=already_zero?n:nH;
18230     for (int i=2;i<nstop;i++){
18231       vector<giac_double>::iterator it=H[i].begin(),itend=it+i-1; // or min(i-1,n);
18232       for (;it!=itend;++it){
18233 	*it=0;
18234       }
18235     }
18236     if (debug_infolevel>2)
18237       CERR << CLOCK()*1e-6 << " hessenberg_ortho clean subdiagonal end" << '\n';
18238     hessenberg_ortho3_flush_p(P,compute_P,oper,false);
18239   }
18240 
hessenberg_ortho3(matrix_double & H,matrix_double & P,int firstrow,int n,bool compute_P,vector<giac_double> & oper)18241   void hessenberg_ortho3(matrix_double & H,matrix_double & P,int firstrow,int n,bool compute_P,vector<giac_double> & oper){
18242     int nH=int(H.size());
18243     if (n<0 || n>nH)
18244       n=nH;
18245     if (firstrow<0 || firstrow>n)
18246       firstrow=0;
18247     giac_double t,u,t2,u2,norme;
18248     // vector<giac_double> oper(4*(n-2-firstrow));
18249     oper.reserve(oper.size()+3+4*(n-2-firstrow));
18250     oper.push_back(3); // number of lines involved
18251     oper.push_back(firstrow);
18252     oper.push_back(n);
18253     int opstart=int(oper.size());
18254     for (int m=firstrow;m<n-2;++m){
18255       // check for a non zero coeff in the column m line m+1 and m+2
18256       int nstop=m+6;
18257       if (nstop>nH)
18258 	nstop=nH;
18259       t=H[m+1][m];
18260       u=H[m+2][m];
18261       t2=1; u2=0;
18262       // line operation
18263       norme=std::sqrt(u*u+t*t);
18264       if (norme==0){//<=1e-16*absdouble(H[m][m])){
18265 	CERR << m << " " << n-3 << '\n';
18266 	u=0; t=1; norme=0;
18267 	if (m==n-3) {
18268 	  oper.push_back(u);
18269 	  oper.push_back(t);
18270 	  oper.push_back(u2);
18271 	  oper.push_back(t2);
18272 	  break;
18273 	}
18274       }
18275       else {
18276 	u /= norme; t /= norme;
18277       }
18278       if (m==n-3){
18279 	// H[m+2]=u*H[m+2]+t*H[m+1] and H[m+1]=t*H[m+2]-u*H[m+1];
18280 	// if (m!=n-3) CERR << m << " " << n-3 << '\n';
18281 	bi_linear_combination_CA(u,H[m+2],t,H[m+1],m,nH);
18282 	H[m+2][m]=0;
18283 	for (int j=m+1;j<nstop;++j){
18284 	  vector<giac_double> & Hj=H[j];
18285 	  giac_double & Hjm=Hj[m+1];
18286 	  giac_double & Hj1=Hj[m+2];
18287 	  giac_double tmp=t*Hjm+u*Hj1;
18288 	  Hj1=t*Hj1-u*Hjm;
18289 	  Hjm=tmp;
18290 	}
18291       }
18292       else {
18293 	t2=norme;
18294 	u2=H[m+3][m];
18295 	norme=std::sqrt(u2*u2+t2*t2);
18296 	u2 /= norme; t2 /= norme;
18297 #if 1
18298 	tri_linear_combination(u,H[m+2],t,H[m+1],u2,H[m+3],t2,m);
18299 #else
18300 	bi_linear_combination_CA(u,H[m+2],t,H[m+1],m,nH);
18301 	bi_linear_combination_CA(u2,H[m+3],t2,H[m+1],m,nH);
18302 #endif
18303 	H[m+2][m]=0;
18304 	H[m+3][m]=0;
18305 	// column operation lines m+1 to nstop(=m+6), cols. m+1/2/3
18306 	matrix_double::iterator Hjptr=H.begin(),Hjend=Hjptr+nstop;
18307 	for (Hjptr+=m+1;Hjptr!=Hjend;++Hjptr){
18308 	  giac_double * Hj=&(*Hjptr)[m+1];
18309 	  giac_double tmp0=*Hj;
18310 	  ++Hj;
18311 	  giac_double tmp1=*Hj;
18312 	  *Hj=-u*tmp0+t*tmp1;
18313 	  ++Hj;
18314 	  tmp0=t*tmp0+u*tmp1;
18315 	  tmp1=*Hj;
18316 	  *Hj=-u2*tmp0+t2*tmp1;
18317 	  Hj[-2]=t2*tmp0+u2*tmp1;
18318 	}
18319       }
18320       oper.push_back(u);
18321       oper.push_back(t);
18322       oper.push_back(u2);
18323       oper.push_back(t2);
18324     } // for int m=firstrow ...
18325     // finish work on H columns
18326     int j=0,opindex;
18327 #if 1
18328     for (;j<n-4;j+=3){
18329       giac_double * Hj=&H[j].front(),*Hjend=Hj+n-2,*Hj1=&H[j+1].front(),*Hj2=&H[j+2].front();
18330       opindex=opstart;
18331       if (j>firstrow){
18332 	int decal=(j-firstrow);
18333 	Hj += decal;
18334 	Hj1 += decal;
18335 	Hj2 += decal;
18336 	opindex += 4*decal;
18337       }
18338       Hj += firstrow;
18339       Hj1 += firstrow;
18340       Hj2 += firstrow;
18341       // line j, column j (or firstrow), do operations from index j
18342       // (previous operations from oper were done before)
18343       giac_double *opptr=&oper[opindex];
18344       ++Hj; ++Hj1; ++Hj2;
18345       if (Hj+1>=Hjend)
18346 	break;
18347       giac_double t0mp0=*Hj,t0mp1=Hj[1],t0mpa,t0mpb,U,T;
18348       if (j>=firstrow){
18349 	U=*opptr;
18350 	++opptr;
18351 	T=*opptr;
18352 	++opptr;
18353 	t0mpa=-U*t0mp0+T*t0mp1; // Hj[1] after 1st oper
18354 	t0mp0=T*t0mp0+U*t0mp1; // Hj[0] after 1st oper
18355 	t0mpb=Hj[2];
18356 	U=*opptr;
18357 	++opptr;
18358 	T=*opptr;
18359 	++opptr;
18360 	t0mp1=-U*t0mp0+T*t0mpb; // Hj[2] after 2nd oper (in tmp1 for next iter)
18361 	*Hj=T*t0mp0+U*t0mpb; // Hj[0] after 2nd oper, stored
18362 	t0mp0=t0mpa; // for next iteration
18363 	++Hj; ++Hj1; ++Hj2;
18364       }
18365       giac_double t1mp0=*Hj1,t1mp1=Hj1[1],t1mpa,t1mpb;
18366       if (j+1>=firstrow){
18367 	U=*opptr;
18368 	++opptr;
18369 	T=*opptr;
18370 	++opptr;
18371 	t0mpa=-U*t0mp0+T*t0mp1; // Hj[1] after 1st oper
18372 	t0mp0=T*t0mp0+U*t0mp1; // Hj[0] after 1st oper
18373 	t1mpa=-U*t1mp0+T*t1mp1;
18374 	t1mp0=T*t1mp0+U*t1mp1;
18375 	t0mpb=Hj[2];
18376 	t1mpb=Hj1[2];
18377 	U=*opptr;
18378 	++opptr;
18379 	T=*opptr;
18380 	++opptr;
18381 	t0mp1=-U*t0mp0+T*t0mpb; // Hj[2] after 2nd oper (in t0mp1 for next iter)
18382 	*Hj=T*t0mp0+U*t0mpb; // Hj[0] after 2nd oper, stored
18383 	t0mp0=t0mpa; // for next iteration
18384 	++Hj;
18385 	t1mp1=-U*t1mp0+T*t1mpb;
18386 	*Hj1=T*t1mp0+U*t1mpb;
18387 	t1mp0=t1mpa;
18388 	++Hj1;
18389 	++Hj2;
18390       }
18391       giac_double t2mp0=*Hj2,t2mp1=Hj2[1],t2mpa,t2mpb;
18392       for (;;){
18393 	U=*opptr;
18394 	++opptr;
18395 	T=*opptr;
18396 	++opptr;
18397 	t0mpa=-U*t0mp0+T*t0mp1; // Hj[1] after 1st oper
18398 	t0mp0=T*t0mp0+U*t0mp1; // Hj[0] after 1st oper
18399 	t1mpa=-U*t1mp0+T*t1mp1;
18400 	t1mp0=T*t1mp0+U*t1mp1;
18401 	t2mpa=-U*t2mp0+T*t2mp1;
18402 	t2mp0=T*t2mp0+U*t2mp1;
18403 	if (Hj==Hjend) break;
18404 	t0mpb=Hj[2];
18405 	t1mpb=Hj1[2];
18406 	t2mpb=Hj2[2];
18407 	U=*opptr;
18408 	++opptr;
18409 	T=*opptr;
18410 	++opptr;
18411 	t0mp1=-U*t0mp0+T*t0mpb; // Hj[2] after 2nd oper (in t0mp1 for next iter)
18412 	*Hj=T*t0mp0+U*t0mpb; // Hj[0] after 2nd oper, stored
18413 	t0mp0=t0mpa; // for next iteration
18414 	++Hj;
18415 	t1mp1=-U*t1mp0+T*t1mpb;
18416 	*Hj1=T*t1mp0+U*t1mpb;
18417 	t1mp0=t1mpa;
18418 	++Hj1;
18419 	t2mp1=-U*t2mp0+T*t2mpb;
18420 	*Hj2=T*t2mp0+U*t2mpb;
18421 	t2mp0=t2mpa;
18422 	++Hj2;
18423       }
18424       *Hj=t0mp0;
18425       Hj[1]=t0mpa;
18426       *Hj1=t1mp0;
18427       Hj1[1]=t1mpa;
18428       *Hj2=t2mp0;
18429       Hj2[1]=t2mpa;
18430     }
18431 #endif
18432     for (;j<n-2;++j){
18433       giac_double * Hj=&H[j].front(),*Hjend=Hj+n;
18434       opindex=opstart;
18435       if (j>firstrow){
18436 	int decal=(j-firstrow);
18437 	Hj += decal;
18438 	opindex += 4*decal;
18439       }
18440       Hj += firstrow;
18441       // line j, column j (or firstrow), do operations from index j
18442       // (previous operations from oper were done before)
18443       giac_double *opptr=&oper[opindex];
18444       ++Hj;
18445       giac_double tmp0=*Hj,tmp1=Hj[1],tmpa;
18446       for (Hjend-=2;;){
18447 	giac_double tmpb,U,T;
18448 	U=*opptr;
18449 	++opptr;
18450 	T=*opptr;
18451 	++opptr;
18452 	tmpa=-U*tmp0+T*tmp1; // Hj[1] after 1st oper
18453 	tmp0=T*tmp0+U*tmp1; // Hj[0] after 1st oper
18454 	if (Hj==Hjend) break;
18455 	tmpb=Hj[2];
18456 	U=*opptr;
18457 	++opptr;
18458 	T=*opptr;
18459 	++opptr;
18460 	tmp1=-U*tmp0+T*tmpb; // Hj[2] after 2nd oper (in tmp1 for next iter)
18461 	*Hj=T*tmp0+U*tmpb; // Hj[0] after 2nd oper, stored
18462 	tmp0=tmpa; // for next iteration
18463 	++Hj;
18464       }
18465       *Hj=tmp0;
18466       Hj[1]=tmpa;
18467     }
18468     hessenberg_ortho3_flush_p(P,compute_P,oper,false);
18469   }
18470 
18471   // Hessenberg reduction, P is orthogonal and should be initialized to identity
18472   // trn(P)*H*P=original
18473   // already_zero is either <=0 or an integer such that H[i][j]==0 if i>j+already_zero
18474   // (already_zero==1 if H is hessenberg, ==2 or 3 for Francis algorithm)
tri_linear_combination(const giac_double & c1,const vector<giac_double> & x1,const giac_double & c2,const vector<giac_double> & x2,const giac_double & c3,const vector<giac_double> & x3,vector<giac_double> & y)18475   void tri_linear_combination(const giac_double & c1,const vector<giac_double> & x1,const giac_double & c2,const vector<giac_double> & x2,const giac_double & c3,const vector<giac_double> & x3,vector<giac_double> & y){
18476     vector<giac_double>::const_iterator it1=x1.begin(),it2=x2.begin(),it3=x3.begin(),it3end=x3.end();
18477     vector<giac_double>::iterator jt=y.begin();
18478     for (;it3!=it3end;++jt,++it1,++it2,++it3){
18479       *jt=c1*(*it1)+c2*(*it2)+c3*(*it3);
18480     }
18481   }
18482 
18483 #ifdef NSPIRE
18484   template<class T>
operator <<(nio::ios_base<T> & os,const vector<giac_double> & m)18485   nio::ios_base<T> & operator << (nio::ios_base<T> & os,const vector<giac_double> & m){
18486     int s=int(m.size());
18487     os << "[";
18488     for (int i=0;i<s;++i){
18489       os << m[i] << " ";
18490     }
18491     return "]" << os;
18492   }
18493 
18494   template<class T>
operator <<(nio::ios_base<T> & os,const matrix_double & m)18495   nio::ios_base<T> & operator << (nio::ios_base<T> & os,const matrix_double & m){
18496     int s=int(m.size());
18497     for (int i=0;i<s;++i)
18498       os << m[i] << '\n';
18499     return os;
18500   }
18501 
dbgprint() const18502   void matrix_double::dbgprint() const { COUT << *this << '\n'; }
18503 
18504   template<class T>
operator <<(nio::ios_base<T> & os,const vector<complex_double> & m)18505   nio::ios_base<T> & operator << (nio::ios_base<T> & os,const vector< complex_double > & m){
18506     int s=int(m.size());
18507     for (int i=0;i<s;++i)
18508       os << m[i] << " ";
18509     return os;
18510   }
18511 
18512   template<class T>
operator <<(nio::ios_base<T> & os,const matrix_complex_double & m)18513   nio::ios_base<T> & operator << (nio::ios_base<T> & os,const matrix_complex_double & m){
18514     int s=int(m.size());
18515     for (int i=0;i<s;++i)
18516       os << m[i] << '\n';
18517     return os;
18518   }
18519 
18520 #else
18521 
operator <<(ostream & os,const vector<giac_double> & m)18522   ostream & operator << (ostream & os,const vector<giac_double> & m){
18523     int s=int(m.size());
18524     os << "[";
18525     for (int i=0;i<s;++i){
18526       os << m[i];
18527       if (i+1!=s)
18528 	os << ",";
18529     }
18530     return os << "]";
18531   }
18532 
operator <<(ostream & os,const matrix_double & m)18533   ostream & operator << (ostream & os,const matrix_double & m){
18534     int s=int(m.size());
18535     os << "[";
18536     for (int i=0;i<s;++i){
18537       os << m[i] ;
18538       if (i+1!=s)
18539 	os << ",";
18540       os << '\n';
18541     }
18542     return os << "]";
18543   }
18544 
dbgprint() const18545   void matrix_double::dbgprint() const { COUT << *this << '\n'; }
18546 
operator <<(ostream & os,const vector<complex_double> & m)18547   ostream & operator << (ostream & os,const vector< complex_double > & m){
18548     int s=int(m.size());
18549     for (int i=0;i<s;++i)
18550       os << m[i] << " ";
18551     return os;
18552   }
18553 
operator <<(ostream & os,const matrix_complex_double & m)18554   ostream & operator << (ostream & os,const matrix_complex_double & m){
18555     int s=int(m.size());
18556     for (int i=0;i<s;++i)
18557       os << m[i] << '\n';
18558     return os;
18559   }
18560 
18561 #endif // NSPIRE
18562 
dbgprint() const18563   void matrix_complex_double::dbgprint() const { COUT << *this << '\n'; }
18564 
francis_iterate1(matrix_double & H,int n1,int n2,matrix_double & P,double eps,bool compute_P,giac_double l1,bool finish,vector<giac_double> & oper)18565   void francis_iterate1(matrix_double & H,int n1,int n2,matrix_double & P,double eps,bool compute_P,giac_double l1,bool finish,vector<giac_double> & oper){
18566     if (debug_infolevel>2)
18567       CERR << CLOCK()*1e-6 << " iterate1 " << n1 << " " << n2 << '\n';
18568     int n_orig=int(H.size());
18569     giac_double x,y;
18570     if (finish){
18571       // [[a,b],[c,d]] -> [b,l1-a] or [l1-d,c] as first eigenvector
18572       giac_double a=H[n2-2][n2-2],b=H[n2-2][n2-1],c=H[n2-1][n2-2],d=H[n2-1][n2-1];
18573       giac_double l1a=l1-a,l1d=l1-d;
18574       if (absdouble(l1a)>absdouble(l1d)){
18575 	x=b; y=l1a;
18576       }
18577       else {
18578 	x=l1d; y=c;
18579       }
18580     }
18581     else
18582       x=H[n1][n1]-l1,y=H[n1+1][n1];
18583     giac_double xy=std::sqrt(x*x+y*y),tmp1;
18584     if (xy==0) return;
18585     // normalize
18586     x = x/xy; y = y/xy;
18587     // apply Q on H and P: line operations on H and P
18588     bi_linear_combination_AC(x,H[n1],y,H[n1+1]);
18589     if (compute_P){
18590       oper.push_back(-2);
18591       oper.push_back(n1);
18592       oper.push_back(n1+1);
18593       oper.push_back(x);
18594       oper.push_back(y);
18595       hessenberg_ortho3_flush_p(P,compute_P,oper,false);
18596       // bi_linear_combination_AC(x,P[n1],y,P[n1+1]);
18597     }
18598     // now columns operations on H (not on P)
18599     for (int j=0;j<n_orig;++j){
18600       vector<giac_double> & Hj=H[j];
18601       giac_double & Hjm1=Hj[n1];
18602       giac_double & Hjm2=Hj[n1+1];
18603       tmp1=Hjm1*x+Hjm2*y; // tmp1=Hjm1*c11+Hjm2*c21;
18604       Hjm2=Hjm1*y-Hjm2*x; // tmp2=Hjm1*c12+Hjm2*c22;
18605       Hjm1=tmp1;
18606     }
18607     if (debug_infolevel>2)
18608       CERR << CLOCK()*1e-6 << " iterate1 hessenberg " << n1 << " " << n2 << '\n';
18609     hessenberg_ortho(H,P,n1,n2,compute_P,2,oper);
18610   }
18611 
18612   // declaration for recursive use
18613   bool in_francis_schur(matrix_double & H,int n1,int n2,matrix_double & P,int maxiter,double eps,bool compute_P,matrix_double & Haux,matrix_double & T,bool in_recursion,vector<giac_double> & oper);
18614 
do_francis_iterate2(matrix_double & H,int n1,int n2,giac_double s,giac_double p,matrix_double & P,bool compute_P,vector<giac_double> & oper)18615   void do_francis_iterate2(matrix_double & H,int n1,int n2,giac_double s,giac_double p,matrix_double & P,bool compute_P,vector<giac_double> & oper){
18616     // compute (H-l2)(H-l1)=(H-s)*H+p on n1-th basis vector (if n1==0, on [1,0,...,0])
18617     giac_double ha=H[n1][n1],hb=H[n1][n1+1],
18618       hd=H[n1+1][n1],he=H[n1+1][n1+1],
18619       hh=H[n1+2][n1+1];
18620     giac_double x=hb*hd+ha*(ha-s)+p,y=hd*(he-s+ha),z=hd*hh,c11,c12,c13,c21,c22,c23,c31,c32,c33;
18621     if (x>0){
18622       x=-x; y=-y; z=-z;
18623     }
18624     giac_double xyz=std::sqrt(x*x+y*y+z*z),xm1;
18625     c11=x=x/xyz; c12=c21=y=y/xyz; c13=c31=z=z/xyz;
18626     xm1=1-x;
18627     c22=(x*x+z*z-x)/xm1;
18628     c33=(x*x+y*y-x)/xm1;
18629     c32=c23=-(y*z)/xm1;
18630     // NB for complex coeffs, once x is real the matrix is
18631     // [[x,  conj(y),       conj(z)       ]
18632     //  [y,  1-|y|^2/xm1,   -conj(y)*z/xm1]
18633     //  [z, -y*conj(z)/xm1, 1-|z|^2/xm1   ]]
18634     // CERR << "[[" << c11 <<"," << c12 << "," << c13 << "],[" <<  c21 <<"," << c22 << "," << c23 << "],[" << c31 <<"," << c32 << "," << c33 << "]]" << '\n';
18635     // columns operations on H (not on P)
18636     // since H is tridiagonal, H[j][n1+2]==0 if j=>n1+4
18637     int nend=int(H.size());
18638     if (n1+4<nend)
18639       nend=n1+4;
18640     for (int j=0;j<nend;++j){
18641       vector<giac_double> & Hj=H[j];
18642       giac_double & Hjm1=Hj[n1];
18643       giac_double & Hjm2=Hj[n1+1];
18644       giac_double & Hjm3=Hj[n1+2];
18645       giac_double tmp1=Hjm1*c11+Hjm2*c21+Hjm3*c31;
18646       giac_double tmp2=Hjm1*c12+Hjm2*c22+Hjm3*c32;
18647       Hjm3=Hjm1*c13+Hjm2*c23+Hjm3*c33;
18648       Hjm1=tmp1;
18649       Hjm2=tmp2;
18650     }
18651     // line operations on H
18652     tri_linear_combination(c11,H[n1],c12,H[n1+1],c13,H[n1+2],c22,c23,c33);
18653     // tri_linear_combination(c11,H[n1],c12,H[n1+1],c13,H[n1+2],v1);
18654     // tri_linear_combination(c21,H[n1],c22,H[n1+1],c23,H[n1+2],v2);
18655     // tri_linear_combination(c31,H[n1],c32,H[n1+1],c33,H[n1+2],H[n1+2]);
18656     // H[n1].swap(v1);
18657     // H[n1+1].swap(v2);
18658     // H[n1+2].swap(v3);
18659     // CERR << H << '\n';
18660     if (compute_P){
18661       oper.push_back(-3);
18662       oper.push_back(n1);
18663       oper.push_back(n1);
18664       oper.push_back(c11);
18665       oper.push_back(c12);
18666       oper.push_back(c13);
18667       oper.push_back(c22);
18668       oper.push_back(c23);
18669       oper.push_back(c33);
18670       hessenberg_ortho3_flush_p(P,compute_P,oper,false);
18671       // tri_linear_combination(c11,P[n1],c12,P[n1+1],c13,P[n1+2],c22,c23,c33);
18672       // tri_linear_combination(c11,P[n1],c12,P[n1+1],c13,P[n1+2],v1);
18673       // tri_linear_combination(c21,P[n1],c22,P[n1+1],c23,P[n1+2],v2);
18674       // tri_linear_combination(c31,P[n1],c32,P[n1+1],c33,P[n1+2],P[n1+2]);
18675       // P[n1].swap(v1);
18676       // P[n1+1].swap(v2);
18677     }
18678     // CERR << H << '\n';
18679     // chase the bulge: Hessenberg reduction on 2 subdiagonals
18680     if (debug_infolevel>2)
18681       CERR << CLOCK()*1e-6 << " iterate2 hessenberg " << n1 << " " << n2 << '\n';
18682     hessenberg_ortho3(H,P,n1,n2,compute_P,oper);
18683   }
18684 
18685   // #define GIAC_SCHUR_RECURSE_ALL
18686 
18687   // oper is a work register for hessenberg reduction
francis_iterate2(matrix_double & H,int n1,int n2,matrix_double & P,double eps,bool compute_P,matrix_double & Haux,matrix_double & T,bool in_recursion,vector<giac_double> & oper)18688   void francis_iterate2(matrix_double & H,int n1,int n2,matrix_double & P,double eps,bool compute_P,matrix_double & Haux,matrix_double & T,bool in_recursion,vector<giac_double> & oper){
18689     // now H is proper hessenberg (indices n1 to n2-1)
18690     if (debug_infolevel>2)
18691       CERR << CLOCK()*1e-6 << " iterate2 " << n1 << " " << n2 << '\n';
18692     giac_double s,p; // s=sum of shifts, p=product
18693     giac_double ok=absdouble(H[n2-1][n2-2]/H[n2-1][n2-1]);
18694     if (
18695 #ifdef GIAC_HAS_STO_38 // otherwise p:=48*x*(1+x)^60 -(1+x)^60 +1; proot(p) crashes
18696 	0 &&
18697 #endif
18698 	!in_recursion && H.size()>=50){
18699       // search for a small coeff on the subdiagonal in the last elements
18700       int k=-1,ksmallest=-1;
18701       const double limite=0.5;giac_double savetest,smallest=-1;
18702       if (ok<limite)
18703 	k=n2-1;
18704       else
18705 	ok=limite;
18706       for (int k0=n2-2;k0>n2-200 && k0>(0.2*n1+0.8*n2)
18707 	     ;--k0
18708 	   ){
18709 	giac_double test0=absdouble(H[k0][k0-1]/H[k0-1][k0-1]);
18710 	if (smallest<0 || test0<smallest){
18711 	  smallest=test0;
18712 	  ksmallest=k0;
18713 	}
18714 	if (test0<ok){
18715 	  k=k0;
18716 	  ok=test0;
18717 	  savetest=test0;
18718 	  if (test0<1e-7){
18719 	    if (debug_infolevel>2)
18720 	      CERR << CLOCK()*1e-6 << " small subdiag. element found " << test0 << " line " << k << '\n';
18721 	    break;
18722 	  }
18723 	}
18724 	// testing from n1 to k-1 is slower...
18725 	int k1=n1+n2-k0;
18726 	if (0 && k1<k0 && k1>n1){
18727 	  giac_double test1=absdouble(H[k1][k1-1]/H[k1-1][k1-1]);
18728 	  if (test1<ok){
18729 	    k=k1;
18730 	    ok=test1;
18731 	    savetest=test1;
18732 	    if (test1<1e-7){
18733 	      if (debug_infolevel>2)
18734 		CERR << CLOCK()*1e-6 << " small subdiag. element found " << test1 << " line " << k << '\n';
18735 	      break;
18736 	    }
18737 	  }
18738 	}
18739 	ok *= 1.06;
18740 	if (ok>limite)
18741 	  ok=limite;
18742       }
18743       if (0 && k==-1){
18744 	k=ksmallest;
18745 	if (debug_infolevel)
18746 	  CERR << "No split found, using " << k << '\n';
18747       }
18748       if (k==n2-1){ // was <= std::sqrt(eps)
18749 	francis_iterate1(H,n1,n2,P,eps,compute_P,H[n2-1][n2-1],false,oper);
18750 	return;
18751       }
18752       if (k>n1+2 && k<n2-2){
18753 	// 1 or 2 eigenvalues of the submatrix k..n2-1 or n1..k-1 will be taken as shift
18754 	unsigned d=n2-k;
18755 	bool n1k=false;
18756 	if (k-n1<int(d)){
18757 	  d=k-n1;
18758 	  n1k=true;
18759 	}
18760 	T.resize(d);
18761 	matrix_double TP;
18762 	for (unsigned i=0;i<d;++i){
18763 	  T[i].swap(Haux[i]);
18764 	  T[i].clear();
18765 	}
18766 	// copy submatrix
18767 	for (unsigned i=0;i<d;i++){
18768 	  T[i].reserve(d);
18769 	  if (n1k){
18770 	    for (unsigned j=0;j<d;j++){
18771 	      T[i].push_back(H[n1+i][n1+j]);
18772 	    }
18773 	  }
18774 	  else {
18775 	    for (unsigned j=0;j<d;j++){
18776 	      T[i].push_back(H[k+i][k+j]);
18777 	    }
18778 	  }
18779 	}
18780 	if (debug_infolevel>2 && d>=3){
18781 	  if (n1k)
18782 	    CERR << CLOCK()*1e-6 << " ok=" << ok << ", test=" << savetest << ", recursive call dim " << d << " n1 " << n1 <<" on ... [" << T[d-2][d-3] << "," << T[d-2][d-2] << "," << T[d-2][d-1] << " ],[" << T[d-1][d-2] << "," << T[d-1][d-1] << "]" << '\n';
18783 	  else
18784 	    CERR << CLOCK()*1e-6 << " ok=" << ok << ", test=" << savetest << ", recursive call dim " << d << " n2 " << n2 <<" on ... [" << T[d-2][d-3] << "," << T[d-2][d-2] << "," << T[d-2][d-1] << " ],[" << T[d-1][d-2] << "," << T[d-1][d-1] << "]" << '\n';
18785 	}
18786 	int save_debug_infolevel=debug_infolevel;
18787 	debug_infolevel=0;
18788 	// schur it
18789 	vector<giac_double> oper_recursive;
18790 	if(in_francis_schur(T,0,d,TP,25,eps,false /* TP not computed*/,Haux,T,true /* in_recursion */,oper_recursive)){
18791 	  debug_infolevel=save_debug_infolevel;
18792 	  if (debug_infolevel>2){
18793 	    CERR << CLOCK()*1e-6 << " end recursive call on ... [" << T[d-2][d-3] << "," << T[d-2][d-2] << "," << T[d-2][d-1] << " ][0," << T[d-1][d-2] << "," << T[d-1][d-1] << "]" << '\n';
18794 	    if (debug_infolevel>3){
18795 	      CERR << "success subdiag. " ;
18796 	      for (unsigned i=1;i<d;++i)
18797 		CERR << T[i][i-1] << ",";
18798 	      CERR << '\n';
18799 	    }
18800 	  }
18801 #ifdef GIAC_SCHUR_RECURSE_ALL
18802 	  for (int k=d-1;k>=2;){
18803 	    if (absdouble(T[k-1][k-2])>1e-5){
18804 	      francis_iterate1(H,n1,n2,P,eps,compute_P,T[k][k],false,oper);
18805 	      // if (absdouble(H[n2-2][n2-1])>1e-5) break;
18806 	      k--;
18807 	      continue;
18808 	    }
18809 	    s=T[k-1][k-1]+T[k][k];
18810 	    p=T[k-1][k-1]*T[k][k]-T[k][k-1]*T[k-1][k];
18811 	    do_francis_iterate2(H,n1,n2,s,p,P,compute_P,oper);
18812 	    // if (absdouble(H[n2-3][n2-2])>1e-5) break;
18813 	    k-=2;
18814 	  }
18815 #else
18816 	  if (absdouble(T[d-2][d-3])>1e-5){
18817 	    francis_iterate1(H,n1,n2,P,eps,compute_P,T[d-1][d-1],false,oper);
18818 	    for (unsigned i=0;i<T.size();++i){
18819 	      Haux[i].swap(T[i]);
18820 	    }
18821 	    return;
18822 	  }
18823 	  k=d-1;
18824 	  s=T[k-1][k-1]+T[k][k];
18825 	  p=T[k-1][k-1]*T[k][k]-T[k][k-1]*T[k-1][k];
18826 	  do_francis_iterate2(H,n1,n2,s,p,P,compute_P,oper);
18827 #endif
18828 	  return;
18829 	} // end recursive call
18830 	else {
18831 	  if (debug_infolevel>2){
18832 	    CERR << CLOCK()*1e-6 << " recursive call failure" << '\n';
18833 	    if (debug_infolevel>3){
18834 	      CERR << "failure subdiag. " ;
18835 	      for (unsigned i=1;i<d;++i)
18836 		CERR << T[i][i-1] << ",";
18837 	      CERR << '\n';
18838 	    }
18839 	  }
18840 	}
18841 	for (unsigned i=0;i<T.size();++i){
18842 	  Haux[i].swap(T[i]);
18843 	}
18844 	if (debug_infolevel>2)
18845 	  CERR << CLOCK()*1e-6 << " swapped " << '\n';
18846       } // if k>=n1 && k<n2-2
18847     } // end if (!in_recursion && H.size()>=50)
18848     else {
18849       if (ok<1e-2){
18850 	francis_iterate1(H,n1,n2,P,eps,compute_P,H[n2-1][n2-1],false,oper);
18851 	return;
18852       }
18853     }
18854     // find eigenvalues l1 and l2 of last 2x2 matrix, they will be taken as shfits
18855     s=H[n2-2][n2-2]+H[n2-1][n2-1];
18856     p=H[n2-2][n2-2]*H[n2-1][n2-1]-H[n2-1][n2-2]*H[n2-2][n2-1];
18857     if (s==int(s) && p==int(p))
18858       s=s*(1+(100*eps*giac_rand(context0)/rand_max2));
18859     // CERR << p << " " << s << " " << eps << '\n' << absdouble(H[n2-2][n2-2]) << " " << absdouble(H[n2-1][n2-1]) << '\n';
18860     if (p==s*s/4 || (absdouble(H[n2-2][n2-2])<eps &&absdouble(H[n2-1][n2-1])<eps) ){
18861       // multiple root
18862       s += giac_rand(context0)*(H[n2-1][n2-2]+std::sqrt(absdouble(p)))/rand_max2;
18863       // CERR << "new s " << s << '\n';
18864     }
18865     do_francis_iterate2(H,n1,n2,s,p,P,compute_P,oper);
18866   }
18867 
in_francis_schur(matrix_double & H,int n1,int n2,matrix_double & P,int maxiter,double eps,bool compute_P,matrix_double & Haux,matrix_double & T,bool in_recursion,vector<giac_double> & oper)18868   bool in_francis_schur(matrix_double & H,int n1,int n2,matrix_double & P,int maxiter,double eps,bool compute_P,matrix_double & Haux,matrix_double & T,bool in_recursion,vector<giac_double> & oper){
18869     if (n2-n1<=1)
18870       return true; // nothing to do
18871     if (n2-n1==2){ // 2x2 submatrix, we know how to diagonalize
18872       giac_double l1,l2;
18873       if (eigenval2(H,n2,l1,l2)){
18874 	francis_iterate1(H,n1,n2,P,eps,compute_P,l1,true,oper);
18875       }
18876       return true;
18877     }
18878     for (int niter=0;n2-n1>2 && niter<maxiter;niter++){
18879       if (debug_infolevel>=2)
18880 	CERR << CLOCK()*1e-6 << " qr iteration number " << niter << " " << '\n';
18881       if (debug_infolevel>=5)
18882 	H.dbgprint();
18883       // check if one subdiagonal element is sufficiently small, if so
18884       // we can increase n1 or decrease n2 or split
18885       giac_double ratio,coeff=1;
18886       if (niter>maxiter-3)
18887 	coeff=100;
18888       if (debug_infolevel>2)
18889 	CERR << CLOCK()*1e-6 << " first ratios ";
18890       for (int i=n2-2;i>=n1;--i){
18891       // for (int i=n1;i<=n2-2;++i){
18892 	ratio=absdouble(H[i+1][i])/(absdouble(H[i][i])+(i<n2-2?absdouble(H[i+2][i+1]):0));
18893 	if (debug_infolevel>2 && i>n2-25)
18894 	  CERR << ratio << " ";
18895 	if (ratio<coeff*eps){
18896 	  // do a final iteration if i==n2-2 or n2-3? does not improve much precision
18897 	  // if (i==n2-3) francis_iterate2(H,n1,n2,P,eps,compute_P,Haux,T,in_recursion,oper);
18898 	  // submatrices n1..i and i+1..n2-1
18899 	  if (debug_infolevel>2)
18900 	    CERR << '\n' << CLOCK()*1e-6 << " Francis split double " << giacmin((i+1)-n1,n2-(i+1)) << " [" << n1 << " " << i+1 << " " << n2 << "]" << '\n';
18901 #ifdef GIAC_SCHUR_RECURSE_ALL
18902 	  if (!in_francis_schur(H,n1,i+1,P,maxiter,eps,compute_P,Haux,T,in_recursion,oper)){
18903 	    in_francis_schur(H,i+1,n2,P,maxiter,eps,compute_P,Haux,T,in_recursion,oper);
18904 	    return false;
18905 	  }
18906 #else
18907 	  if (in_recursion && n2-(i+1)<=2)
18908 	    return true;
18909 	  if (!in_recursion && !in_francis_schur(H,n1,i+1,P,maxiter,eps,compute_P,Haux,T,in_recursion,oper)){
18910 	    in_francis_schur(H,i+1,n2,P,maxiter,eps,compute_P,Haux,T,in_recursion,oper);
18911 	    return false;
18912 	  }
18913 #endif
18914 	  return in_francis_schur(H,i+1,n2,P,maxiter,eps,compute_P,Haux,T,in_recursion,oper);
18915 	}
18916 	if (i<=n1+1 && ratio<std::sqrt(eps)){
18917 	  if (debug_infolevel>3)
18918 	    CERR << "splitable from begin " << n1 << "," << n2 << '\n';
18919 	  // exchange lines/columns n1/n2-1
18920 	  // exchange(H,P,compute_P,n1,n2-1);
18921 	  // break;
18922 	}
18923 	// IMPROVE: in that case we should iterate_n using the eigenvalues of the
18924 	// submatrix i+1..n2-1
18925       }
18926       if (debug_infolevel>2)
18927 	CERR << '\n';
18928       francis_iterate2(H,n1,n2,P,eps,compute_P,Haux,T,in_recursion,oper);
18929     } // end for loop on niter
18930     return false;
18931   }
18932 
18933   // Francis algo on H after balance
balanced_eigenvalues(matrix_double & H,vecteur & res,int maxiter,double eps,bool is_hessenberg,GIAC_CONTEXT)18934   bool balanced_eigenvalues(matrix_double & H,vecteur & res,int maxiter,double eps,bool is_hessenberg,GIAC_CONTEXT){
18935     vector<giac_double> d;
18936     if (!balance_krylov(H,d,5,1e-8))
18937       return false;
18938     int n1=0,n2=int(H.size());
18939     // compute d*H*d^-1: H_jk <- d_jj*H_jk/d_kk
18940     for (int j=n1;j<n2;++j){
18941       vector<giac_double> & Hj=H[j];
18942       for (int k=n1;k<n2;++k){
18943 	Hj[k]=d[j]*Hj[k]/d[k];
18944       }
18945     }
18946     // schur on d*H*d^-1
18947     matrix_double P;
18948     if (!francis_schur(H,n1,n2,P,maxiter,eps,is_hessenberg,false))
18949       return false;
18950     // Invariant if compute_P was true trn(P)*d*H*d^-1*P=orig matrix
18951     // same eigenvalues, but different eigenvectors
18952     return schur_eigenvalues(H,res,eps,contextptr);
18953   }
18954 
18955   // Francis algorithm on submatrix rows and columns n1..n2-1
18956   // Invariant: trn(P)*H*P=orig matrix, complex_schur not used for giac_double coeffs
francis_schur(matrix_double & H,int n1,int n2,matrix_double & P,int maxiter,double eps,bool is_hessenberg,bool compute_P)18957   bool francis_schur(matrix_double & H,int n1,int n2,matrix_double & P,int maxiter,double eps,bool is_hessenberg,bool compute_P){
18958     vecteur eigenv;
18959     if (n1==0
18960 	// && n2<400
18961 	&& lapack_schur(H,P,compute_P,eigenv))
18962       return true;
18963 #ifdef VISUALC // tested on 100 rand poly of degree 10, should work...
18964     // return false;
18965 #endif
18966     // int n_orig=H.size();//,nitershift0=0;
18967     if (!is_hessenberg){
18968       if (debug_infolevel>0)
18969 	CERR << CLOCK()*1e-6 << " start hessenberg real n=" << H.size() << '\n';
18970 #if 1
18971       hessenberg_householder(H,P,compute_P);
18972 #else
18973       hessenberg_ortho(H,P,0,n_orig,compute_P,0); // insure Hessenberg form (on the whole matrix)
18974 #endif
18975       if (debug_infolevel>0)
18976 	CERR << CLOCK()*1e-6 << " hessenberg real done" <<'\n';
18977     }
18978     matrix_double Haux(n2/2),T(n2/2);
18979     vector<giac_double> oper;
18980     oper.reserve(P.size()*(P.size()/10+4)+3);
18981     // adjust maxiter for large matrices
18982     if (H.size()>=50)
18983       maxiter=(maxiter*int(H.size()))/50;
18984     bool res=in_francis_schur(H,n1,n2,P,maxiter,eps,compute_P,Haux,T,false,oper);
18985     if (compute_P)
18986       hessenberg_ortho3_flush_p(P,compute_P,oper,true);
18987     if (debug_infolevel>0)
18988       CERR << CLOCK()*1e-6 << " schur real done" <<'\n';
18989     return res;
18990   }
18991 
18992   // conj(a)*A+conj(c)*C->C
18993   // c*A-a*C->A
bi_linear_combination(complex_double a,vector<complex_double> & A,complex_double c,vector<complex_double> & C,int cstart,int cend)18994   void bi_linear_combination( complex_double  a,vector< complex_double > & A, complex_double  c,vector< complex_double > & C,int cstart,int cend){
18995     complex_double  * Aptr=&A.front()+cstart;
18996     complex_double  * Cptr=&C.front()+cstart,* Cend=Cptr+(cend-cstart);
18997     complex_double ac=conj(a),cc=conj(c);
18998     for (;Cptr!=Cend;++Aptr,++Cptr){
18999       complex_double  tmp=c*(*Aptr)-a*(*Cptr);
19000       *Cptr=ac*(*Aptr)+cc*(*Cptr);
19001       *Aptr=tmp;
19002     }
19003   }
19004 
hessenberg_ortho(matrix_complex_double & H,matrix_complex_double & P,int firstrow,int n,bool compute_P,int already_zero)19005   void hessenberg_ortho(matrix_complex_double & H,matrix_complex_double & P,int firstrow,int n,bool compute_P,int already_zero){
19006     int nH=int(H.size());
19007     if (n<0 || n>nH)
19008       n=nH;
19009     if (firstrow<0 || firstrow>n)
19010       firstrow=0;
19011     complex_double  t,u,tc,uc;
19012     double norme;
19013     for (int m=firstrow;m<n-2;++m){
19014       if (debug_infolevel>=5)
19015 	CERR << "// hessenberg reduction line " << m << '\n';
19016       // if initial Hessenberg check for a non zero coeff in the column m below ligne m+1
19017       int i=m+1;
19018       int nend=n;
19019       if (already_zero){
19020 	if (i+already_zero<n)
19021 	  nend=i+already_zero;
19022       }
19023       else {
19024 	double pivot=0;
19025 	int pivotline=0;
19026 	for (;i<nend;++i){
19027 	  double t=complex_abs(H[i][m]);
19028 	  if (t>pivot){
19029 	    pivotline=i;
19030 	    pivot=t;
19031 	  }
19032 	}
19033 	if (pivot==0)
19034 	  continue;
19035 	i=pivotline;
19036 	// exchange line and columns
19037 	if (i>m+1){
19038 	  swap(H[i],H[m+1]);
19039 	  if (compute_P)
19040 	    swap(P[i],P[m+1]);
19041 	  for (int j=0;j<n;++j){
19042 	    vector< complex_double > & Hj=H[j];
19043 #ifdef VISUALC
19044 	    complex<double> cc=Hj[i];
19045 	    Hj[i]=Hj[m+1];
19046 	    Hj[m+1]=cc;
19047 #else
19048 	    swap< complex_double >(Hj[i],Hj[m+1]);
19049 #endif
19050 	  }
19051 	}
19052       }
19053       // now coeff at line m+1 column m is H[m+1][m]=t!=0
19054       for (i=m+2;i<nend;++i){
19055 	u=H[i][m];
19056 	if (u==0)
19057 	  continue;
19058 	// line operation
19059 	t=H[m+1][m];
19060 	norme=std::sqrt(norm(u)+norm(t));
19061 	u=u/norme; t=t/norme;
19062 	uc=conj(u); tc=conj(t);
19063 	if (debug_infolevel>=5)
19064 	  CERR << "// i=" << i << " " << u <<'\n';
19065 	// H[m+1]=uc*H[i]+tc*H[m+1] and H[i]=t*H[i]-u*H[m+1];
19066 	bi_linear_combination(u,H[i],t,H[m+1],m,nH);
19067 	// column operation:
19068 	int nstop=already_zero?nend+already_zero-1:nH;
19069 	if (nstop>nH)
19070 	  nstop=nH;
19071 	matrix_complex_double::iterator Hjptr=H.begin(),Hjend=Hjptr+nstop;
19072 	for (;Hjptr!=Hjend;++Hjptr){
19073 	  complex_double  *Hj=&Hjptr->front();
19074 	  complex_double  Hjm=Hj[m+1],Hji=Hj[i];
19075 	  Hj[i]=-uc*Hjm+tc*Hji;
19076 	  Hj[m+1]=t*Hjm+u*Hji;
19077 	}
19078 	if (compute_P){
19079 	  bi_linear_combination(u,P[i],t,P[m+1],0,nH);
19080 	}
19081       } // for i=m+2...
19082     } // for int m=firstrow ...
19083   }
19084 
19085   // a*A+c*C->A
19086   // c*A-a*C->C
bi_linear_combination(double a,vector<complex_double> & A,complex_double c,vector<complex_double> & C)19087   void bi_linear_combination(double a,vector< complex_double > & A,complex_double c,vector< complex_double > & C){
19088     complex_double * Aptr=&A.front();
19089     complex_double * Cptr=&C.front(),* Cend=Cptr+C.size();
19090     complex_double cc=conj(c);
19091     for (;Cptr!=Cend;++Aptr,++Cptr){
19092       complex_double tmp=a*(*Aptr)+cc*(*Cptr);
19093       *Cptr=c*(*Aptr)-a*(*Cptr);
19094       *Aptr=tmp;
19095     }
19096   }
19097 
complex_abs(const complex_double & c)19098   double complex_abs(const complex_double & c){
19099 #if defined EMCC || defined FXCG
19100     double r=c.real(),i=c.imag();
19101     r=std::sqrt(r*r+i*i);
19102     return r;
19103 #else
19104     return std::abs(c);
19105 #endif
19106   }
19107 
complex_long_abs(const complex_long_double & c)19108   double complex_long_abs(const complex_long_double & c){
19109 #if defined EMCC || defined FXCG
19110     long_double r=c.real(),i=c.imag();
19111     r=std::sqrt(r*r+i*i);
19112     return r;
19113 #else
19114     return std::abs(c);
19115 #endif
19116   }
19117 
francis_iterate1(matrix_complex_double & H,int n1,int n2,matrix_complex_double & P,double eps,bool compute_P,complex_double l1,bool finish)19118   void francis_iterate1(matrix_complex_double & H,int n1,int n2,matrix_complex_double & P,double eps,bool compute_P,complex_double l1,bool finish){
19119     if (debug_infolevel>2)
19120       CERR << CLOCK()*1e-6 << " iterate1 " << n1 << " " << n2 << '\n';
19121     int n_orig=int(H.size());
19122     complex_double x,y,yc;
19123     if (finish){
19124       // [[a,b],[c,d]] -> [b,l1-a] or [l1-d,c] as first eigenvector
19125       complex_double a=H[n2-2][n2-2],b=H[n2-2][n2-1],c=H[n2-1][n2-2],d=H[n2-1][n2-1];
19126       complex_double l1a=l1-a,l1d=l1-d;
19127       if (complex_abs(l1a)>complex_abs(l1d)){
19128 	x=b; y=l1a;
19129       }
19130       else {
19131 	x=l1d; y=c;
19132       }
19133     }
19134     else {
19135       x=H[n1][n1]-l1,y=H[n1+1][n1];
19136       if (complex_abs(x)<eps && complex_abs(y-1.0)<eps){
19137 	x = double(giac_rand(context0))/rand_max2;
19138       }
19139     }
19140     // make x real
19141     double xr=real(x),xi=imag(x),yr=real(y),yi=imag(y),X;
19142     X = std::sqrt(xr*xr+xi*xi);
19143     if (X!=0){
19144       // gen xy = gen(xr/x,-xi/x); y=y*xy;
19145       y = complex_double ((yr*xr+yi*xi)/X,(yi*xr-yr*xi)/X);
19146       yr=real(y); yi=imag(y);
19147     }
19148     double xy=std::sqrt(X*X+yr*yr+yi*yi);
19149     // normalize eigenvector
19150     X = X/xy; y = y/xy;	yc=conj(y);
19151     // compute reflection matrix such that Q*[1,0]=[x,y]
19152     // hence column 1 is [x,y] and column2 is [conj(y),-x]
19153     // apply Q on H and P: line operations on H and P
19154     // complex_double c11=x, c12=conj(y,contextptr),
19155     //                 c21=y, c22=-x;
19156     // apply Q on H and P: line operations on H and P
19157     bi_linear_combination(X,H[n1],y,H[n1+1]);
19158     if (compute_P)
19159       bi_linear_combination(X,P[n1],y,P[n1+1]);
19160     // now columns operations on H (not on P)
19161     for (int j=0;j<n_orig;++j){
19162       vector< complex_double > & Hj=H[j];
19163       complex_double & Hjm1=Hj[n1];
19164       complex_double & Hjm2=Hj[n1+1];
19165       complex_double tmp1=Hjm1*X+Hjm2*y; // tmp1=Hjm1*c11+Hjm2*c21;
19166       Hjm2=Hjm1*yc-Hjm2*X; // tmp2=Hjm1*c12+Hjm2*c22;
19167       Hjm1=tmp1;
19168     }
19169     if (debug_infolevel>2)
19170       CERR << CLOCK()*1e-6 << " iterate1 hessenberg " << n1 << " " << n2 << '\n';
19171     hessenberg_ortho(H,P,n1,n2,compute_P,2);
19172   }
19173 
19174   bool in_francis_schur(matrix_complex_double & H,int n1,int n2,matrix_complex_double & P,int maxiter,double eps,bool compute_P,matrix_complex_double & Haux,bool only_one);
19175 
francis_iterate2(matrix_complex_double & H,int n1,int n2,matrix_complex_double & P,double eps,bool compute_P,matrix_complex_double & Haux,bool only_one)19176   void francis_iterate2(matrix_complex_double & H,int n1,int n2,matrix_complex_double & P,double eps,bool compute_P,matrix_complex_double & Haux,bool only_one){
19177     // int n_orig(H.size());
19178     // now H is proper hessenberg (indices n1 to n2-1)
19179     if (debug_infolevel>2)
19180       CERR << CLOCK()*1e-6 << " iterate2 " << n1 << " " << n2 << '\n';
19181     complex_double s=H[n2-1][n2-1];
19182     double ok=complex_abs(H[n2-1][n2-2])/complex_abs(H[n2-1][n2-1]);
19183     if (
19184 #ifdef GIAC_HAS_STO_38
19185 	0 &&
19186 #endif
19187 	!only_one && H.size()>=50
19188 	){
19189       // search for a small coeff on the subdiagonal in the last elements
19190       int k=-1;
19191       if (ok<0.5)
19192 	k=n2-1;
19193       else
19194 	ok=0.5;
19195       for (int k0=n2-2;k0>(n1+n2)/2
19196 	     // && (n2-k0)*(n2-k0)<H.size()
19197 	     ;--k0
19198 	     //,ok*=0.99
19199 	   ){
19200 	double test=1.79769313486e+308;
19201 	test=complex_abs(H[k0][k0-1])/complex_abs(H[k0-1][k0-1]);
19202 	if (test<ok){
19203 	  k=k0;
19204 	  ok=test;
19205 	}
19206       }
19207       if (k>=n1 && k<n2-2){
19208 	// 1 eigenvalue of the submatrix k..n2-1 will be taken as shift
19209 	unsigned d=n2-k;
19210 	matrix_complex_double T(d),TP;
19211 	for (unsigned i=0;i<d;++i){
19212 	  T[i].swap(Haux[i]);
19213 	  T[i].clear();
19214 	}
19215 	// copy submatrix
19216 	for (unsigned i=0;i<d;i++){
19217 	  T[i].reserve(d);
19218 	  for (unsigned j=0;j<d;j++){
19219 	    T[i].push_back(H[k+i][k+j]);
19220 	  }
19221 	}
19222 	if (debug_infolevel>2)
19223 	  CERR << CLOCK()*1e-6 << " recursive call dim " << d << " on ... [" << T[d-2][d-3] << "," << T[d-2][d-2] << "," << T[d-2][d-1] << " ][" << T[d-1][d-2] << "," << T[d-1][d-1] << "]" << '\n';
19224 	int save_debug_infolevel=debug_infolevel;
19225 	debug_infolevel=0;
19226 	// schur it
19227 	if(in_francis_schur(T,0,d,TP,25,eps,false,Haux,true)){
19228 	  debug_infolevel=save_debug_infolevel;
19229 	  if (debug_infolevel>2)
19230 	    CERR << CLOCK()*1e-6 << " end recursive call on ... [" << T[d-2][d-3] << "," << T[d-2][d-2] << "," << T[d-2][d-1] << " ][" << T[d-1][d-2] << "," << T[d-1][d-1] << "]" << '\n';
19231 	  s=T[d-1][d-1];
19232 	}
19233 	for (unsigned i=0;i<T.size();++i){
19234 	  Haux[i].swap(T[i]);
19235 	}
19236       }
19237     } // if (!only_one  && H.size()>=50)
19238     else {
19239       if (debug_infolevel>2)
19240 	CERR << "ok " << ok << '\n';
19241       if (n2-n1==2 ||(ok>1e-1 && n2-n1>2 && complex_abs(H[n2-2][n2-3])<1e-2*complex_abs(H[n2-2][n2-2]))){
19242 	complex_double a=H[n2-2][n2-2],b=H[n2-2][n2-1],c=H[n2-1][n2-2],d=H[n2-1][n2-1];
19243 	complex_double delta=a*a-2.0*a*d+d*d+4.0*b*c;
19244 	if (debug_infolevel>2)
19245 	  CERR << "delta " << delta << '\n';
19246 #ifdef EMCC
19247 	delta=std::exp(std::log(delta)/2.0);
19248 #else
19249 	delta=sqrt(delta);
19250 #endif
19251 	if (debug_infolevel>2)
19252 	  CERR << "delta " << delta << '\n';
19253 	complex_double l1=(a+d+delta)/2.0;
19254 	complex_double l2=(a+d-delta)/2.0;
19255 	s=l1;
19256       }
19257     }
19258     francis_iterate1(H,n1,n2,P,eps,compute_P,s,false);
19259   }
19260 
19261   // EIGENVALUES for double coeff
eigenval2(matrix_complex_double & H,int n2,complex_double & l1,complex_double & l2)19262   bool eigenval2(matrix_complex_double & H,int n2,complex_double & l1, complex_double & l2){
19263     complex_double a=H[n2-2][n2-2],b=H[n2-2][n2-1],c=H[n2-1][n2-2],d=H[n2-1][n2-1];
19264     complex_double delta=a*a-complex_double(2)*a*d+d*d+complex_double(4)*b*c;
19265     if (debug_infolevel>2)
19266       CERR << "eigenval2([[" << a << "," << b << "],[" << c << "," << d << "]], delta=" << delta << '\n';
19267     delta=std::sqrt(delta);
19268     l1=(a+d+delta)/complex_double(2);
19269     l2=(a+d-delta)/complex_double(2);
19270     return true;
19271   }
19272 
in_francis_schur(matrix_complex_double & H,int n1,int n2,matrix_complex_double & P,int maxiter,double eps,bool compute_P,matrix_complex_double & Haux,bool only_one)19273   bool in_francis_schur(matrix_complex_double & H,int n1,int n2,matrix_complex_double & P,int maxiter,double eps,bool compute_P,matrix_complex_double & Haux,bool only_one){
19274     if (debug_infolevel>0)
19275       CERR << " francis complex " << H << '\n' << n1 << " " << n2 << " " << maxiter << " " << eps << '\n';
19276     if (n2-n1<=1)
19277       return true; // nothing to do
19278     if (n2-n1==2){ // 2x2 submatrix, we know how to diagonalize
19279       complex_double l1,l2;
19280       if (eigenval2(H,n2,l1,l2)){
19281 	francis_iterate1(H,n1,n2,P,eps,compute_P,l1,true);
19282       }
19283       return true;
19284     }
19285     for (int niter=0;n2-n1>1 && niter<maxiter;niter++){
19286       // check if one subdiagonal element is sufficiently small, if so
19287       // we can increase n1 or decrease n2 or split
19288       if (debug_infolevel>2)
19289 	CERR << "niter "<< niter << " " << H << '\n';
19290       double ratio,coeff=1;
19291       if (niter>maxiter-3)
19292 	coeff=100;
19293       for (int i=n2-2;i>=n1;--i){
19294 	ratio=complex_abs(H[i+1][i])/complex_abs(H[i][i]);
19295 	if (debug_infolevel>2 && i>n2-25)
19296 	  CERR << ratio << " ";
19297 	if (ratio<coeff*eps){
19298 	  // do a final iteration if i==n2-2 or n2-3? does not improve much precision
19299 	  // if (i>=n2-3) francis_iterate2(H,n1,n2,P,eps,true,complex_schur,compute_P,v1,v2);
19300 	  // submatrices n1..i and i+1..n2-1
19301 	  if (debug_infolevel>2)
19302 	    CERR << '\n' << CLOCK()*1e-6 << " Francis split complex " << giacmin((i+1)-n1,n2-(i+1)) << " [" << n1 << " " << i+1 << " " << n2 << "]" << '\n';
19303 	  if (only_one && n2-(i+1)<=2)
19304 	    return true;
19305 	  if (!only_one && !in_francis_schur(H,n1,i+1,P,maxiter,eps,compute_P,Haux,only_one)){
19306 	    in_francis_schur(H,i+1,n2,P,maxiter,eps,compute_P,Haux,only_one);
19307 	    return false;
19308 	  }
19309 	  return in_francis_schur(H,i+1,n2,P,maxiter,eps,compute_P,Haux,only_one);
19310 	}
19311       }
19312       if (debug_infolevel>2)
19313 	CERR << '\n';
19314       francis_iterate2(H,n1,n2,P,eps,compute_P,Haux,only_one);
19315     } // end for loop on niter
19316     return false;
19317   }
19318 
19319   // Francis algorithm on submatrix rows and columns n1..n2-1
19320   // Invariant: trn(P)*H*P=orig matrix, complex_schur not used for giac_double coeffs
francis_schur(matrix_complex_double & H,int n1,int n2,matrix_complex_double & P,int maxiter,double eps,bool is_hessenberg,bool compute_P)19321   bool francis_schur(matrix_complex_double & H,int n1,int n2,matrix_complex_double & P,int maxiter,double eps,bool is_hessenberg,bool compute_P){
19322     vecteur eigenv;
19323     int n_orig=int(H.size());//,nitershift0=0;
19324     if (!is_hessenberg){
19325       if (debug_infolevel>0)
19326 	CERR << CLOCK()*1e-6 << " start hessenberg complex n=" << H.size() << '\n';
19327 #if 0 // FIXME do it for complex
19328       hessenberg_householder(H,P,compute_P);
19329 #else
19330       hessenberg_ortho(H,P,0,n_orig,compute_P,0); // insure Hessenberg form (on the whole matrix)
19331 #endif
19332       if (debug_infolevel>0)
19333 	CERR << CLOCK()*1e-6 << " hessenberg complex done" <<'\n';
19334     }
19335     matrix_complex_double Haux(n2/2);
19336     return in_francis_schur(H,n1,n2,P,maxiter,eps,compute_P,Haux,false);
19337   }
19338 
19339 #ifndef NO_NAMESPACE_GIAC
19340 } // namespace giac
19341 #endif // ndef NO_NAMESPACE_GIAC
19342