1 /* SYMMETRICA file plet.c */
2 #include "def.h"
3 #include "macro.h"
4
5 /* CC 240197 */
6
7
8 #ifdef PLETTRUE
9
10
11 #ifdef DGUX
12 #define signed
13 #endif /* DGUX */
14
15 #ifdef sun
16 #define signed
17 #endif /*sun */
18 #ifdef hpux
19 #define signed
20 #endif
21
22 static INT cmp();
23 static INT ins_sch_lst();
24 static INT ins_sc_lst();
25 /* static INT ins_s_lst(); */
26 static INT cjg_rv();
27 static INT cjg_rv_lst();
28 static INT pl_schur_schur();
29 static struct liste * proprt();
30 static INT fct_sch_prt_srt();
31 static struct liste * pro_lg();
32 static INT fct_sch_lg_srt();
33 static INT poids();
34 static INT free_lst();
35 static INT free_newton();
36 static INT shuffle_sig();
37 /* static INT shuffle_sg(); */
38 static INT detr();
39 static INT plth1();
40 static INT plth2();
41 static INT plth3();
42 static INT plth4();
43 static INT plth5();
44 static INT cc_plethysm();
45 static INT calcul();
46 static INT calcula();
47 static INT calculi();
48 static INT operer();
49 static INT plet_conj();
50 static INT conjug();
51 static INT t_list_SYM();
52 static INT conjugate_apply_schur();
53 static INT t_list_coef_SYM();
54
55
56
57 struct liste {
58 INT coef;
59 signed char *tab;
60 struct liste *suivant;
61 };
62
63 struct monomial{
64 int degree;
65 unsigned indice;
66 struct liste *resultat;
67 struct monomial *suivant;
68 };
69
70 /*
71 struct cel{
72 struct cel *prec;
73 struct cel *suiv;
74 signed char *tab;
75 long coef;
76 };
77 */
78 /*
79 struct lst{
80 struct cel *deb;
81 };
82 */
83
84 signed char gv,booo,gvr,lng;
85 /**/
voirbuf(bs)86 void voirbuf(bs) register char *bs;
87 {
88 while(*bs)
89 {
90 printf("%d ",*bs);
91 bs++;
92 }
93 }
94 /**/
95 /*
96 prints the double linked list
97 */
98
99 #ifdef UNDEF
voirlst(plst)100 static void voirlst(plst) struct cel *plst;
101 {
102 while(plst!=NULL)
103 {
104 printf("%ld(",plst->coef);
105 voirbuf(plst->tab);
106 printf(")\n");
107 plst=plst->suiv;
108 }
109 }
110
voirliste(plst)111 static void voirliste(plst) struct liste *plst;
112 {
113 while(plst!=NULL)
114 {
115 printf("%ld(",plst->coef);
116 voirbuf(plst->tab);
117 printf(")\n");
118 plst=plst->suivant;
119 }
120 }
121 #endif
122
cmp(a,b)123 static INT cmp(a,b) OP a,b;
124 {
125 OP as=S_MO_S(a);
126 OP bs=S_MO_S(b);
127
128 INT i=S_PA_LI(as)-1L;
129 INT j=S_PA_LI(bs)-1L;
130
131 for(;i>=0L && j>= 0L;i--,j--)
132 {
133 if(S_PA_II(as,i) > S_PA_II(bs,j))
134 return -1L;
135 if(S_PA_II(as,i) < S_PA_II(bs,j))
136 return 1L;
137 }
138 return 0L;
139 }
140
plethysm(a,b,c)141 INT plethysm(a,b,c) OP a,b,c;
142 /* AK 180299 */
143 /*
144 input object a
145 may be SCHUR, MONOMIAL, ...
146 input object b
147 may be SCHUR, MONOMIAL, ...
148 output object c
149 the plethysm a[b] in the basis of b
150 */
151 {
152 INT erg = OK;
153 CE3(a,b,c,plethysm);
154 if ((S_O_K(a) == SCHUR) && (S_O_K(b) == MONOMIAL))
155 {
156 erg += plethysm_schur_monomial(a,b,c);
157 }
158 else if ((S_O_K(a) == SCHUR) && (S_O_K(b) == SCHUR))
159 {
160 erg += plethysm_schur_schur(a,b,c);
161 }
162 else {
163 erg += WTT("plethysm",a,b);
164 }
165 ENDR("plethysm");
166 }
167
168 /*
169 takes a partition, its maximal indice and conjugates it
170 1 1 2, 2 gives 1 3, 1
171 */
172
plet_conj(pt,pj)173 static INT plet_conj(pt,pj) signed char **pt,*pj;
174 {
175 signed char *btab,*af,*baf,j;
176 signed char mid,temp,high,i;
177
178 j= *pj;
179 btab = *pt+j;
180 mid = *btab;*pj=mid;
181 af=(signed char *)SYM_MALLOC(mid+1);
182 *(af+mid)=0;
183 baf=af; j++;
184 temp = 0;
185 while(j >= 0)
186 {
187 high = 0;
188 while(*btab == mid)
189 {
190 j--;
191 high++;
192 if(j == 0)
193 {
194 j--;
195 break;
196 }
197 btab--;
198 }
199 temp = temp+high;
200 if(j == -1)
201 {
202 for(i=0;i<mid-1;i++)
203 *baf++ =temp;
204 *baf=temp;
205 }
206 else
207 {
208 for(i= *btab;i<mid;i++)
209 *baf++ = temp;
210 mid= *btab;
211 }
212 }
213 SYM_free(*pt);
214 *pt=af;
215 return OK;
216 }
217
218
219 /*takes a partition its length and conjugates it */
220
conjug(tab,j,ve)221 static INT conjug(tab,j,ve)
222 /* tab is a partition j its length */
223 signed char *tab; signed char j; OP ve;
224 {
225 signed char *btab;
226 signed char mid,temp,high,i,k;
227
228 btab = tab+j;
229 mid = *btab;
230 m_il_v( (INT) mid,ve);
231 k = (signed char) 0;
232 j++;
233 temp = 0;
234 while(j >= (signed char) 0)
235 {
236 high = 0;
237 while(*btab == mid)
238 {
239 j--;
240 high++;
241 if(j == 0)
242 {
243 j--;
244 break;
245 }
246 btab--;
247 }
248 temp = temp+high;
249 if(j == -1)
250 i = 0;
251 else
252 i = *btab;
253 for(;i < mid;i++)
254 {
255 M_I_I( (INT)temp , S_V_I( ve,(INT)k ) );
256 k++;
257 }
258 mid = *btab;
259 }
260 return OK;
261 }
262
263 int SYM_strlen();
264
265
operer(n,ttp,deg,baf,cof,liste,parite)266 static INT operer(n,ttp,deg,baf,cof,liste,parite)
267 signed char n,ttp,deg,*baf,parite;
268 struct liste *liste;
269 INT cof;
270
271 {
272 signed char np,cond=0,si,v,tv,k,tp,var,first;
273 register signed char j,jn,temp;
274 signed char *s,*init,*tabn,*st,*af,*bs,*binit,*btabn,*bab,*bobo;
275 static struct liste *liste3p;
276 struct liste *liste1,*liste2=NULL,*liste3;
277 static signed char obo[128];
278
279
280 /* The succesive "buf" which come are ordered; The search in "liste" begins
281 at its first pointed element if buf is the first pointed element of
282 "bp" in calcul (gv = 0) or begins in at the element pointed by liste3p if
283 not */
284
285 first = (signed char)0;
286 if(gv == 0)
287 {
288 liste3 = liste;
289 gv = 1;
290 }
291 else
292 liste3 = liste3p;
293 si = sizeof(struct liste);
294
295 /*j is the length of baf; instead of this: strlen(baf)*/
296
297 j = 0;
298 bab = baf;
299 while(*baf != '\0')
300 {
301 baf++;
302 j++;
303 }
304 /*The maximal length of the new terms will be less than or equal to np;
305 tmp is a useful variable giving the difference of length*/
306
307 tp = ttp - j;
308 np = j + (deg * n);
309
310 /*Allocation of four different tableaux*/
311
312 s = (signed char *)SYM_MALLOC(np + 1);
313 init = (signed char *)SYM_MALLOC(np + 1);
314 af = (signed char *)SYM_MALLOC(np + 1);
315 tabn = (signed char *)SYM_MALLOC(deg + 1);
316
317 /*Init is the initial Schur function we want multiply by the monomial
318 function indexed by n*/
319
320 binit = init;
321 for(jn = 0;jn < np - j;jn++)
322 *binit++ = jn + tp;
323 baf = bab;
324 for(jn = 0;jn < j;jn++)
325 *binit++ = *baf++ + (deg * n);
326 *binit = 0;
327
328 /* s is the tableau result of the product; tab is the tableau giving the
329 position of the parts which are incremented*/
330
331 temp = np - 1;
332
333 if(booo == 1)
334 {
335 binit = init + temp;
336 first = 1;
337 for(jn = temp; jn >= 0; jn--)
338 {
339 if(((*binit) + n - tp - temp) <= lng)
340 break;
341 if(jn != 0)
342 binit--;
343 }
344 binit = init;
345 bs = s;
346 for(temp = 0; temp <= jn - deg;temp++)
347 *bs++ = *binit++;
348 for(;temp < jn;temp++)
349 *bs++ = *binit++ + n;
350 for(; temp < np;temp++)
351 *bs++ = *binit++;
352 *(tabn + deg - 1) = jn + 1;
353 if(j < deg)
354 j = deg;
355 tp = j;
356 var = deg - 1;
357 goto et1;
358 }
359 else
360 {
361 jn = np - deg;
362 binit = init + jn;
363 baf = tabn;
364 bs = s + jn;
365
366 for(;jn <= temp;jn++)
367 {
368 *baf++ = jn;
369 *bs++ = *binit++ + n;
370 }
371 *baf = 0;
372 *bs = 0;
373 bs = s;
374 binit = init;
375 for(jn = 0;jn < np - deg;jn++)
376 *bs++ = *binit++;
377 if(j < deg)
378 j = deg;
379 tp = j;
380 liste2 = liste3->suivant;
381 if(liste2 != NULL)
382 {
383
384 /*The Schur function result of the product must be put in a structure liste
385 which is not empty. The real result is st which is an offset of s*/
386
387 st = (signed char *)SYM_MALLOC(j + 1);
388 baf = st;
389 temp = np - j;
390 bs = s + temp;
391 for(jn = temp;jn < np;jn++)
392 *baf++ = *bs++ ;
393 *baf = 0;
394
395 while(liste2 != NULL)
396 {
397
398 /*Is the Schur function in liste? As the cofactor is ordered, the result
399 must not be very far in the liste*/
400
401 /* Position on the last part of the partition for the liste: bab
402 for the result:bs*/
403
404 temp = -1;
405 bab = liste2->tab;
406 while(*bab != '\0')
407 {
408 bab++;
409 temp++;
410 }
411
412 cond = 0;
413 bab = (liste2->tab) + temp;
414
415 bs = st + j - 1;
416
417 /* The comparaison*/
418
419 for(jn = temp;jn >= 0;jn--)
420 {
421 if(*bs < *bab)
422 {
423 cond = -1;
424 break;
425 }
426 else if(*bs > *bab)
427 {
428 cond = 1;
429 break;
430 }
431 bs--;
432 bab--;
433 }
434
435 /*The result of the comparaison*/
436
437 if(cond > 0)
438
439 /*Stop of the comparaison for insertion*/
440
441 break;
442
443 else if(cond == 0)
444 {
445 /*The Schur function is already in the liste*/
446
447 liste2->coef += (cof * parite);
448
449 if(liste2->coef == 0L)
450 {
451 /*the coefficient of the Schur function is null: Supression*/
452
453 liste1 = liste2->suivant;
454 SYM_free(liste2->tab);
455 SYM_free((signed char *)liste2);
456 liste3->suivant = liste1;
457 liste2 = liste1;
458 }
459 else
460 {
461 liste3 = liste2;
462 liste2 = liste2->suivant;
463 }
464 SYM_free(st);
465 /*the comparaison is ended*/
466
467 break;
468 }
469
470 /*End of if cond == 0*/
471
472 else
473 {
474 /*In this case the comparaison go on*/
475
476 liste3 = liste2;
477 liste2 = liste2->suivant;
478 }
479 }
480
481 /*End of while liste2 != NULL*/
482
483 if (cond != 0)
484 {
485 /*Insertion*/
486
487 liste1 = (struct liste *)SYM_MALLOC(si);
488 liste1->tab = st;
489 liste1->suivant = liste2;
490 liste1->coef = cof * parite;
491 liste3->suivant = liste1;
492 liste3 = liste1;
493 }
494
495 /*The first product from the next cofactor will be after the product st
496 in the pointed liste*/
497
498 liste3p = liste3;
499
500 /* Muir's algorithm starts trying to add n to the part indexed by
501 tabn[0]-1*/
502
503 *tabn -= 1;
504 s[np - deg] = s[np - deg] - n;
505
506 for(;;)
507 {
508 while((v = tabn[0]) >= 0)
509 {
510 /*To try to add the leftest part n of the monomial function*/
511
512 if(((np - v) > lng) && (booo == 0))
513 /*If the result has its length bigger than lng, go out the loop*/
514
515 break;
516 tv = s[v] + n;
517 for(jn= v+1;jn< np;jn++)
518 if(tv == s[jn])
519 /*If two parts are equal, try to put n to another place*/
520
521 break;
522 if(jn == np)
523 {
524 /*Build the vector result in af; af is not ordered*/
525
526 baf = af;
527 bs = s;
528 for(jn= 0;jn< v;jn++)
529 *baf++ = *bs++;
530 *baf++ = tv;
531 bs++;
532 for(jn= v+1;jn< np;jn++)
533 *baf++ = *bs++;
534 *baf = '\0';
535
536 /*We reorder the vector into a partition*/
537
538 tv = parite;
539
540
541 for(k = n /2;k > 0;k /= 2)
542
543 for(jn = k;jn< np;jn++)
544
545 for(j = jn-k;((j >= 0) && (af[j] > af[j+k]));j -= k)
546 {
547 tv = -tv;
548 temp = af[j];
549 af[j] = af[j+k];
550 af[j+k] = temp;
551 }
552 /*j is the length of the partition less one; v is np-v i.e.
553 the number of parts which are null*/
554
555 if(tp < np - v)
556 j = np - v - 1;
557 else
558 {
559 v = np - tp;
560 j = tp - 1;
561 }
562
563 if(first == 1)
564 {
565 if(gvr == 0)
566 {
567 gvr = 1;
568 liste3 = liste;
569 }
570 else
571 {
572 temp = SYM_strlen(obo);
573 bobo = obo + (temp - 1);
574 baf = af + np - 1;
575 if(np < temp)
576 temp = np;
577 for(;temp > 1; temp--)
578 {
579 if(*bobo > *baf)
580 {
581 liste3 = liste3p;
582 break;
583 }
584 else if(*bobo < *baf)
585 {
586 liste3 = liste;
587 break;
588 }
589 bobo--;
590 baf--;
591 }
592 if (temp == 1)
593 {
594 if(*bobo > *baf)
595 liste3 = liste3p;
596 else
597 liste3 = liste;
598 }
599 /* CC 1/3/97
600 SYM_free(obo);
601 */
602 }
603 temp = j + 1;
604 /* CC 1/3/97
605 obo = (signed char *)SYM_MALLOC(temp + 1);
606 */
607 bobo = obo;
608 baf = af + v;
609 for(jn = 0;jn < temp;jn++)
610 *bobo++ = *baf++;
611 *bobo = 0;
612
613 liste2 = liste3->suivant;
614
615 }
616
617 /*It is the same search than before: is the Schur function af in
618 the liste*/
619
620 if (liste2 == NULL)
621 cond = 1;
622
623 while(liste2 != NULL)
624 {
625 temp = -1;
626 bab = liste2->tab;
627 while(*bab != '\0')
628 {
629 bab++;
630 temp++;
631 }
632 bab = (liste2->tab) + temp;
633
634 baf = af + np - 1;
635
636 cond = 0;
637
638 if(temp > j)
639 temp = j;
640
641 for(jn = temp;jn>= 0;jn--)
642 {
643 /*Comparaison*/
644
645 if(*baf < *bab)
646 {
647 cond = -1;
648 break;
649 }
650 else if(*baf > *bab)
651 {
652 cond = 1;
653 break;
654 }
655 baf--;
656 bab--;
657 }
658 if(cond > 0)
659 break;
660 else if(cond == 0)
661 {
662 if(tv == -1)
663 liste2->coef -= cof;
664 else
665 liste2->coef += cof;
666
667 if(liste2->coef == 0L)
668 {
669 liste1 = liste2->suivant;
670 SYM_free(liste2->tab);
671 SYM_free((signed char *)liste2);
672 liste3->suivant = liste1;
673 liste2 = liste1;
674 }
675 else
676 {
677 liste3 = liste2;
678 liste2 = liste2->suivant;
679 }
680
681 break;
682 }
683
684 /*End of if cond == 0*/
685
686 else
687 {
688 liste3 = liste2;
689 liste2 = liste2->suivant;
690 }
691 }
692
693 /*End of while liste2 == NULL*/
694
695 if (cond != 0)
696 {
697 /*Insertion*/
698
699 liste1 = (struct liste *)SYM_MALLOC(si);
700 liste3->suivant = liste1;
701 j++;
702
703 /*The Schur function is put in the liste*/
704
705 bab = (signed char *)SYM_MALLOC(j+1);
706 liste1->tab = bab;
707 baf = af + v;
708 for(jn= 0;jn< j;jn++)
709 *bab++ = *baf++;
710 *bab = '\0';
711 liste1->coef = tv * cof;
712 liste1->suivant = liste2;
713 liste3 = liste1;
714 }
715
716 /*End of cond != 0*/
717 if(first == 1)
718 {
719 first = 0;
720 liste3p = liste3;
721 }
722
723 }
724 /*End of jn == np*/
725
726 tabn[0]--;
727 }
728 /*End of the while tabn[0]>= 0*/
729 var = 1;
730 et1: for(jn= var;jn< deg;jn++)
731 {
732 /*To put all the indexes of the monomial function except the
733 leftest one*/
734
735 bab = tabn + jn;
736 if((v = *bab ) != jn)
737 {
738 /*Shift left still the jn index of the monomial function which is
739 at the position v*/
740
741 binit = init + v;
742 baf = s + v;
743 *baf = *binit;
744 for(j = jn;j >= 0;j--)
745
746 /*Try to put the index j of the monomial function*/
747
748 for(;;)
749 {
750 v--;
751 binit--;
752 baf--;
753 if((j > v) || ((booo == 0) && ((np + j - v) > lng)))
754
755 /*It is impossible to put the jn leftest indexes of the monomial
756 function; try to put more than jn indexes*/
757
758 goto boucle1;
759 else
760 {
761 /*Shift*/
762
763 tv = *binit + n;
764 if(np <= v + n)
765 temp = np;
766 else
767 temp = v + n + 1;
768 bs = s + v;
769 for(k = v+1;k < temp;k++)
770 {
771 bs++;
772 if(tv == *bs)
773 {
774 /*Impossible to shift the index j at position v:
775 try to put at v-1*/
776
777 *baf = *binit;
778 break;
779 }
780 }
781 if(k == temp)
782 {
783 /*Succeed in shifting*/
784
785 *bab-- = v;
786 *baf = *binit + n;
787 break;
788 }
789 }
790 }
791 /*After succeeding in shifting, build a new tableau s*/
792
793 bs = s;
794 binit = init;
795 for(k = 0;k <= v;k++)
796 *bs++ = *binit++;
797 break;
798 }
799 boucle1: ;
800 }
801 if(jn== deg)
802 break;
803 }
804 /*End of the loop for(;;) corresponding to Muir's algorithm*/
805 }
806 else
807 {
808 /*It seems to the preceeding loop except that there is not ordering*/
809
810 liste2 = (struct liste *)SYM_MALLOC(si);
811 liste3->suivant = liste2;
812 liste2->suivant = NULL;
813 liste2->coef = cof * parite;
814 bs = s + (np - j);
815 bab = (signed char *)SYM_MALLOC(j + 1);
816 liste2->tab = bab;
817 for(jn = 0;jn < j;jn++)
818 *bab++ = *bs++;
819 *bab = 0;
820 liste3 = liste2;
821 liste2 = NULL;
822 liste3p = liste3;
823
824 tabn[0]--;
825 s[np - deg] = s[np - deg] - n;
826
827 for(;;)
828 {
829 while((v = tabn[0]) >= 0)
830 {
831 if(((np - v) > lng) && (booo == 0))
832 break;
833 tv = s[v] + n;
834 for(jn = v + 1;jn < np;jn++)
835 if(tv == s[jn])
836 break;
837 if(jn == np)
838 {
839 baf = af;
840 bs = s;
841 for(jn = 0;jn < v;jn++)
842 *baf++ = *bs++;
843 *baf++ = tv;
844 bs++;
845 for(jn = v+1;jn < np;jn++)
846 *baf++ = *bs++;
847 *baf = '\0';
848 tv = parite;
849
850 for(k = n /2;k > 0;k /= 2)
851
852 for(jn = k;jn < np;jn++)
853
854 for(j = jn-k;((j >= 0) && (af[j] > af[j+k]));j -= k)
855 {
856 tv = -tv;
857 temp = af[j];
858 af[j] = af[j+k];
859 af[j+k] = temp;
860 }
861 liste2 = (struct liste *)SYM_MALLOC(si);
862 if(tp < np - v)
863 j = np - v;
864 else
865 {
866 v = np - tp;
867 j = tp;
868 }
869
870 baf = af + v;
871 btabn = (signed char *)SYM_MALLOC(j + 1);
872
873 liste2->tab = btabn;
874 while(*baf != '\0')
875 *btabn++ = *baf++;
876 *btabn = '\0';
877 if(first == 1)
878 {
879 first = 0;
880 liste3p = liste3;
881 }
882 liste2->coef = tv * cof;
883 liste2->suivant = NULL;
884 liste3->suivant = liste2;
885 liste3 = liste2;
886
887 }
888 tabn[0]--;
889 }
890 for(jn = 1;jn < deg;jn++)
891 {
892 /*It is the same loop that in the case liste2!= NULL*/
893
894 btabn = tabn + jn;
895 if((v = *btabn) != jn)
896 {
897 binit = init + v;
898 baf = s + v;
899 *baf = *binit;
900 for(j = jn;j >= 0;j--)
901
902 for(;;)
903 {
904 v--;
905 binit--;
906 baf--;
907 if((j > v) || ((booo == 0) && ((np + j - v) > lng)))
908 goto boucle2;
909 else
910 {
911 tv = *binit + n;
912 if ( np <= v + n )
913 temp = np;
914 else
915 temp = v + n + 1;
916 bs = s + v;
917 for(k = v+1;k < temp;k++)
918 {
919 bs++;
920 if(tv == *bs)
921 {
922 *baf = *binit;
923 break;
924 }
925 }
926 if(k == temp)
927 {
928 *btabn-- = v;
929 *baf = *binit+n;
930 break;
931 }
932 }
933 }
934 bs = s;
935 binit = init;
936 for(k = 0;k <= v;k++)
937 *bs++ = *binit++;
938 break;
939 }
940 boucle2: ;
941 }
942 if(jn == deg)
943 break;
944 }
945 }
946 }
947 SYM_free(s); SYM_free(tabn); SYM_free(af); SYM_free(init);
948 return OK;
949 }
950
951
952
calcul(tab,n,ch,dep,cofe,parite,cond4)953 static INT calcul(tab,n,ch,dep,cofe,parite,cond4)
954 signed char *tab,*ch,parite,cond4;
955 int n;
956 INT cofe;
957 struct liste *dep;
958
959 /*calcul makes the product of the Schur function "ch" by the plethysm
960 L"tab" J"n" ; the final determinant is in dep
961 cond4==n && lg(tab)==1 => dep->suivant==NULL*/
962
963 {
964 signed char mx,boo,boo1,boo2,*btab;
965 register int i,j,k;
966 INT cof;
967 int deg,np; /* from signed int AK 210199 */
968 signed char in,jn,v,tv,ttp,tp,tp1=0,var,first;
969 signed char si,sim,max;
970 signed char *binit,*bs,*s,*init,*tabn,*btabn,*baf,*af;
971 signed char lg;
972 unsigned vr,av,bvr,tvr,ttvr,tttvr,atvr;
973 struct liste *liste,*liste2=NULL,*liste3,*bp;
974 struct monomial stmn,*mn,stmn1,*mn1,*bmn=NULL;
975
976 /* lg is the length of the partition tab (strlen(tab))*/
977
978 btab = tab;
979 first = 0;
980 lg = 0;
981 while(*btab != 0)
982 {
983 btab++;
984 lg++;
985 }
986
987 /* max (resp. deg) is the weight (resp. length) of the partition ch*/
988
989 max = 0;
990 deg = 0;
991 btab = ch;
992 while(*btab != 0)
993 {
994 deg++;
995 max += *btab++;
996 }
997 btab = tab;
998 mx = *btab;
999 /*
1000 printf("n %d cond4 %d lg %d booo %d\n",n,cond4,lg,booo);
1001 */
1002 if((n != cond4) && (lg == 1))
1003 {
1004 gv = 0;
1005
1006 btab = ch;
1007 i = max - deg;
1008 while(*btab != 0)
1009 {
1010 *btab += i;
1011 btab++;
1012 i++;
1013 }
1014 operer(n,max,mx,ch,cofe,dep,parite);
1015 }
1016 else
1017 {
1018 /*In the stucture monomial, there are the different determinants of order i,
1019 i between 1 and lg determinants taken on the i first columns*/
1020
1021 mn = &stmn;
1022 mn->suivant = NULL;
1023 si = sizeof(struct liste);
1024 sim = sizeof(struct monomial);
1025 vr = 1;
1026
1027 if(lg != 1)
1028 boo = 1;
1029 else
1030 boo = parite;
1031 for(k = mx;((k > mx - lg) && (k > 0));k--)
1032 {
1033 /*The calculus of all the determinants of the first column, except may be
1034 the product of the plethysm L0Jn (=1) by ch.*/
1035
1036 if(lg != 1)
1037
1038 /*The determinant is of order bigger than 1: the is put in a liste*/
1039
1040 liste = (struct liste *)SYM_MALLOC(si);
1041 else
1042
1043 /*The determinant is of order 1: the result is returned in dep, argument
1044 of the function calcul*/
1045
1046 liste = dep;
1047
1048 /*The program in the loop "for(k = mx;((k > mx - lg) && (k > 0));k--)"
1049 is the Muir's formula to compute the determinants in the first column:
1050 see this algorithm in operer*/
1051
1052 liste->suivant = NULL;
1053 np = (n * k) + deg;
1054 tp1 = max - deg;
1055
1056 s = (signed char *)SYM_MALLOC(np + 1);
1057 init = (signed char *)SYM_MALLOC(np + 1);
1058 af = (signed char *)SYM_MALLOC(np + 1);
1059 tabn = (signed char *)SYM_MALLOC(k + 1);
1060
1061 baf = ch;
1062 binit = init;
1063 for(in = 0;in < np - deg;in++)
1064 *binit++ = in + tp1;
1065 for(;in < np ;in++)
1066 *binit++ = *baf++ + in + tp1;
1067 *binit = 0;
1068 if(booo == 1)
1069 {
1070 first = 1;
1071 binit = init + np - 1;
1072 for(i = np - 1; i >= 0; i--)
1073 {
1074 if(((*binit) + n - tp1 - np ) < lng)
1075 break;
1076 if(i != 0)
1077 binit--;
1078 }
1079 bs = s;
1080 binit = init;
1081 for(jn = 0; jn <= i-k;jn++)
1082 *bs++ = *binit++;
1083 for(;jn < i;jn++)
1084 *bs++ = *binit++ + n;
1085 for(; jn < np;jn++)
1086 *bs++ = *binit++;
1087 *(tabn + k - 1) = i + 1;
1088 j = deg;
1089 if(j < k)
1090 j = k;
1091 var = k - 1;
1092 goto et3;
1093 }
1094 else
1095 {
1096 bs = s ;
1097 binit = init;
1098 btabn = tabn;
1099 for(in = 0;in < np - k; in ++)
1100 *bs++ = *binit++;
1101 for(; in < np; in++)
1102 {
1103 *bs++ = *binit++ + n;
1104 *btabn++ = in;
1105 }
1106 *btabn = 0;
1107 *bs = 0;
1108
1109 j = deg;
1110 if(j < k)
1111 j = k;
1112
1113 liste2 = (struct liste*)SYM_MALLOC(si);
1114 if(lg != 1)
1115 liste2->coef = 1L;
1116 else
1117 liste2->coef = boo * cofe;
1118 bs = s + (np - j);
1119 btabn = (signed char *)SYM_MALLOC(j + 1);
1120 liste2->tab = btabn;
1121 while(*bs != 0)
1122 *btabn++ = *bs++ ;
1123 *btabn = '\0';
1124 liste2->suivant = NULL;
1125 liste->suivant = liste2;
1126
1127 tabn[0]--;
1128 s[np - k] = s[np - k] - n;
1129
1130 for(;;)
1131 {
1132 while((v = tabn[0]) >= 0)
1133 {
1134 if(((np - v) > lng) && (booo == 0))
1135 break;
1136 tv = s[v] + n;
1137 for(in = v+1;in < np;in++)
1138 if(tv == s[in])
1139 break;
1140 if(in == np)
1141 {
1142
1143 baf = af;
1144 bs = s;
1145 for(in = 0;in < v;in++)
1146 *baf++ = *bs++;
1147 bs = s + v + 1;
1148 *baf++ = tv;
1149 for(in = v+1;in < np;in++)
1150 *baf++ = *bs++;
1151 *baf = '\0';
1152 tv = boo;
1153
1154 for(i = n /2;i > 0;i /= 2)
1155
1156 for(in = i;in < np;in++)
1157
1158 for(jn = in-i;((jn >= 0) && (af[jn] > af[jn+i]));jn -= i)
1159
1160 {
1161 tv = -tv;
1162 ttp = af[jn];
1163 af[jn] = af[jn+i];
1164 af[jn+i] = ttp;
1165 }
1166
1167
1168 bp = (struct liste *)SYM_MALLOC(si);
1169 if(j < np - v)
1170 jn = np - v;
1171 else
1172 {
1173 v = np - j;
1174 jn = j;
1175 }
1176
1177 btabn = (signed char *) SYM_MALLOC(jn + 1);
1178 bp->tab = btabn;
1179 baf = af + v;
1180 while(*baf != 0)
1181 *btabn++ = *baf++;
1182
1183 *btabn = '\0';
1184 if(lg != 1)
1185 bp->coef = tv;
1186 else
1187 bp->coef = tv * cofe;
1188 bp->suivant = NULL;
1189 if(first == 1)
1190 {
1191 first = 0;
1192 liste2 = liste;
1193 }
1194 liste2->suivant = bp;
1195 liste2 = bp;
1196
1197 }
1198 tabn[0]--;
1199 }
1200 var = 1;
1201 et3:
1202
1203 for(in = var;in < k;in++)
1204 {
1205 btabn = tabn + in;
1206 if((v = *btabn) != in)
1207 {
1208 binit = init + v;
1209 baf = s + v;
1210 *baf = *binit;
1211 for(jn = in;jn >= 0;jn--)
1212
1213 for(;;)
1214 {
1215 v--;
1216 binit--;
1217 baf--;
1218 if((jn > v) || ((booo == 0) && ((np + jn - v) > lng)))
1219 goto boucle;
1220 else
1221 {
1222 tv = *binit+n;
1223 if ( np <= v + n )
1224 ttp = np;
1225 else
1226 ttp = v + n + 1;
1227 bs = s + v;
1228 for(i = v+1;i < ttp;i++)
1229 {
1230 bs++;
1231 if(tv == *bs)
1232 {
1233 *baf = *binit;
1234 break;
1235 }
1236 }
1237 if(i == ttp)
1238 {
1239 *btabn-- = v;
1240 *baf = *binit+n;
1241 break;
1242 }
1243 }
1244 }
1245 bs = s;
1246 binit = init;
1247 for(i = 0;i <= v;i++)
1248 *bs++ = *binit++;
1249 break;
1250 }
1251 boucle: ;
1252 }
1253 if(in == k)
1254 break;
1255 }
1256 }
1257 SYM_free(s); SYM_free(tabn); SYM_free(af); SYM_free(init);
1258 if (lg != 1)
1259 {
1260 /*The option is bigger than 0: if the final determinant is not of
1261 order 1, write the different partial results in the pointed liste of
1262 type struct monomial: stmn*/
1263
1264 mn->suivant = (struct monomial *)SYM_MALLOC(sim);
1265 mn = mn->suivant;
1266 mn->resultat = liste;
1267
1268 /*The record indice is used to recognize the different determinants*/
1269
1270 mn->indice = vr;
1271 vr = vr << 1;
1272 mn->degree = k;
1273 mn->suivant = NULL;
1274 }
1275
1276 }
1277 /*End of the loop for(k = mx;((k > mx - lg) && (k > 0));k--)*/
1278
1279 if((k == 0) && (k != mx - lg))
1280 {
1281 /*To put a determinant of value the partition ch*/
1282
1283 if(lg != 1)
1284
1285 /*Not final liste*/
1286
1287 liste = (struct liste *)SYM_MALLOC(si);
1288 else
1289
1290 /*Final liste*/
1291
1292 liste = dep;
1293 liste2 = (struct liste *)SYM_MALLOC(si);
1294 liste->suivant = liste2;
1295
1296 /*Write the coefficient*/
1297
1298 if(lg != 1)
1299 liste2->coef = 1L;
1300 else
1301 liste2->coef = boo * cofe;
1302
1303 /*write the partition*/
1304
1305 baf = (signed char *)SYM_MALLOC(deg + 1);
1306 liste2->tab = baf;
1307 bs = ch;
1308 for(i = max - deg;i < max ;i++)
1309 *baf++ = *bs++ + i ;
1310 *baf = 0;
1311 liste2->suivant = NULL;
1312
1313 if(lg != 1)
1314 {
1315 mn->suivant = (struct monomial *)SYM_MALLOC(sim);
1316 mn = mn->suivant;
1317 mn->resultat = liste;
1318 mn->indice = vr;
1319 mn->degree = 0;
1320 mn->suivant = NULL;
1321 }
1322
1323 }
1324 boo = 1;
1325 if(lg != 1)
1326 {
1327 /*The determinant is of order bigger than 0*/
1328
1329 vr = 1;
1330 av = (1 << (lg - 1));
1331
1332 for(i = 1;i < lg;i++)
1333 {
1334 /*The algorithm progresses with columns i+1*/
1335
1336 /*The option is bigger than i: we will write in the structure monomial*/
1337
1338 if(boo == 1)
1339 {
1340 /*The preceeding determinants (of order i ) are in stmn;
1341 put the determinants ( of order i+1) we are going to compute
1342 in stmn1*/
1343
1344 mn = stmn.suivant;
1345 mn1 = &stmn1;
1346 }
1347 else
1348 {
1349 /*The preceeding determinants (of order i ) are in stmn1;
1350 put the determinants ( of order i+1) we are going to compute
1351 in stmn*/
1352
1353 mn = stmn1.suivant;
1354 mn1 = &stmn;
1355 }
1356 mn1->suivant = NULL;
1357
1358 /*All the variables of type unsigned is used to enumerate
1359 the determinants: for example the determinants of order 2 have
1360 for indices the characters 00000011, 00000101, 00001001, ...
1361 where the position of 1 are the rows of the cofactor*/
1362
1363 av = av | (1 << (lg - i - 1));
1364 vr = (1 << i) | vr;
1365
1366 /*vr will be the index of the first determinant of order i+1 we
1367 compute; for example for the determinants of order 3, vr is 111*/
1368
1369 tvr = vr;
1370
1371 btab++;
1372 mx = *btab;
1373
1374 for(;;)
1375 {
1376 /*CALCUL of the determinant of index tvr*/
1377
1378 tp = -1;
1379
1380 if(i != lg - 1)
1381 {
1382 /*Not final liste*/
1383
1384 liste = (struct liste *)SYM_MALLOC(si);
1385 liste->suivant = NULL;
1386 }
1387 else
1388 /*Final liste*/
1389
1390 liste = dep;
1391
1392 boo1 = 0;
1393 boo2 = 0;
1394 tv = -1;
1395
1396 for(in = lg - 1;in >= 0;in--)
1397 {
1398 /*Consider the factor which is in the row in + 1, and on the columns
1399 i + 1*/
1400
1401 if(tp == i)
1402
1403 /*The computation of the determinant indexed by tvr is finished*/
1404
1405 break;
1406 ttvr = tvr;
1407 if(((ttvr >> in) & 1) == 0)
1408
1409 /*The factor is not used in the computation of the determinant indexed
1410 by tvr*/
1411
1412 continue;
1413 ttvr = (1 << in) ^ tvr;
1414 tp++;
1415 deg = mx + i - in;
1416 if(deg < 0)
1417
1418 /*The factor is null*/
1419
1420 continue;
1421 if((deg > lng) && (booo == 0))
1422 break;
1423
1424 else
1425 {
1426 tv = -tv;
1427 if(deg == 0)
1428 {
1429 /*The factor is equal to 1*/
1430
1431 /*Read the cofactor from the monomial structure mn*/
1432
1433 bmn = mn;
1434 while(bmn != NULL)
1435 {
1436 /*Search of the cofactor*/
1437
1438 if(bmn->indice == ttvr)
1439 break;
1440 bmn = bmn->suivant;
1441 }
1442 if(bmn == NULL)
1443
1444 /*The cofactor is null; it will be the same for the cofactor
1445 not yet considered: break */
1446
1447 break;
1448 boo1 = 1;
1449 if(boo2 == 0)
1450 {
1451 /*the product 'tp1*n' will be the weight of the Schur function
1452 indexed by tvr*/
1453
1454 boo2 = 1;
1455 tp1 = bmn->degree;
1456 }
1457 bp = (bmn->resultat)->suivant;
1458
1459 liste3 = liste;
1460 liste2 = liste3->suivant;
1461
1462 while( bp!= NULL)
1463 {
1464 /*Copy in liste the cofactor (the factor is equal to one);
1465 at the beginning liste2 is null; moreover the cofactor is
1466 already ordered: it is just a copy*/
1467
1468 liste2 = (struct liste *)SYM_MALLOC(si);
1469 baf = bp->tab;
1470 j = 0;
1471 while(*baf != 0)
1472 {
1473 baf++;
1474 j++;
1475 }
1476 bs = (signed char *)SYM_MALLOC(j+1);
1477
1478 /*Write the partition*/
1479
1480 baf = bp->tab;
1481 liste2->tab = bs;
1482 while(*baf != 0)
1483 *bs++ = *baf++;
1484 *bs = 0;
1485
1486 /*Write the coefficient*/
1487
1488 liste2->coef = bp->coef * tv;
1489
1490 liste2->suivant = NULL;
1491 liste3->suivant = liste2;
1492 liste3 = liste2;
1493 bp = bp->suivant;
1494
1495 }
1496 }
1497 /*End of the if deg == 0*/
1498 else
1499 {
1500 gvr = 0;
1501
1502 /*It is the product by the monomial function indexed by deg and
1503 its cofactor indexed by ttvr*/
1504
1505
1506 /* The preceeding result is in the monomial structure bmn*/
1507
1508 if(boo1 == 1)
1509 {
1510
1511 /* The calculus of a determinant has already begun*/
1512
1513 bmn = bmn->suivant;
1514 }
1515 else
1516 {
1517 bmn = mn;
1518 }
1519 while(bmn != NULL)
1520 {
1521
1522 /* It is the search of the cofactor of the monomial indexed
1523 by deg*/
1524
1525 if(bmn->indice == ttvr)
1526 break;
1527 bmn = bmn->suivant;
1528 }
1529 if(bmn == NULL)
1530
1531 /*The cofactor is null*/
1532
1533 break;
1534
1535 /*The cofactor is not null; boo1 signals that for the next
1536 step in the calculus of the determinant a product factor
1537 by cofactor different from 0 has already been*/
1538
1539 boo1 = 1;
1540 if(boo2 == 0)
1541 {
1542
1543 /* In the first product (boo2 == 0), '(tp1*n)+max', where max
1544 is the weight of the second partition entered, is the weight
1545 of the Schur function we are computing*/
1546
1547 boo2 = 1;
1548 tp1 = bmn->degree + deg;
1549 }
1550
1551 /* bp is the cofactor*/
1552
1553 bp = (bmn->resultat)->suivant;
1554
1555 /*ttp is the degree maxi of the cofactor np1 is the degree
1556 of the product*/
1557
1558 ttp = (bmn->degree * n) + max;
1559
1560 /*gv is a global variable to indicate to operer that the
1561 product begins*/
1562
1563 gv = 0;
1564
1565 while(bp != NULL)
1566 {
1567
1568 /* operer which makes the product is called for each term
1569 of the cofactor*/
1570
1571 cof = bp->coef * tv;
1572 if(i == lg - 1)
1573 {
1574 cof = cof * cofe;
1575 j = parite;
1576 }
1577 else
1578 j = 1;
1579 operer(n,ttp,deg,bp->tab,cof,liste,j);
1580 bp = bp->suivant;
1581 }
1582
1583 }
1584 /*End of deg > 0*/
1585 }
1586 /*End of a product factor by cofactor*/
1587 }
1588 /*End of the computation of the determinant indexed by tvr*/
1589
1590 if(liste->suivant == NULL)
1591 SYM_free((signed char *)liste);
1592 else
1593 {
1594 if( i != lg - 1)
1595 {
1596 /*i < opt: do not use the files; i!=lg-1: put the liste in the
1597 structure pointed by mn1*/
1598
1599 bmn = (struct monomial *)SYM_MALLOC(sim);
1600 mn1->suivant = bmn;
1601 mn1 = bmn;
1602 mn1->suivant = NULL;
1603 mn1->indice = tvr;
1604 mn1->degree = tp1;
1605 mn1->resultat = liste;
1606 }
1607
1608 }
1609 if(av == tvr)
1610
1611 /*The computation of the determinants of order i+1 is finished: break*/
1612
1613 break;
1614
1615 /*tvr will be the index of the next determinant: for example for
1616 lg+1 = 4,and i+1 = 2, the order for the indexes is the following:
1617 0011,0101,0110,1001,1010,1100*/
1618
1619 ttvr = tvr;
1620 atvr = 0xFFFF;
1621 tp = 0;
1622 tp1 = 0;
1623 bvr = 1;
1624 while((ttvr & 1) == 0)
1625 {
1626 ttvr = ttvr >> 1;
1627 bvr = (bvr << 1) | 1;
1628 tp++;
1629 }
1630 tttvr = 0;
1631 tp++;
1632 tp1++;
1633 bvr = (bvr << 1 ) | 1;
1634 ttvr = ttvr >> 1;
1635 while((ttvr & 1) == 1)
1636 {
1637 ttvr = ttvr >> 1;
1638 tttvr = (tttvr << 1) | 1;
1639 bvr = (bvr << 1) | 1;
1640 tp++;
1641 tp1++;
1642 }
1643 ttvr = (1 << tp) | tttvr;
1644 atvr = atvr << tp;
1645 tvr = atvr & tvr;
1646 tvr = tvr | ttvr;
1647 }
1648
1649 /*Erase the structure having the last results
1650 (determinants of order i)*/
1651
1652 if(boo == 1)
1653 mn = stmn.suivant;
1654 else
1655 mn = stmn1.suivant;
1656
1657 while(mn != NULL)
1658 {
1659 bp = (mn->resultat)->suivant;
1660 while(bp != NULL)
1661 {
1662 SYM_free(bp->tab);
1663 liste = bp;
1664 bp = bp->suivant;
1665 SYM_free((signed char *)liste);
1666 }
1667 mn1 = mn;
1668 mn = mn->suivant;
1669 SYM_free((signed char *)(mn1->resultat));
1670 SYM_free((signed char *)mn1);
1671 }
1672
1673 boo = -boo;
1674 }
1675 /* End of the loop for(i = 1 ;i < lg ; i++) */
1676 }
1677 /* End of the condition lg != 1 */
1678 }
1679 return OK;
1680 }
1681
1682 /*
1683 is used by plth3 to compute
1684 product of \psi^outer(S_inner), in the basis of Schur functions,
1685 where outer and inner are partitions.
1686 */
1687
calculi(sch,inner,outer,dep)1688 static INT calculi(sch,inner,outer,dep) signed char *outer, *inner, *sch;
1689 struct liste *dep;
1690 {
1691 struct liste *bp, *entree;
1692 register signed char *bs, tp;
1693 signed char pas, tmp,we;
1694
1695 pas=0;
1696 bs=inner;
1697 while(*bs) pas+= *bs++;
1698
1699 tmp= -1;
1700 bs=sch;
1701 while(*bs) tmp+= *bs++;
1702 we=tmp;
1703
1704 entree=(struct liste *) SYM_MALLOC(sizeof(struct liste));
1705 entree->coef= 1L;
1706 entree->tab= sch;
1707 entree->suivant=NULL;
1708 while(*outer)
1709 {
1710 while(entree!=NULL)
1711 {
1712 if(tmp== we)
1713 {
1714 gvr=0;
1715 calcul(inner,(int) *outer,entree->tab,dep,entree->coef,1,*outer+1);
1716 }
1717 else
1718 {
1719 bs=entree->tab;
1720 while(*bs) bs++;
1721 bs--;
1722 tp=tmp;
1723 for(;;)
1724 {
1725 *bs -=tp;
1726 if(bs==entree->tab) break;
1727 bs--; tp--;
1728 }
1729 gvr=0;
1730 calcul(inner,(int) *outer,entree->tab,dep,entree->coef,1,*outer+1);
1731 }
1732 SYM_free(entree->tab);
1733 bp=entree;
1734 entree=entree->suivant;
1735 SYM_free((signed char *)bp);
1736 }
1737 tmp += ((*outer)*pas);
1738 entree=dep->suivant;
1739 dep->suivant=NULL;
1740 outer++;
1741 }
1742 dep->suivant=entree;
1743 return OK;
1744 }
1745
calcula(inner,np,pa,res)1746 static INT calcula(inner,np,pa,res)
1747 signed char *inner,np;
1748 OP res;
1749 OP pa;
1750
1751 {
1752 OP crc,pb,cb,cf,tr;
1753 register signed char *bs,tp;
1754 INT i;
1755 signed char pas,av,tmp,lb,lim,*outer,*bouter;
1756 struct liste str, *bp, *db,*entree;
1757
1758 if (S_O_K(res) != SCHUR) error("calcula:res != SCHUR");
1759
1760
1761 pas=0;
1762 bs=inner;
1763 while(*bs) pas+= *bs++;
1764 if(booo==0) lim= *(bs-1); else lim=bs-inner;
1765
1766 db=(struct liste *)SYM_MALLOC(sizeof(struct liste));
1767 db->coef= 1L;
1768 db->tab= (signed char *)SYM_calloc(1,1);
1769 db->suivant=NULL;
1770
1771 str.suivant=NULL;
1772 cb=callocobject();cf=callocobject();
1773 crc=callocobject(); m_part_sc(pa,crc);
1774 for(i=0L;i<S_SC_PLI(crc);i++)
1775 {
1776 pb= S_SC_PI(crc,i);
1777 lb= S_PA_LI(pb);
1778 if(S_I_I(S_SC_WI(crc,(INT)i))!=0L
1779 && lim<=lng)
1780 {
1781 bs=(signed char *)SYM_MALLOC(S_PA_LI(pb)+1);
1782 outer=bs;
1783 for(tp=0;tp<S_PA_LI(pb);tp++)
1784 *bs++ =S_PA_II(pb,tp);
1785 *bs=0;
1786
1787 entree=db;
1788 bouter=outer;
1789 tmp= -1;
1790
1791 while(*bouter!=0)
1792 {
1793
1794 while(entree!=NULL)
1795 {
1796 if(*entree->tab==0)
1797 {
1798 gvr=0;
1799 calcul(inner,(int) *bouter,entree->tab,&str,1,1,*bouter);
1800 entree=entree->suivant;
1801 }/*End of if(*entree->tab==0)*/
1802 else
1803 {
1804 bs=entree->tab;
1805 while(*bs) bs++;
1806 bs--;
1807 tp=tmp;
1808 for(;;)
1809 {
1810 *bs -=tp;
1811 if(bs==entree->tab) break;
1812 bs--; tp--;
1813 }
1814 gvr=0;
1815 calcul(inner,(int) *bouter,entree->tab,&str,entree->coef,1,*bouter+1);
1816 SYM_free(entree->tab);
1817 bp=entree;
1818 entree=entree->suivant;
1819 SYM_free((signed char *)bp);
1820 }/*End of else of if(*entree->tab==0)*/
1821 }/*End of while(entree!=NULL)*/
1822 if(*(bouter+1)!=0)
1823 {
1824 tmp += *bouter*pas;
1825 entree=str.suivant;
1826 }
1827 else
1828 {
1829 tr=callocobject();
1830 bs=outer;
1831 /*Suppress cb=callocobject(); CC 24/01/97*/
1832 M_I_I(1L,cb);av=0;
1833 while(*bs)
1834 {
1835 M_I_I(*bs,cf);
1836 mult_apply(cf,cb);
1837 if(*bs==av)
1838 {
1839 tp++;
1840 M_I_I(tp,cf);
1841 mult_apply(cf,cb);
1842 }
1843 else tp = 1;
1844 av= *bs;
1845 bs++;
1846 }
1847 div(S_SC_WI(crc,i),cb,cf);
1848 t_list_coef_SYM(&str,cf,np,tr);
1849 /*CC 24/01/97*/ freeself(cb); freeself(cf);
1850 if(nullp(res))
1851 {
1852 copy(tr,res);
1853 freeall(tr); /* CC 24/07/97*/
1854 }
1855 else
1856 {
1857 insert(tr,res,add_koeff,cmp);
1858 }
1859 }
1860 str.suivant=NULL;
1861 bouter++;
1862 }/*End of while(*bouter!=0)*/
1863 SYM_free(outer);
1864 }/*End of if(S_I_I(S_SC_WI(...)*/
1865 }/*End of for(i=0L;i<...*/
1866 SYM_free(db->tab);
1867 SYM_free((char *) db);
1868 freeall(crc);/**/
1869 freeall(cf);
1870 freeall(cb);/* suppress CC 24/01/97 */
1871 return OK;
1872 }
1873
1874
1875
1876 /*
1877 Input os,on,opsi.
1878 Output ores
1879 make the product of S_os by the plethysm \psi_on(S_psi)
1880 cond3==0=> limits upon length
1881 cond3==1=> limits upon the biggest part
1882 */
1883
plth1(os,on,opsi,cond3,ores)1884 static INT plth1(os,on,opsi,cond3,ores) OP os,on,opsi,ores;char cond3;
1885 {
1886 register signed char *bs,i,j;
1887 register struct liste *bp;
1888 int tmp; /* AK 210199 */
1889 signed char li,lj,inv,tp,n,*s,*psi;
1890 struct liste stdep,*dep;
1891 OP sc,ve,cf,pol,d;
1892
1893 if(S_O_K(os)!=INTEGER && S_O_K(os)!=PARTITION)
1894 return error("plth1: wrong first type");
1895 if(S_O_K(opsi)!=INTEGER && S_O_K(opsi)!=PARTITION)
1896 return error("plth1: wrong third type");
1897 if(S_O_K(on)!=INTEGER)
1898 return error("plth1: wrong second type");
1899 if(lng<0L)
1900 {
1901 init(SCHUR,ores);
1902 return OK;
1903 }
1904 n=S_I_I(on);
1905 if(n<0)
1906 {
1907 init(SCHUR,ores);
1908 return OK;
1909 }
1910
1911 if(S_O_K(os)==INTEGER)
1912 {
1913 if(S_I_I(os)<0L)
1914 {
1915 init(SCHUR,ores); return OK;
1916 }
1917 sc=callocobject();
1918 if(S_I_I(os)==0L) m_il_v(0L,sc);
1919 else
1920 {
1921 m_il_v(1L,sc);
1922 M_I_I(S_I_I(os),S_V_I(sc,0L));
1923 }
1924 freeself(os); b_ks_pa(VECTOR,sc,os);
1925 }
1926 if(n==0)
1927 {
1928 if(not EMPTYP(ores)) freeself(ores);
1929 sc=callocobject();
1930 weight(os,sc); /*CC 240596 to change with the upon the length of os*/
1931 if(S_I_I(sc)==0L)
1932 {
1933 M_I_I(1L,ores);freeall(sc);
1934 return OK;
1935 }
1936 freeall(sc);
1937 m_skn_s(os,cons_eins,NULL,ores);
1938 return OK;
1939 }
1940 if(S_O_K(opsi)==INTEGER)
1941 {
1942 if(S_I_I(opsi)<0L)
1943 {
1944 init(SCHUR,ores);
1945 return OK;
1946 }
1947 sc=callocobject();
1948 if(S_I_I(opsi)==0L) m_il_v(0L,sc);
1949 else
1950 {
1951 m_il_v(1L,sc);
1952 M_I_I(S_I_I(opsi),S_V_I(sc,0L));
1953 }
1954 freeself(opsi); b_ks_pa(VECTOR,sc,opsi);
1955 }
1956 sc=callocobject();
1957 weight(opsi,sc); /*CC 240596 to change with the upon the length of opsi*/
1958 if(S_I_I(sc)==0L)
1959 {
1960 freeall(sc);
1961 if(not EMPTYP(ores)) freeself(ores);
1962 sc=callocobject();
1963 weight(os,sc); /*CC 240596 to change with the upon the length of os*/
1964 if(S_I_I(sc)!=0L)
1965 {
1966 m_skn_s(os,cons_eins,NULL,ores);freeall(sc);
1967 return OK;
1968 }
1969 else
1970 {
1971 M_I_I(1L,ores);
1972 freeall(sc);
1973 return OK;
1974 }
1975 }
1976 freeall(sc);
1977
1978 dep= &stdep; dep->suivant=NULL;
1979
1980 li=(signed char)S_PA_LI(os); lj=(signed char)S_PA_LI(opsi);
1981 if((cond3==1 && (S_PA_II(os,(INT)li-1L)>lng || S_PA_II(opsi,(INT)lj-1L)>lng))||(cond3==0 && (li>lng||lj>lng)))
1982 {
1983 init(SCHUR,ores); return OK;
1984 }
1985 if(not EMPTYP(ores)) freeself(ores);
1986 if(n==1)
1987 {
1988 sc=callocobject();
1989 M_I_I(lng,sc);
1990 l_outerproduct_schur_lrs(sc,os,opsi,ores);
1991 freeall(sc);
1992 return OK;
1993 }
1994
1995 bs=(signed char *)SYM_MALLOC(li+1);
1996 s=bs; tp=0;
1997 for(i=0;i<li;i++,bs++)
1998 tp += *bs=S_PA_II(os,(INT)i);
1999 *bs=0;
2000
2001 bs=(signed char *)SYM_MALLOC(lj+1);
2002 psi=bs;tmp=0;
2003 for(i=0;i<lj;i++,bs++)
2004 tmp += *bs=S_PA_II(opsi,(INT)i);
2005 *bs-- =0;
2006
2007 tmp= n*tmp+tp;
2008 if(tmp>127)
2009 {
2010 fprintf(stderr,"Plethysms too big\n");
2011 SYM_free((signed char*)psi); SYM_free((signed char*)s);
2012 exit(0);
2013 }
2014
2015 if(lj>= *bs)
2016 {
2017 lj--;inv=0;
2018 plet_conj(&psi,&lj);
2019 }
2020 else
2021 {
2022 inv=1;
2023 if(*s)
2024 {
2025 li--;
2026 plet_conj(&s,&li);
2027 }
2028 }
2029
2030 gvr=0;
2031 if(cond3==0) booo=inv;
2032 else
2033 {
2034 if(inv==1) booo=0;
2035 else booo=1;
2036 }
2037 calcul(psi,(int) n,s,dep,1L,1,n);
2038
2039 bp=dep->suivant;
2040
2041 init(SCHUR,ores);d=ores;
2042 while(bp!=NULL)
2043 {
2044 bs=bp->tab;
2045 j= -1;
2046 while(*bs){ bs++;j++;}
2047 bs--;
2048 tp=tmp-1;
2049 for(i=j;i>=0;i--)
2050 {
2051 (*bs--) -=tp;
2052 tp--;
2053 }
2054
2055 /*ALLOCATION OF A NEW MEMORY FOR THE VECTOR ve AND THE SCHUR FUNCTION sc.
2056 THE RESULT ores */
2057
2058 sc = callocobject();
2059 ve = callocobject();
2060 pol=callocobject();
2061 init(VECTOR,ve);
2062 if(inv == 1)
2063 {
2064 conjug( bp->tab , j , ve);
2065 }
2066 else
2067 {
2068 bs = bp->tab;
2069 m_il_v( (INT)(j+1), ve );
2070 for(i = 0; i<=j ;i++)
2071 {
2072 M_I_I( (INT)(*bs), S_V_I(ve, (INT) i));
2073 bs++;
2074 }
2075 }
2076 SYM_free(bp->tab);
2077 b_ks_pa(VECTOR,ve,sc);
2078 cf=callocobject(); M_I_I(bp->coef,cf);
2079 b_skn_s(sc,cf,NULL,pol);
2080 c_l_n(d,pol);d=pol;
2081
2082 dep = bp;
2083 bp = bp->suivant;
2084 SYM_free((signed char *)dep);
2085 }
2086 if(S_L_N(ores)!=NULL)
2087 {
2088 /*CC 24/01/97*/
2089 d=S_L_N(ores);
2090 c_l_s(ores,S_L_S(S_L_N(ores)));
2091 c_l_n(ores,S_L_N(S_L_N(ores)));
2092 c_l_n(d,NULL);
2093 c_l_s(d,NULL);
2094 freeall(d);
2095 }
2096 SYM_free((signed char*)psi); SYM_free((signed char*)s);
2097 return OK;
2098 }
2099 /*
2100 computes S_m (cond1==0) or \Lambda_m (cond1==1) of S_{tab} (cond2==0)
2101 or \Lambda_tab(cond2==1) restricted upon length (cond3==0)
2102 or upon parts (cond3==1)
2103 */
2104
plth2(tab,cond1,cond2,cond3,m,newton)2105 static INT plth2(tab,cond1,cond2,cond3,m,newton)
2106 signed char *tab,cond1,cond2,cond3;
2107 int m;
2108 struct liste *newton;
2109 {
2110 signed char *s,*bs,*btab,*baf,*af,*bch,*tab1;
2111 char condition,parite,mx,np,npt,le,inv;
2112 INT cof;
2113 signed char n,in;
2114 signed char k;
2115 signed char cond,high,mid;
2116 register signed char i,j,temp;
2117 struct liste str,*bp,*liste,*liste1;
2118
2119 le=0;
2120 mx=0;
2121 btab=tab;
2122 while(*btab!=0)
2123 {
2124 le++;
2125 mx += *btab;
2126 btab++;
2127 }
2128 inv=0;
2129 if(*(btab - 1) < le)
2130 {
2131 inv = 1;
2132 tab1 = (signed char *)SYM_MALLOC(*(btab - 1) + 1);
2133 bs = tab1;
2134 btab = tab;
2135 af = (signed char *)SYM_MALLOC(le + 1);
2136 baf = af;
2137 while(*btab != 0)
2138 *baf++ = *btab++;
2139 *baf = 0;
2140
2141 cond = -1;
2142 j = le - 1;
2143 btab = af + j;
2144 mid = *btab;
2145 j++;
2146 temp = 0;
2147 while(j >= 0)
2148 {
2149 high = 0;
2150 while(*btab == mid)
2151 {
2152 j--;
2153 high++;
2154 if(j == 0)
2155 {
2156 *btab = 0;
2157 j--;
2158 break;
2159 }
2160 btab--;
2161 }
2162 temp = temp+high;
2163 for(i = *btab;i < mid;i++)
2164 {
2165 cond++;
2166 *bs++ = temp;
2167 }
2168 mid = *btab;
2169 }
2170 *bs = 0;
2171 SYM_free(af);
2172 }
2173 else
2174 {
2175 tab1 = (signed char *)SYM_MALLOC(le + 1);
2176 btab = tab;
2177 bch = tab1;
2178 while(*btab != 0)
2179 *bch++ = *btab++;
2180 *bch = 0;
2181 }
2182
2183 booo = 0;
2184 if((( cond2 == 0) && (inv == 0)) || ((cond2 == 1) && (inv == 1)))
2185 booo = 1;
2186 if(cond2 == 0)
2187 {
2188 if(lng < le)
2189 {
2190 fprintf(stderr,"No elements of the length %d in this plethysm\n",m);
2191 return ERROR;
2192 }
2193 }
2194 else
2195 if(lng < *(tab + le - 1))
2196 {
2197 fprintf(stderr,"No elements of the length %d in this plethysm\n",m);
2198 return ERROR;
2199 }
2200
2201
2202 liste1 = &str;
2203
2204 if ( cond2 == 0)
2205
2206 if(cond1 == 0)
2207
2208 if((mx%2 == 0) || ((mx%2 == 1)&&(inv == 1)))
2209 condition = 0;
2210 else
2211
2212 condition = 1;
2213 else
2214
2215 if((mx%2 == 0) || ((mx%2 == 1)&&(inv == 1)))
2216 condition = 1;
2217 else
2218 condition = 0;
2219 else
2220
2221 if(cond1 == 0)
2222 if((inv == 0) || ((inv == 1) && (mx%2 == 0)))
2223 condition = 0;
2224 else
2225
2226 condition = 1;
2227 else
2228 if((inv == 0) || ((inv == 1) && (mx%2 == 0)))
2229 condition = 1;
2230 else
2231
2232 condition = 0;
2233 liste = (struct liste *)SYM_MALLOC(sizeof(struct liste));
2234 liste->coef = 1L;
2235 liste->suivant = NULL;
2236 liste1->suivant = liste;
2237 bs = (signed char *)SYM_MALLOC(1);
2238 liste->tab = bs;
2239 *bs = 0;
2240 (newton)->suivant = liste1->suivant;
2241
2242
2243 for(n = 1;n <= m;n++)
2244 {
2245 liste1->suivant = NULL;
2246 np = n * mx;
2247 npt = np;
2248 if( n == 1)
2249 {
2250 liste = (struct liste *)SYM_MALLOC(sizeof(struct liste));
2251 liste->coef = 1L;
2252 liste->suivant = NULL;
2253 liste1->suivant = liste;
2254 if (inv == 0)
2255 {
2256 bs = (signed char *)SYM_MALLOC(tab[le - 1] + 1);
2257 liste->tab = bs;
2258 btab = tab;
2259 af = (signed char *)SYM_MALLOC(le + 1);
2260 baf = af;
2261 while(*btab != 0)
2262 *baf++ = *btab++;
2263 *baf = 0;
2264
2265 cond = -1;
2266 j = le - 1;
2267 btab = af + j;
2268 mid = *btab;
2269 j++;
2270 temp = 0;
2271 while(j >= 0)
2272 {
2273 high = 0;
2274 while(*btab == mid)
2275 {
2276 j--;
2277 high++;
2278 if(j == 0)
2279 {
2280 *btab = 0;
2281 j--;
2282 break;
2283 }
2284 btab--;
2285 }
2286 temp = temp+high;
2287 for(i = *btab;i < mid;i++)
2288 {
2289 cond++;
2290 *bs++ = temp;
2291 }
2292 mid = *btab;
2293 }
2294 *bs = 0;
2295 temp = mx - 1;
2296 bs--;
2297 for(i = 0 ;i <= cond; i++)
2298 {
2299 (*bs) += temp;
2300 temp--;
2301 if(i != cond)
2302 bs--;
2303 }
2304 if(bs == NULL)
2305 return OK;
2306 SYM_free(af);
2307
2308 }
2309 else
2310 {
2311 liste->tab = (signed char *)SYM_MALLOC(le + 1);
2312 bs = liste->tab + le;
2313 *bs-- = 0;
2314 btab = tab + le - 1;
2315 temp = mx - 1;
2316 for(i = 1 ;i <= le; i++)
2317 {
2318 *bs = *btab + temp;
2319 temp--;
2320 if(i != le)
2321 {
2322 btab--;
2323 bs--;
2324 }
2325 }
2326 }
2327 }
2328 else
2329 {
2330 for(in = 0;in < n;in++)
2331 {
2332 /*
2333 fprintf(stderr,"\nn = %d,in = %d ",n,in);
2334 */
2335 if(condition == 1)
2336 {
2337 i = (n+1+in)%2;
2338 if(i == 0)
2339 parite = 1;
2340 else
2341 parite = -1;
2342 }
2343 else
2344 parite = 1;
2345
2346
2347 liste = (newton+in)->suivant;
2348
2349 while(liste != NULL)
2350 {
2351 baf = liste->tab;
2352 temp = np - npt;
2353 s = (signed char *)SYM_MALLOC(temp + 1);
2354 if(temp != 0)
2355 {
2356 temp--;
2357 j = 0;
2358 while(*baf != '\0')
2359 {
2360 j++;
2361 baf++;
2362 }
2363
2364 baf--;
2365 btab = s + j;
2366 *btab-- = 0;
2367 for(k = j-1;k >= 0;k--)
2368 {
2369 *btab = (*baf) - temp;
2370 if(k != 0)
2371 {
2372 btab--;
2373 baf--;
2374 temp--;
2375 }
2376 }
2377 }
2378 else
2379 *s = '\0';
2380
2381 cof = liste->coef;
2382 gvr = 0;
2383
2384 if(cond3==1)
2385 {
2386 if(booo==1) booo=0;
2387 else booo=1;
2388 }
2389 calcul(tab1,(int) n - in,s,liste1,cof,parite,n);
2390 if(cond3==1)
2391 {
2392 if(booo==1) booo=0;
2393 else booo=1;
2394 }
2395 SYM_free(s);
2396 liste = liste->suivant;
2397 }
2398 npt = npt - mx;
2399
2400 }
2401 /* End of the loop for (in = 0;in < n ;in++) */
2402
2403 }
2404 liste = liste1->suivant;
2405
2406 while(liste != NULL)
2407 {
2408 liste->coef = liste->coef/n;
2409 liste = liste->suivant;
2410 }
2411
2412 (newton+n)->suivant = liste1->suivant;
2413
2414 }
2415
2416 /* End of the loop with n*/
2417 liste = newton + 1;
2418
2419 for(in=1;in<=m;in++)
2420 {
2421 bp = liste->suivant;
2422 k = in * mx;
2423
2424 /*We read the Schur functions which are expressions of Sin(Sp),
2425 to express them by their diagonal indices*/
2426
2427 while(bp != NULL)
2428 {
2429 btab = bp->tab;
2430 j = -1;
2431 while(*btab != '\0')
2432 {
2433 btab++;
2434 j++;
2435 }
2436 btab--;
2437 temp = k-1;
2438
2439 for(i = j;i > 0;i--)
2440 {
2441 (*btab--) -= temp;
2442 temp--;
2443 }
2444 *btab -=temp;
2445
2446
2447 af=(signed char *)SYM_MALLOC(j+2);
2448 baf=af;
2449 btab=bp->tab+j;
2450 for(i=0;i<j;i++)
2451 *baf++ = *btab--;
2452 *baf++ = *btab; *baf=0;
2453 SYM_free(btab);
2454 bp->tab=af;
2455 bp = bp->suivant;
2456 }
2457 liste++;
2458 }
2459 SYM_free(tab1);
2460 return OK;
2461 }
2462
2463
2464 /*
2465 Puts in c the decomposition of the plethysm
2466 \psi^a(S_b) where a and b are partitions, in the basis of Schur functions
2467 cond3==0=> retriction upon length. cond3==1=> restriction upon parts.
2468 */
2469
plth3(a,b,cond3,c)2470 static INT plth3(a,b,cond3,c) OP a,b,c; signed char cond3;
2471 {
2472 OP sc,d,pol,ve,cf;
2473 signed char *inner,*outer,*sch;
2474 signed char tp,la,lb,inv,tmp,j;
2475 struct liste *dep,str,*bp;
2476 register signed char i,*bs;
2477
2478
2479 if(S_O_K(a)!=INTEGER && S_O_K(a)!=PARTITION)
2480 return error("plth3: wrong first type");
2481 if(S_O_K(b)!=INTEGER && S_O_K(b)!=PARTITION)
2482 return error("plth3: wrong second type");
2483
2484 if(S_O_K(b)==INTEGER)
2485 {
2486 if(S_I_I(b)<0L)
2487 {
2488 init(SCHUR,c);return OK;
2489 }
2490 if(S_I_I(b)==0L)
2491 {
2492 freeself(c);M_I_I(1L,c);return OK;
2493 }
2494 sc=callocobject();
2495 m_il_v(1L,sc);
2496 M_I_I(S_I_I(b),S_V_I(sc,0L));
2497 freeself(b);b_ks_pa(VECTOR,sc,b);
2498 }
2499
2500 if(S_O_K(a)==INTEGER)
2501 {
2502 if(S_I_I(a)<0L)
2503 {
2504 init(SCHUR,c);return OK;
2505 }
2506 if(S_I_I(a)==0L)
2507 {
2508 freeself(c);M_I_I(1L,c);return OK;
2509 }
2510 sc=callocobject();
2511 M_I_I(0L,sc);
2512 plth1(sc,a,b,cond3,c);
2513 freeall(sc); return OK;
2514 }
2515
2516 if(S_PA_LI(a)==0L || S_PA_LI(b)==0L)
2517 {
2518 freeself(c); M_I_I(1L,c); return OK;
2519 }
2520 if(S_PA_LI(a)==1L)
2521 {
2522 sc=callocobject();
2523 M_I_I(0L,sc);
2524 plth1(sc,S_PA_I(a,0L),b,cond3,c);
2525 freeall(sc); return OK;
2526 }
2527
2528 lb= (signed char)S_PA_LI(b);
2529 if((cond3==1 && S_PA_II(b,(INT)lb-1L)>lng )||(cond3==0 && lb>lng))
2530 {
2531 init(SCHUR,c); return OK;
2532 }
2533
2534 bs=(signed char *)SYM_MALLOC(lb+1);
2535 inner=bs; tp=0;
2536 for(i=0;i<lb;i++,bs++)
2537 tp += *bs= S_PA_II(b,(INT)i);
2538
2539 *bs-- =0; inv=1;
2540 if(lb>= *bs)
2541 {
2542 lb--;inv=0;
2543 plet_conj(&inner, &lb);
2544 }
2545
2546 la=(signed char ) S_PA_LI(a);
2547 bs=(signed char *)SYM_MALLOC(la+1);
2548 outer=bs; tmp=0;
2549 for(i=0;i<la;i++,bs++)
2550 tmp += *bs= S_PA_II(a,(INT)i);
2551 *bs =0;
2552
2553 tmp *= tp;
2554 /* gcc: comparison is always 0 due to limited range of data type
2555 if(tmp > 127)
2556 return error("plth3: plethysm too big");
2557 */
2558
2559 if(cond3==0) booo=inv;
2560 else if(inv==1) booo=0;
2561 else booo=1;
2562
2563 dep= &str;
2564 str.suivant=NULL;
2565 sch=(signed char *)SYM_calloc(1,1);
2566 calculi(sch,inner,outer,dep);
2567 tmp--;
2568
2569 bp=dep->suivant;
2570
2571 init(SCHUR,c);d=c;
2572 while(bp!=NULL)
2573 {
2574 bs=bp->tab;
2575 j= -1;
2576 while(*bs){ bs++;j++;}
2577 bs--;
2578 tp=tmp;
2579 for(i=j;i>=0;i--)
2580 {
2581 (*bs--) -=tp;
2582 tp--;
2583 }
2584
2585 /*ALLOCATION OF A NEW MEMORY FOR THE VECTOR ve AND THE SCHUR FUNCTION sc.
2586 THE RESULT c */
2587
2588 sc = callocobject();
2589 ve = callocobject();
2590 pol=callocobject();
2591 init(VECTOR,ve);
2592 if(inv == 1)
2593 {
2594 conjug( bp->tab , j , ve);
2595 }
2596 else
2597 {
2598 bs = bp->tab;
2599 m_il_v( (INT)(j+1), ve );
2600 for(i = 0; i<=j ;i++)
2601 {
2602 M_I_I( (INT)(*bs), S_V_I(ve, (INT) i));
2603 bs++;
2604 }
2605 }
2606 SYM_free(bp->tab);
2607 b_ks_pa(VECTOR,ve,sc);
2608 cf=callocobject(); M_I_I(bp->coef,cf);
2609 b_skn_s(sc,cf,NULL,pol);
2610 c_l_n(d,pol);d=pol;
2611
2612 dep = bp;
2613 bp = bp->suivant;
2614 SYM_free((signed char *)dep);
2615 }
2616 if(S_L_N(c)!=NULL)
2617 {
2618 /*CC 24/01/97*/
2619 d=S_L_N(c);
2620 c_l_s(c,S_L_S(S_L_N(c)));
2621 c_l_n(c,S_L_N(S_L_N(c)));
2622 c_l_n(d,NULL);
2623 c_l_s(d,NULL);
2624 freeall(d);
2625 }
2626 SYM_free(outer); SYM_free(inner);
2627 return OK;
2628 }
2629
2630
2631 /*
2632 Puts in c the decomposition of the product
2633 S_os * \psi^a(S_b) where a and b are partitions, in the basis of Schur functions
2634 cond3==0=> retriction upon length. cond3==1=> restriction upon parts.
2635 */
2636
plth5(os,a,b,cond3,c)2637 static INT plth5(os,a,b,cond3,c) OP os,a,b,c; signed char cond3;
2638 {
2639 OP sc,d,pol,ve,cf;
2640 signed char *inner,*outer,*sch;
2641 signed char tp,la,lb,inv,tmp,j,los,pdos;
2642 struct liste *dep,str,*bp;
2643 register signed char i,*bs;
2644
2645
2646 if(S_O_K(a)!=INTEGER && S_O_K(a)!=PARTITION)
2647 return error("plth5: wrong second type");
2648 if(S_O_K(b)!=INTEGER && S_O_K(b)!=PARTITION)
2649 return error("plth5: wrong third type");
2650 if(S_O_K(os)!=INTEGER && S_O_K(os)!=PARTITION)
2651 return error("plth5: wrong first type");
2652
2653 if(lng<0){init(SCHUR,c); return OK;}
2654
2655 if(S_O_K(os)==INTEGER)
2656 {
2657 if(S_I_I(os) <0L)
2658 {
2659 init(SCHUR,os); return OK;
2660 }
2661 else
2662 {
2663 sc=callocobject();
2664 if(S_I_I(os) == 0L) m_il_v(0L,sc);
2665 else
2666 {
2667 m_il_v(1L,sc);
2668 M_I_I(S_I_I(os),S_V_I(sc,0L));
2669 }
2670 freeself(os); b_ks_pa(VECTOR,sc,os);
2671
2672 }
2673 }
2674
2675 if(cond3==0 && S_PA_LI(os) > lng)
2676 {
2677 init(SCHUR,c);return OK;
2678 }
2679
2680 if(S_PA_LI(os) > 0 && (cond3==1 && S_PA_II(os,S_PA_LI(os)-1L)>lng))
2681 {
2682 init(SCHUR,c);return OK;
2683 }
2684
2685 if(S_O_K(b)==INTEGER)
2686 {
2687 if(S_I_I(b)<0L)
2688 {
2689 init(SCHUR,c);return OK;
2690 }
2691 if(S_I_I(b)==0L)
2692 {
2693 freeself(c);m_skn_s(os,cons_eins,NULL,c);return OK;
2694 }
2695 sc=callocobject();
2696 m_il_v(1L,sc);
2697 M_I_I(S_I_I(b),S_V_I(sc,0L));
2698 freeself(b);b_ks_pa(VECTOR,sc,b);
2699 }
2700
2701 if(S_O_K(a)==INTEGER)
2702 {
2703 if(S_I_I(a)<0L)
2704 {
2705 init(SCHUR,c);return OK;
2706 }
2707 if(S_I_I(a)==0L)
2708 {
2709 freeself(c);m_skn_s(os,cons_eins,NULL,c);return OK;
2710 }
2711 plth1(os,a,b,cond3,c);
2712 return OK;
2713 }
2714
2715 if(S_PA_LI(a)==0L || S_PA_LI(b)==0L)
2716 {
2717 freeself(c);m_skn_s(os,cons_eins,NULL,c); return OK;
2718 }
2719 if(S_PA_LI(a)==1L)
2720 {
2721 plth1(os,S_PA_I(a,0L),b,cond3,c);
2722 return OK;
2723 }
2724
2725 lb= (signed char)S_PA_LI(b);
2726 if((cond3==1 && S_PA_II(b,(INT)lb-1L)>lng )||(cond3==0 && lb>lng))
2727 {
2728 init(SCHUR,c); return OK;
2729 }
2730
2731 los=S_PA_LI(os);
2732 bs=(signed char *)SYM_MALLOC(los+1);
2733 sch=bs; pdos=0;
2734 for(i=0;i<los;i++,bs++)
2735 {
2736 *bs= S_PA_II(os,i);
2737 pdos+= *bs;
2738 }
2739 *bs=0;
2740
2741 bs=(signed char *)SYM_MALLOC(lb+1);
2742 inner=bs; tp=0;
2743 for(i=0;i<lb;i++,bs++)
2744 tp += *bs= S_PA_II(b,(INT)i);
2745
2746 *bs-- =0;
2747 if(lb>= *bs)
2748 {
2749 lb--;inv=0;
2750 plet_conj(&inner, &lb);
2751 }
2752 else
2753 {
2754 inv=1;
2755 if(*sch!=0)
2756 {
2757 los--; plet_conj(&sch,&los);
2758 }
2759 }
2760
2761 la=(signed char ) S_PA_LI(a);
2762 bs=(signed char *)SYM_MALLOC(la+1);
2763 outer=bs; tmp=0;
2764 for(i=0;i<la;i++,bs++)
2765 tmp += *bs= S_PA_II(a,(INT)i);
2766 *bs =0;
2767
2768 tmp = tmp*tp+pdos;
2769
2770 /* gcc: comparison is always 0 due to limited range of data type
2771 if(tmp > 127)
2772 return error("plth3: plethysm too big");
2773 */
2774 if(cond3==0) booo=inv;
2775 else if(inv==1) booo=0;
2776 else booo=1;
2777
2778 dep= &str;
2779 str.suivant=NULL;
2780 calculi(sch,inner,outer,dep);
2781 tmp--;
2782
2783 bp=dep->suivant;
2784
2785 init(SCHUR,c);d=c;
2786 while(bp!=NULL)
2787 {
2788 bs=bp->tab;
2789 j= -1;
2790 while(*bs){ bs++;j++;}
2791 bs--;
2792 tp=tmp;
2793 for(i=j;i>=0;i--)
2794 {
2795 (*bs--) -=tp;
2796 tp--;
2797 }
2798
2799 /*ALLOCATION OF A NEW MEMORY FOR THE VECTOR ve AND THE SCHUR FUNCTION sc.
2800 THE RESULT c */
2801
2802 sc = callocobject();
2803 ve = callocobject();
2804 pol=callocobject();
2805 init(VECTOR,ve);
2806 if(inv == 1)
2807 {
2808 conjug( bp->tab , j , ve);
2809 }
2810 else
2811 {
2812 bs = bp->tab;
2813 m_il_v( (INT)(j+1), ve );
2814 for(i = 0; i<=j ;i++)
2815 {
2816 M_I_I( (INT)(*bs), S_V_I(ve, (INT) i));
2817 bs++;
2818 }
2819 }
2820 SYM_free(bp->tab);
2821 b_ks_pa(VECTOR,ve,sc);
2822 cf=callocobject(); M_I_I(bp->coef,cf);
2823 b_skn_s(sc,cf,NULL,pol);
2824 c_l_n(d,pol);d=pol;
2825
2826 dep = bp;
2827 bp = bp->suivant;
2828 SYM_free((signed char *)dep);
2829 }
2830 if(S_L_N(c)!=NULL)
2831 {
2832 /*CC 24/01/97*/
2833 d=S_L_N(c);
2834 c_l_s(c,S_L_S(S_L_N(c)));
2835 c_l_n(c,S_L_N(S_L_N(c)));
2836 c_l_n(d,NULL);
2837 c_l_s(d,NULL);
2838 freeall(d);
2839 }
2840 SYM_free(outer); SYM_free(inner); /*Ne pas liberer sch: ca a ete fait dans calculi*/
2841 return OK;
2842 }
2843
2844
conjugate_apply_schur(a)2845 static INT conjugate_apply_schur(a) OP a;
2846 /* afterwards a is no longer ordered */
2847 {
2848 OP tmp,z;
2849 if(S_O_K(a)==SCHUR)
2850 {
2851 if(not nullp(a))
2852 {
2853 z=a;
2854 while(z!=NULL)
2855 {
2856 tmp=callocobject();
2857
2858 conjugate_partition(S_S_S(z),tmp);
2859 copy(tmp,S_S_S(z));
2860
2861 freeall(tmp);
2862 z=S_L_N(z);
2863 }
2864 }
2865 }
2866 return OK;
2867 }
2868
2869
2870 /*
2871 Puts in c the decomposition of the plethysm
2872 S_a(S_b) where a and b are partitions, in the basis of Schur functions
2873 cond3==0=> retriction upon length. cond3==1=> restriction upon parts.
2874 */
2875
cc_plet_pss_integer_partition(a,b,c,f)2876 INT cc_plet_pss_integer_partition(a,b,c,f) OP a,b,c,f;
2877 /* to call from pss_integer_partition */
2878 {
2879 INT erg = OK;
2880 OP d;
2881 CTO(INTEGER,"cc_plet_pss_integer_partition_(1)",a);
2882 CTO(PARTITION,"cc_plet_pss_integer_partition_(2)",b);
2883 CTTO(SCHUR,HASHTABLE,"cc_plet_pss_integer_partition_(3)",c);
2884
2885 if (S_PA_LI(b) == 0) {
2886 OP m;
2887 m = CALLOCOBJECT();
2888 b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m);
2889 COPY(f,S_MO_K(m));
2890 COPY(b,S_MO_S(m));
2891 if (S_O_K(c) == SCHUR)
2892 insert_list(m,c,add_koeff,comp_monomschur);
2893 else
2894 insert_scalar_hashtable(m,c,add_koeff,eq_monomsymfunc,hash_monompartition);
2895 goto ende;
2896 }
2897
2898 d = CALLOCOBJECT();
2899 erg += schur_schur_plet(a,b,d);
2900 CTO(SCHUR,"cc_plet_pss_integer_partition(i1)",d);
2901 MULT_APPLY(f,d);
2902 if (S_O_K(c) == SCHUR)
2903 insert_list_list(d,c,add_koeff,comp_monomschur);
2904 else
2905 insert_schur_hashtable(d,c,add_koeff,eq_monomsymfunc,hash_monompartition);
2906
2907 ende:
2908 ENDR("cc_plet_pss_integer_partition");
2909 }
cc_plet_phs_integer_partition(a,b,c,f)2910 INT cc_plet_phs_integer_partition(a,b,c,f) OP a,b,c,f;
2911 /* to call from phs_integer_partition */
2912 /* AK 2002 */
2913 /* AK 210704 V3.0 */
2914 {
2915 INT erg = OK;
2916 CTO(INTEGER,"cc_plet_phs_integer_partition_(1)",a);
2917 CTO(PARTITION,"cc_plet_phs_integer_partition_(2)",b);
2918 CTTO(SCHUR,HASHTABLE,"cc_plet_phs_integer_partition_(3)",c);
2919
2920 {
2921 OP d;
2922 d = CALLOCOBJECT();
2923 erg += complete_schur_plet(a,b,d);
2924 CTO(SCHUR,"cc_plet_phs_integer_partition(i1)",d);
2925 MULT_APPLY(f,d);
2926 if (S_O_K(c) == SCHUR)
2927 insert_list_list(d,c,add_koeff,comp_monomschur);
2928 else
2929 insert_schur_hashtable(d,c,add_koeff,eq_monomsymfunc,hash_monompartition);
2930 }
2931
2932 ENDR("cc_plet_phs_integer_partition");
2933 }
cc_plet_pes_integer_partition(a,b,c,f)2934 INT cc_plet_pes_integer_partition(a,b,c,f) OP a,b,c,f;
2935 /* to call from pes_integer_partition */
2936 {
2937 INT erg = OK;
2938 OP d;
2939 CTO(INTEGER,"cc_plet_pes_integer_partition_(1)",a);
2940 CTO(PARTITION,"cc_plet_pes_integer_partition_(2)",b);
2941 CTTO(SCHUR,HASHTABLE,"cc_plet_pes_integer_partition_(3)",c);
2942
2943 d = CALLOCOBJECT();
2944 erg += elementary_schur_plet(a,b,d);
2945 CTO(SCHUR,"cc_plet_phs_integer_partition(i1)",d);
2946 MULT_APPLY(f,d);
2947 if (S_O_K(c) == SCHUR)
2948 insert_list_list(d,c,add_koeff,comp_monomschur);
2949 else
2950 insert_schur_hashtable(d,c,add_koeff,eq_monomsymfunc,hash_monompartition);
2951
2952 ENDR("cc_plet_pes_integer_partition");
2953 }
2954
2955
2956
cc_plet_pss_partition_partition(a,b,c,f)2957 INT cc_plet_pss_partition_partition(a,b,c,f) OP a,b,c,f;
2958 /* to call from pss_partition_partition */
2959 {
2960 INT erg = OK;
2961 OP d;
2962 CTO(PARTITION,"cc_plet_pss_partition_partition_(1)",a);
2963 CTO(PARTITION,"cc_plet_pss_partition_partition_(2)",b);
2964 CTTO(SCHUR,HASHTABLE,"cc_plet_pss_partition_partition_(3)",c);
2965
2966 d = CALLOCOBJECT();
2967 erg += schur_schur_plet(a,b,d);
2968 CTO(SCHUR,"cc_plet_pss_integer_partition(i1)",d);
2969 MULT_APPLY(f,d);
2970 if (S_O_K(c) == SCHUR)
2971 insert_list_list(d,c,add_koeff,comp_monomschur);
2972 else
2973 insert_schur_hashtable(d,c,add_koeff,eq_monomsymfunc,hash_monompartition);
2974
2975 ENDR("cc_plet_pss_partition_partition");
2976 }
2977
2978
2979 /*
2980 Puts in c the decomposition of the plethysm
2981 S_a(S_b) where a and b are partitions, in the basis of Schur functions
2982 cond3==0=> retriction upon length. cond3==1=> restriction upon parts.
2983 */
plth4(a,b,cond3,c)2984 static INT plth4(a,b,cond3,c) OP a,b,c; signed char cond3;
2985 {
2986 OP sc;
2987 signed char *inner;
2988 signed char tp,lb,inv,tmp;
2989 register signed char i,*bs;
2990
2991
2992 if(S_O_K(a)!=INTEGER && S_O_K(a)!=PARTITION)
2993 return error("plth4: wrong first type");
2994 if(S_O_K(b)!=INTEGER && S_O_K(b)!=PARTITION)
2995 return error("plth4: wrong second type");
2996
2997 if(S_O_K(b)==INTEGER)
2998 {
2999 if(S_I_I(b)<0L) { init(SCHUR,c);return OK; }
3000 if(S_I_I(b)==0L) { freeself(c);M_I_I(1L,c);return OK; }
3001 sc=callocobject();
3002 m_il_v(1L,sc);
3003 M_I_I(S_I_I(b),S_V_I(sc,0L));
3004 freeself(b);b_ks_pa(VECTOR,sc,b);
3005 }
3006
3007 if(S_O_K(a)==INTEGER)
3008 {
3009 if(S_I_I(a)<0L) { init(SCHUR,c);return OK; }
3010 if(S_I_I(a)==0L) { freeself(c);M_I_I(1L,c);return OK; }
3011 sc=callocobject();
3012 m_il_v(1L,sc);
3013 M_I_I(S_I_I(a),S_V_I(sc,0L));
3014 freeself(a);b_ks_pa(VECTOR,sc,a);
3015 }
3016
3017 if(S_PA_LI(a)==0L || S_PA_LI(b)==0L) { freeself(c); M_I_I(1L,c); return OK; }
3018
3019 lb= (signed char)S_PA_LI(b);
3020 if((cond3==1 && S_PA_II(b,(INT)lb-1L)>lng )||(cond3==0 && lb>lng))
3021 {
3022 init(SCHUR,c); return OK;
3023 }
3024
3025 bs=(signed char *)SYM_MALLOC(lb+1);
3026 inner=bs; tp=0;
3027 for(i=0;i<lb;i++,bs++)
3028 tp += *bs= S_PA_II(b,(INT)i);
3029
3030 *bs-- =0; inv=1;
3031 if(lb>= *bs)
3032 {
3033 lb--;inv=0;
3034 plet_conj(&inner, &lb);
3035 }
3036
3037 sc=callocobject();
3038 weight(a,sc);
3039
3040 tmp = tp*(char)S_I_I(sc);
3041 freeall(sc);
3042 /* gcc: comparison is always 0 due to limited range of data type
3043 if(tmp > 127)
3044 return error("plth4: plethysm too big");
3045 */
3046
3047 if(cond3==0) booo=inv;
3048 else if(inv==1) booo=0;
3049 else booo=1;
3050
3051 init(SCHUR,c);
3052 calcula(inner,tmp-1,a,c);
3053 if(inv==1) conjugate_apply_schur(c);
3054 SYM_free(inner);
3055 return OK;
3056 }
3057
3058
3059
3060 /*
3061 Insert a Schur function in a sorted list,
3062 the partition being read from the right.
3063 Partition begins at *af
3064 */
3065 /*
3066 NOT TESTED
3067 */
3068 #ifdef UNDEF
3069
ins_s_lst(af,coef,plst)3070 static INT ins_s_lst(af,coef,plst)
3071 signed char *af;
3072 INT coef;
3073 struct liste **plst;
3074 {
3075 register struct liste *bp,*bpp;
3076 struct liste *bc;
3077 signed char *db;
3078 register signed char *baf,*btab;
3079
3080 bpp= *plst;
3081 bp=bpp->suivant;
3082 baf=af; while(*baf) baf++;
3083 db = --baf;
3084 while(bp!=NULL)
3085 {
3086 baf=db;
3087 btab=bp->tab;
3088 while(*btab) btab++;
3089 btab--;
3090 for(;;)
3091 {
3092 if(*baf < *btab)
3093 goto out1;
3094 if(*baf > *btab)
3095 goto out2;
3096 if(baf==af) goto out3;
3097 baf--; btab--;
3098 }
3099 out1:
3100 bpp=bp;
3101 bp=bp->suivant;
3102 }
3103
3104 /*
3105 On sort avec bp==NULL ou avant un plus grand element dans la liste
3106 */
3107 out2:
3108 bc=(struct liste *)SYM_MALLOC(sizeof(struct liste));
3109 bc->coef=coef;
3110 bc->suivant=bp;
3111 btab=(signed char *)SYM_MALLOC(db+2);
3112 baf=af;
3113 bc->tab=btab;
3114 while(*baf)
3115 *btab++ = *baf++;
3116 *btab=0;
3117 bpp->suivant=bc;
3118 *plst=bpp;
3119 return OK;
3120
3121 /*
3122 l'element existe deja dans la liste
3123 */
3124 out3:
3125 if(coef== -bp->coef)
3126 {
3127 bpp->suivant=bp->suivant;
3128 SYM_free(bp->tab);
3129 SYM_free((char *)bp);
3130 }
3131 else
3132 bp->coef +=coef;
3133 *plst=bpp;
3134 return OK;
3135 }
3136
3137 #endif
3138
3139 /*
3140 list2 est le shuffle des 2 listes triees
3141 a partir de la fin sig*lst1 et lst2
3142 sig*lst1 signifie que le champ coef de toutes les cellules est
3143 multiplie par sig
3144 */
3145
3146 /*
3147 static INT shuffle_sg(lst1,sig,lst2)
3148 register struct liste *lst1;
3149 struct liste *lst2;
3150 signed char sig;
3151 {
3152 lst1=lst1->suivant;
3153 while(lst1!= NULL)
3154 {
3155 ins_s_lst(lst1->tab,lst1->coef*sig,&lst2);
3156 lst1=lst1->suivant;
3157 }
3158 return OK;
3159 }
3160 */
3161
3162
3163 /*
3164 insert a Schur function in a sorted list
3165 Partition begins at *af
3166 */
3167
ins_sc_lst(af,coef,plst)3168 static INT ins_sc_lst(af,coef,plst)
3169 signed char *af;
3170 INT coef;
3171 struct liste **plst;
3172 {
3173 register struct liste *bp,*bpp;
3174 struct liste *bc;
3175 register signed char *baf,*btab;
3176
3177 bpp= *plst;
3178 bp=bpp->suivant;
3179 while(bp!=NULL)
3180 {
3181 baf=af;
3182 btab=bp->tab;
3183 while(*baf!=0)
3184 {
3185 if(*baf < *btab)
3186 goto out1;
3187 if(*baf > *btab)
3188 goto out2;
3189 baf++;btab++;
3190 }
3191 goto out3;
3192 out1:
3193 bpp=bp;
3194 bp=bp->suivant;
3195 }
3196
3197 /*
3198 On sort avec bp==NULL ou avant un plus grand element dans la liste
3199 */
3200 out2:
3201 bc=(struct liste *)SYM_MALLOC(sizeof(struct liste));
3202 bc->coef=coef;
3203 bc->suivant=bp;
3204 baf=af;
3205 while(*baf++);
3206 btab=(signed char *)SYM_MALLOC(baf-af+1);
3207 baf=af;
3208 bc->tab=btab;
3209 while(*baf)
3210 *btab++ = *baf++;
3211 *btab=0;
3212 bpp->suivant=bc;
3213 *plst=bpp;
3214 return OK;
3215
3216 /*
3217 l'element existe deja dans la liste
3218 */
3219 out3:
3220 if(coef== -bp->coef)
3221 {
3222 bpp->suivant=bp->suivant;
3223 SYM_free(bp->tab);
3224 SYM_free((char *)bp);
3225 }
3226 else
3227 bp->coef +=coef;
3228 *plst=bpp;
3229 return OK;
3230 }
3231
3232 /*
3233 list2 est le shuffle des 2 listes triees sig*lst1 et lst2
3234 sig*lst1 signifie que le champ coef de toutes les cellules est
3235 multiplie par sig
3236 */
3237
shuffle_sig(lst1,sig,lst2)3238 static INT shuffle_sig(lst1,sig,lst2)
3239 register struct liste *lst1;
3240 struct liste *lst2;
3241 signed char sig;
3242 {
3243 lst1=lst1->suivant;
3244 while(lst1!= NULL)
3245 {
3246 ins_sc_lst(lst1->tab,lst1->coef*sig,&lst2);
3247 lst1=lst1->suivant;
3248 }
3249 return OK;
3250 }
3251
3252 /*
3253 frees a list
3254 */
3255
free_lst(lst)3256 static INT free_lst (lst)
3257 register struct liste *lst;
3258 {
3259 struct liste *lst1,*bp;
3260 lst1=lst;
3261 lst=lst->suivant;
3262 while(lst!=NULL)
3263 {
3264 SYM_free(lst->tab);
3265 bp=lst;
3266 lst=lst->suivant;
3267 SYM_free((signed char *)bp);
3268 }
3269 lst1->suivant=NULL;
3270 return OK;
3271 }
3272
3273 /*
3274 frees a tableau of struct liste tiil the rank n
3275 */
3276 /* CC 24/01/97 */
3277
free_newton(newton,n)3278 static INT free_newton(newton, n)
3279 struct liste *newton; int n;
3280 {
3281 for(; n>=0; n--)
3282 {
3283 free_lst(newton);
3284 newton++;
3285 }
3286 return OK;
3287 }
3288
3289
3290 /*
3291 returns the weight of partitions of a list
3292 */
poids(lst)3293 static INT poids (lst)
3294 struct liste *lst;
3295 {
3296 register signed char *btab;
3297 register signed char tmp=0;
3298
3299 lst=lst->suivant;
3300 if(lst!=NULL)
3301 {
3302 btab=lst->tab;
3303 while(*btab)
3304 {
3305 tmp+= *btab;
3306 btab++;
3307 }
3308 }
3309 return((INT)tmp);
3310 }
3311
3312 /*
3313 insere une fonction de Schur dans une liste
3314 *af est la taille de la partition
3315 */
3316
ins_sch_lst(af,coef,plst)3317 static INT ins_sch_lst(af,coef,plst)
3318 signed char *af;
3319 INT coef;
3320 struct liste **plst;
3321 {
3322 register struct liste *bp,*bpp;
3323 struct liste *bc;
3324 register signed char *baf,*btab;
3325
3326 bpp= *plst;
3327 bp=bpp->suivant;
3328 while(bp!=NULL)
3329 {
3330 baf=af+1;
3331 btab=bp->tab;
3332 while(*baf!=0)
3333 {
3334 if(*baf < *btab)
3335 goto out1;
3336 if(*baf > *btab)
3337 goto out2;
3338 baf++;btab++;
3339 }
3340 goto out3;
3341 out1:
3342 bpp=bp;
3343 bp=bp->suivant;
3344 }
3345
3346 /*
3347 On sort avec bp==NULL ou avant un plus grand element dans la liste
3348 */
3349 out2:
3350 bc=(struct liste *)SYM_MALLOC(sizeof(struct liste));
3351 bc->coef=coef;
3352 bc->suivant=bp;
3353 baf=af;
3354 btab=(signed char *)SYM_MALLOC(*baf+1);
3355 baf++;
3356 bc->tab=btab;
3357 while(*baf)
3358 *btab++ = *baf++;
3359 *btab=0;
3360 bpp->suivant=bc;
3361 *plst=bpp;
3362 return OK;
3363
3364 /*
3365 l'element existe deja dans la liste
3366 */
3367 out3:
3368 if(coef== -bp->coef)
3369 {
3370 bpp->suivant=bp->suivant;
3371 SYM_free(bp->tab);
3372 SYM_free((signed char *)bp);
3373 }
3374 else
3375 bp->coef +=coef;
3376 *plst=bpp;
3377 return OK;
3378 }
3379
3380
3381 /*
3382 met dans lst le produit de S_fi par S_ev
3383 produit restreint aux partitions dont les parts sont <= mx
3384 lst est une liste a entete et peut ne pas etre vide (lst->suivant!= NULL)
3385 retourne l'adresse de la
3386 cellule precedent la premiere cellule de la liste qui a ete modifie
3387 va plus vite si le poids de fi est superieur que le poids de ev
3388 Algo sophistique
3389 */
3390
proprt(fi,ev,coef1,coef2,mx,lst)3391 static struct liste * proprt(fi,ev,coef1,coef2,mx,lst)
3392 signed char *fi,*ev,mx;
3393 INT coef1,coef2;
3394 struct liste *lst;
3395 {
3396 INT cmt;
3397 INT coef;
3398 signed char etat,ssetat=0,bas=0,ev_niv,ym;
3399 signed char nb_lt,lg_fi,lg_tb,lg_tb_dct,lg_old;
3400 signed char i,j=0,k,tmp,tp,dsp,topc,topd,pds,av,fr=0;
3401 register signed char niv;
3402 signed char sz_pcar,sz_plst,sz_lst;
3403 signed char **tb,**nb_tb,**ctb,**dtb,**etb,**ftb,**gtb,**htb;
3404 register signed char **btb,**bnb_tb,**byam;
3405 signed char **yam;
3406 signed char *af,*bfi,*bev,*pos,*bpos;
3407 register signed char *baf;
3408 struct liste **pl,**bpl,*bpc,*lst1;
3409
3410 cmt=1L;
3411
3412 /*
3413 Faire un test si il y a des termes ou pas
3414 */
3415 if((*fi > mx)|| (*ev > mx)) return lst;
3416 /*
3417 nb_lt nombre de lettres
3418 lg_fi longueur de la forme interieure
3419 */
3420 baf=ev;
3421 nb_lt= 0;
3422 while(*baf++) nb_lt++;
3423 baf=fi;
3424 lg_fi= 0;
3425 while(*baf++) lg_fi++;
3426 /*
3427
3428 lg_fi=*fi;nb_lt=*ev;
3429 */
3430 sz_pcar= sizeof(signed char *); /* Dimension d'un pointeur sur caractere*/
3431 sz_plst= sizeof(struct liste *); /*Dimension de pointeur sur structure liste*/
3432 sz_lst= sizeof(struct liste); /* Dimension sur structure liste*/
3433 lg_tb= lg_fi+nb_lt; /* Longueur maximum des tableaux resultat*/
3434
3435 /*
3436 Creation de 3 tableaux bidimensionnels avec pour nombre de lignes lg_tb
3437 */
3438
3439 tb=(signed char **)SYM_MALLOC((lg_tb+4)*sz_pcar);
3440 nb_tb=(signed char **)SYM_MALLOC((lg_tb+4)*sz_pcar);
3441 yam=(signed char **)SYM_MALLOC((lg_tb+4)*sz_pcar);
3442 btb=tb;
3443 bnb_tb=nb_tb;byam=yam;
3444 for(i=0;i<=lg_tb+2;i++)
3445 {
3446 *btb++ =(signed char *)SYM_calloc(nb_lt+3,1);
3447 *bnb_tb++ =(signed char *)SYM_calloc(nb_lt+3,1);
3448 *byam++ =(signed char *)SYM_calloc(nb_lt+3,1);
3449 }
3450 *btb=NULL;*bnb_tb =NULL;*byam=NULL;
3451
3452 /*
3453 Construction d'un tableau de taille lg_tb+3
3454 */
3455
3456 af=(signed char *)SYM_calloc(lg_tb+3,1);
3457
3458 /*
3459 Creation d'un tableau de dimension nb_lt + 2
3460 ou on met les sommes cumulees du vecteur d'evaluation
3461 pds: poids de la partition composee des parts de la partition
3462 */
3463
3464 pos=(signed char *)SYM_MALLOC(nb_lt+2);
3465 bpos=pos;
3466 *bpos++ =0; bev=ev;av=0;
3467 for(i=1;i<=nb_lt;i++)
3468 {
3469 *bpos = av+ *bev;
3470 av= *bpos;
3471 bev++;bpos++;
3472 }
3473 pds= *--bpos;
3474
3475
3476 /*
3477 Creation d'un tableau de pointeurs sur struct liste de dimension
3478 pds pour l'insertion d'un tableau dans la liste des tableaux
3479 */
3480
3481 pl=(struct liste **)SYM_MALLOC((pds+2)*sz_plst);
3482
3483
3484 /*
3485 Initialisation de tb selon fi
3486 */
3487 **tb=mx;
3488 btb=tb+1;
3489 bfi=fi;
3490 for(i=1;i<=lg_fi;i++)
3491 {
3492 tmp= *bfi;
3493 bpos= *btb;
3494 for(j=0;j<=nb_lt+1;j++)
3495 {
3496 *bpos++ = tmp;
3497 }
3498 bfi++;btb++;
3499 }
3500
3501 /* Remplissage des tableaux */
3502
3503 btb=tb; bev=ev;
3504 bnb_tb=nb_tb+1;
3505 byam=yam+1;
3506 dsp = *bev;
3507 ctb=btb; dtb= btb+1;
3508 etb= bnb_tb;
3509 while(dsp!= 0)
3510 {
3511 topc= **ctb;
3512 topd= **dtb;
3513 tmp= topc-topd;
3514 if(tmp>=dsp)
3515 {
3516 /*
3517 dsp etant different de 0, tmp est > 0
3518 */
3519 *(*byam+1)=99;
3520 *(*etb+1)=dsp;
3521 tmp= **dtb+dsp;
3522 bpos = *dtb+1;
3523 for(j=1;j<=nb_lt+1;j++)
3524 *bpos++ = tmp;
3525 break;
3526 }
3527 *(*byam+1)=99;
3528 *(*etb+1)=tmp;
3529 dsp -= tmp;
3530 tmp= **dtb+tmp;
3531 bpos= *dtb+1;
3532 for(j=1;j<=nb_lt+1;j++)
3533 *bpos++ = tmp;
3534 ctb++;dtb++;etb++;byam++;
3535 }/* Fin du while(dsp !=0)*/
3536
3537 bev++;btb++;
3538 byam=yam+1;
3539 for(i=2;i<=nb_lt;i++)
3540 {
3541 dsp= *bev;
3542 ctb=btb; dtb=btb+1;
3543 etb= bnb_tb; ftb=bnb_tb+1;
3544 gtb=byam; htb=byam+1;
3545 k=i;
3546 while(dsp !=0)
3547 {
3548 topc= *(*ctb+i-1);
3549 topd= *(*dtb+i-1);
3550 tmp=topc-topd;
3551 ym= *(*gtb+i) + *(*etb+i-1);
3552 if(ym<tmp)
3553 tmp=ym;
3554 if(tmp>=dsp)
3555 {
3556 /*
3557 dsp etant different de 0, tmp est > 0
3558 */
3559 *(*ftb+i)=dsp;
3560 *(*htb+i)= ym - dsp;
3561 tmp= *(*dtb+i-1)+dsp;
3562 bpos= *dtb+i;
3563 for(j=i;j<=nb_lt+1;j++)
3564 *bpos++ = tmp;
3565 break;
3566 }/* if(tmp>=dsp) */
3567 *(*ftb+i)=tmp;
3568 *(*htb+i)= ym - tmp;
3569 dsp -=tmp;
3570 tmp= *(*dtb+i-1)+tmp;
3571 bpos= *dtb+i;
3572 for(j=i;j<=nb_lt+1;j++)
3573 *bpos++ = tmp;
3574 ctb++;dtb++;
3575 etb++;ftb++;
3576 gtb++;htb++;
3577 k++;
3578 }/*while(dsp != 0)*/
3579 k++;
3580 gtb++;htb++;etb++;
3581 for(;k<=lg_tb;k++)
3582 {
3583 *(*htb+i)= *(*gtb+i)+ *(*etb+i-1);
3584 htb++;gtb++;etb++;
3585 }
3586 bev++;btb++;bnb_tb++;byam++;
3587 }/*for(i=2;i<=nb_lt;i++)*/
3588
3589 baf=af+1;
3590 btb=tb+1;
3591 for(i=1;i<= lg_tb+1;i++)
3592 {
3593 tmp= *(*btb+nb_lt);
3594 *baf= tmp;
3595 if(tmp==0) break;
3596 baf++;btb++;
3597 }
3598 lg_tb_dct=i-1;
3599
3600
3601 **tb=0;
3602
3603 coef=coef1*coef2;
3604 bpl=pl+1;
3605 for(i=1;i<=pds;i++)
3606 *bpl++ =lst;
3607 *af=lg_tb_dct;
3608 ins_sch_lst(af,coef,&lst);
3609 lst1=lst;
3610
3611 /*
3612 Debut de l'algorithme
3613 */
3614 niv=nb_lt;
3615 lg_old=lg_tb_dct;
3616 etat=0;
3617
3618 while(niv>0)
3619 {
3620 switch(etat)
3621 {
3622 case 0:
3623
3624 /*
3625 Depilage: Essai de placer les lettres plus haut dans le tableau
3626 */
3627
3628 ev_niv=ev[niv-1];
3629 baf=af+lg_tb_dct;
3630 btb=tb+lg_tb_dct;
3631 bnb_tb=nb_tb+lg_tb_dct;
3632 i= ev_niv;j=lg_tb_dct;
3633 av=lg_tb_dct+1;
3634
3635 while(i>0)
3636 {
3637 /*
3638 Chaque lettre i de valeur niv est testee.
3639 */
3640 if(*(*bnb_tb+ niv)==0)
3641 {
3642 bnb_tb--;btb--;
3643 j--;baf--;
3644 }
3645 else
3646 {
3647 ctb=btb;dtb=btb+1;
3648
3649 for(k=j+1;k<=av;k++)
3650 {
3651 /* On teste ou la mettre plus haut dans le tableau tb*/
3652 topc= *(*ctb+niv-1);
3653 topd= *(*dtb+niv);
3654 if(topc>topd)
3655 {
3656 /*SUCCES: On enleve cette lettre niv de la ligne j pour la mettre
3657 plus haut dans le tableau*/
3658 etat=1;fr=niv;
3659 (*(*btb+niv))--;
3660 (*baf)--;(*(*bnb_tb+niv))--;
3661 byam=yam+j;
3662 (*(*byam+niv))++;tp= *(*byam+niv);
3663 byam++;j++;
3664 for(;j<k;j++)
3665 {
3666 tp += *(*bnb_tb+niv-1);
3667 *(*byam+niv)=tp;bnb_tb++;byam++;
3668 }
3669 /*bas est le numero de la lettre qu'on va placer*/
3670 bas=i+pos[niv-1];
3671 tmp= *(*bnb_tb+niv-1);
3672 bnb_tb++;
3673 /*
3674 La ieme lettre de valeur niv peut se placer a la ligne j. Ne pas la placer.
3675 Le placement de cette ieme lettre et de ses suivantes se fait dans le case 1
3676 */
3677 ssetat=1;btb=tb+j;baf=af+j;
3678 break;
3679 }/*if(topc>topd)*/
3680 ctb++;dtb++;
3681 }/*for(k=j+1;k<=av;k++)*/
3682 if(etat==1)break;
3683 tp= *(*bnb_tb+niv);av=j;i-=tp;
3684 bnb_tb--;btb--;j--;baf--;
3685 }/*else du if(*(*bnb_tb+niv)==0)*/
3686 }/*while(i>0)*/
3687 if(etat==1)break;
3688 if(*(*(tb+lg_tb_dct)+niv-1)==0) lg_tb_dct--;
3689 niv--;
3690 break;/*Sortie du case 0*/
3691
3692 case 1:
3693
3694 if(ssetat==0)
3695 {
3696 /*
3697 On commence a placer la premiere lettre de valeur niv
3698 */
3699 i=1;j=niv; /* premiere lettre niv*/
3700 btb=tb+j;byam=yam+j;baf=af+j;
3701 bnb_tb=nb_tb+j;
3702 }
3703 /*j est forcement > 1*/
3704 /*Essai de placer toutes les lettres niv de i a ev_niv*/
3705 ev_niv=ev[niv-1];
3706 while((j<=lg_tb_dct)||(i<=ev_niv))
3707 {
3708 topc= *(*(btb-1)+niv-1);
3709 topd= *(*btb+niv-1);
3710 tmp=topc-topd;
3711 ym= *(*(byam-1)+niv)+ *(*(bnb_tb-1)+niv-1);
3712 if((tmp>0)&&(ym>0))
3713 {
3714 if(tmp>ym)tmp=ym;
3715 dsp=ev_niv-i+1;
3716 if(tmp>dsp)tmp=dsp;
3717 *(*byam+niv) =ym-tmp;
3718 *(*bnb_tb+niv)=tmp;
3719 *(*btb+niv)=topd+tmp;
3720 *baf=topd+tmp;
3721 i+=tmp;
3722 if(j>lg_tb_dct)
3723 {
3724 lg_tb_dct++;
3725 }
3726 }
3727 else
3728 {
3729 *(*byam+niv)=ym;
3730 *(*btb+niv) =topd;
3731 *baf=topd;
3732 *(*bnb_tb+niv)=0;
3733 }
3734 btb++;bnb_tb++;byam++;baf++;j++;
3735 }
3736
3737 topd= *(*btb+niv-1);
3738 for(;j<=lg_old;j++)
3739 {
3740 *(*btb+niv)=topd;
3741 btb++;
3742 }
3743
3744 niv++;ssetat=0;
3745 break;/*Sortie de case 1*/
3746 }
3747 if(niv >nb_lt)
3748 {
3749 etat=0;
3750 if(lg_tb_dct<lg_old)
3751 {
3752 i=lg_tb_dct+1;
3753 btb=tb+i;
3754 bfi=fi+i-1;
3755 for(;i<=lg_fi;i++)
3756 {
3757 bpos= *btb+fr;
3758 for(j=fr;j<=nb_lt;j++)
3759 *bpos++ = *bfi;
3760 bfi++;btb++;
3761 }
3762 for(;i<=lg_old;i++)
3763 {
3764 bpos= *btb+fr;
3765 for(j=fr;j<=nb_lt;j++)
3766 *bpos++ = 0;
3767 btb++;
3768 }
3769 }
3770 lg_old=lg_tb_dct;
3771 *(af+lg_tb_dct+1)=0;
3772 *af=lg_tb_dct;
3773 niv--;
3774 bpc=pl[bas];
3775 ins_sch_lst(af,coef,&bpc);
3776 bpl=pl+bas;
3777 for(i=bas;i<=pds;i++)
3778 *bpl++ =bpc;
3779 bas=pds+1;cmt++;
3780 }
3781 }
3782
3783 SYM_free(af);SYM_free(pos);
3784 btb=tb;byam=yam;bnb_tb=nb_tb;
3785 for(i=0;i<lg_tb+2;i++)
3786 {
3787 SYM_free(*byam);SYM_free(*bnb_tb);SYM_free(*btb);
3788 byam++;bnb_tb++;btb++;
3789 }
3790 SYM_free(*byam);SYM_free(*bnb_tb);SYM_free(*btb);
3791 SYM_free((signed char *)tb);SYM_free((signed char *)nb_tb);SYM_free((signed char *)yam);
3792 /*CC 27/02 */
3793 SYM_free(pl);
3794 return lst1;
3795 }
3796
3797
3798 /*
3799 Produit de sommes de fonctions de Schur
3800 lst1 et lst2 sont des liste avec entete triees
3801 lst2 n'est pas vide
3802 Algo sophistique
3803 */
fct_sch_prt_srt(lst1,lst2,mx,res)3804 static INT fct_sch_prt_srt(lst1,lst2,mx,res)
3805 struct liste *lst1,*lst2,*res;
3806 signed char mx;
3807 {
3808 struct liste *bp,*bnv1,*bnv2;
3809
3810 lst1=lst1->suivant;
3811 bnv1=res;
3812 res->tab=(signed char *)SYM_calloc(2,1);*(res->tab)=99;
3813 while(lst1!=NULL)
3814 {
3815 bp=lst2->suivant;
3816 if(strcmp((char *) lst1->tab,(char *) bnv1->tab)>0)
3817 bnv1=proprt(lst1->tab,bp->tab,lst1->coef,bp->coef,mx,bnv1);
3818 else
3819 bnv1=proprt(lst1->tab,bp->tab,lst1->coef,bp->coef,mx,res);
3820 bnv2=bnv1;
3821 bp=bp->suivant;
3822 while(bp!=NULL)
3823 {
3824 if(strcmp((char *) lst1->tab,(char *) bnv2->tab)>0)
3825 bnv2=proprt(lst1->tab,bp->tab,lst1->coef,bp->coef,mx,bnv2);
3826 else
3827 bnv2=proprt(lst1->tab,bp->tab,lst1->coef,bp->coef,mx,res);
3828 bp=bp->suivant;
3829 }
3830 lst1=lst1->suivant;
3831 }
3832 return OK;
3833 }
3834
3835
3836 /*
3837 met dans lst le produit de S_fi par S_ev
3838 produit restreint aux partitions de longueur <=lg
3839 lst est une liste a entete et peut ne pas etre vide (lst->suivant!= NULL)
3840 retourne l'adresse de la
3841 cellule precedent la premiere cellule de la liste qui a ete modifie
3842 va plus vite si le poids de fi est superieur que le poids de ev
3843 */
3844
pro_lg(fi,ev,coef1,coef2,lg,lst)3845 static struct liste * pro_lg(fi,ev,coef1,coef2,lg,lst)
3846 INT coef1,coef2;
3847 signed char lg;
3848 signed char *fi,*ev;
3849 struct liste *lst;
3850 {
3851 INT cmt;
3852 INT coef;
3853 signed char etat,ssetat,bas=0,ev_niv,ym;
3854 signed char nb_lt,lg_fi,lg_tb,lg_tb_dct,lg_tb_dct0=0,lg_old;
3855 signed char i,j=0,k,tmp,tp,dsp,topc,topd,pds,av,ttp=0,fr=0,niv0=0;
3856 register signed char niv;
3857 signed char sz_pcar,sz_plst,sz_lst;
3858 signed char **tb,**nb_tb,**ctb,**dtb;
3859 signed char **yam,**bbyam;
3860 register signed char **btb,**bnb_tb,**byam;
3861 signed char *af,*bfi,*bev,*baf,*pos,*bpos;
3862 struct liste **pl,**bpl,*bpc,*lst1;
3863
3864 cmt=1L;
3865 nb_lt= 0; /* Nombre de lettres*/
3866 baf=ev;
3867 while(*baf++) nb_lt++;
3868 lg_fi= 0; /* Longueur de la forme interieure*/
3869 baf=fi;
3870 while(*baf++) lg_fi++;
3871 if((lg_fi >lg)||(nb_lt >lg))
3872 {
3873 return lst;
3874 }
3875 sz_pcar= sizeof(signed char *); /* Dimension d'un pointeur sur caractere*/
3876 sz_plst= sizeof(struct liste *); /*Dimension de pointeur sur structure liste*/
3877 sz_lst= sizeof(struct liste); /* Dimension sur structure liste*/
3878 lg_tb= lg_fi+nb_lt; /* Longueur maximum des tableaux resultat*/
3879
3880 /*
3881 Creation de 3 tableaux bidimensionnels avec pour nombre de lignes lg_tb
3882 */
3883
3884 tb=(signed char **)SYM_MALLOC((lg_tb+4)*sz_pcar);
3885 nb_tb=(signed char **)SYM_MALLOC((lg_tb+4)*sz_pcar);
3886 yam=(signed char **)SYM_MALLOC((lg_tb+4)*sz_pcar);
3887 btb=tb;
3888 bnb_tb=nb_tb;byam=yam;
3889 for(i=0;i<=lg_tb+2;i++)
3890 {
3891 *btb++ =(signed char *)SYM_calloc(nb_lt+3,1);
3892 *bnb_tb++ =(signed char *)SYM_calloc(nb_lt+3,1);
3893 *byam++ =(signed char *)SYM_calloc(nb_lt+3,1);
3894 }
3895 *btb=NULL;*bnb_tb =NULL;*byam=NULL;
3896
3897 /*
3898 Construction d'un tableau de taille lg_tb+3
3899 */
3900
3901 af=(signed char *)SYM_MALLOC(lg_tb+3);
3902
3903 /*
3904 Creation d'un tableau de dimension nb_lt + 2
3905 ou on met les sommes cumulees du vecteur d'evaluation
3906 pds: poids de la partition composee des parts de la partition
3907 */
3908
3909 pos=(signed char *)SYM_MALLOC(nb_lt+2);
3910 bpos=pos;
3911 *bpos++ =0; bev=ev;av=0;
3912 for(i=1;i<=nb_lt;i++)
3913 {
3914 *bpos = av+ *bev;
3915 av= *bpos;
3916 bev++;bpos++;
3917 }
3918 pds= *--bpos;
3919
3920
3921 /*
3922 Creation d'un tableau de pointeurs sur struct liste de dimension
3923 pds pour l'inserion d'un tableau dans la liste des tableaux
3924 */
3925
3926 pl=(struct liste **)SYM_MALLOC((pds+2)*sz_plst);
3927
3928
3929 /*
3930 Initialisation avant remplissage des tableaux
3931 */
3932
3933 bnb_tb=nb_tb+1;
3934 bev=ev;
3935 btb=tb+1;
3936 byam=yam+1;
3937 av= *bev;
3938 if(lg_fi<nb_lt)
3939 lg_tb_dct=nb_lt;
3940 else
3941 lg_tb_dct=lg_fi;
3942
3943 bfi=fi;
3944 baf=af+1;
3945
3946 /*
3947 Remplissage des tableaux
3948 */
3949
3950 for(i=1;i<=nb_lt;i++)
3951 {
3952 tp= *bev;tmp= *bfi;
3953 *(*bnb_tb+i)=tp;
3954 bpos= *btb;
3955 for(j=0;j<i;j++)
3956 *bpos++ =tmp;
3957 for(;j<=nb_lt+1;j++)
3958 *bpos++ =tmp+tp;
3959 *baf= *(bpos-1);
3960 if(i!=1)
3961 {
3962 bbyam=byam;
3963 tmp=av- tp;
3964 for(j=i;j<=lg_tb;j++)
3965 {
3966 *(*bbyam+i)=tmp;
3967 bbyam++;
3968 }
3969 }
3970 av= *bev;
3971 btb++;baf++;
3972 byam++;
3973 bev++;
3974 bnb_tb++;
3975 if(i<=lg_fi) bfi++;
3976 }
3977
3978 for(; i<= lg_tb_dct;i++)
3979 {
3980 tmp= *bfi++;
3981 *baf++ =tmp;
3982 bpos= *btb;
3983 for(j=0;j<=nb_lt+1;j++)
3984 *bpos++ =tmp;
3985 btb++;
3986 }
3987 *baf=0;
3988 bpl=pl+1;
3989 for(i=1;i<=pds;i++)
3990 *bpl++ =lst;
3991 coef=coef1*coef2;
3992 *af=lg_tb_dct;
3993 ins_sch_lst(af,coef,&lst);
3994 lst1=lst;
3995
3996 /*
3997 Debut de l'algorithme
3998 */
3999 niv=nb_lt;
4000 lg_old=lg_tb_dct;
4001 etat=0;ssetat=0;
4002 while(niv>0)
4003 {
4004 switch(etat)
4005 {
4006 case 0:
4007
4008 /*
4009 Depilage: Essai de placer les lettres plus haut dans le tableau
4010 */
4011
4012 ev_niv=ev[niv-1];
4013 if(ssetat==0)
4014 {
4015 baf=af+lg_tb_dct;
4016 btb=tb+lg_tb_dct;
4017 bnb_tb=nb_tb+lg_tb_dct;
4018 i= ev_niv;j=lg_tb_dct;
4019 av=lg_tb_dct+1;
4020 }
4021 else
4022 {
4023 ssetat=0;
4024 j=av-1;
4025 i=ttp;
4026 lg_tb_dct=lg_tb_dct0;
4027 baf=af+j;
4028 bnb_tb=nb_tb+j;
4029 btb=tb+j;
4030 }
4031
4032 while(i>0)
4033 {
4034 /*
4035 Chaque lettre i de valeur niv est testee.
4036 */
4037 if(*(*bnb_tb+ niv)==0)
4038 {
4039 bnb_tb--;btb--;
4040 j--;baf--;
4041 }
4042 else
4043 {
4044 ctb=btb;dtb=btb+1;
4045
4046 for(k=j+1;k<=av;k++)
4047 {
4048 /* On teste ou la mettre plus haut dans le tableau tb*/
4049 topc= *(*ctb+niv-1);
4050 topd= *(*dtb+niv);
4051 if(topc>topd)
4052 {
4053 if(k >lg)
4054 break;
4055 else
4056 {
4057 /*SUCCES: On enleve cette lettre niv de la ligne j pour la mettre
4058 plus haut dans le tableau*/
4059 etat=1;fr=niv;
4060 av=j;ttp=i- *(*bnb_tb+niv);
4061 (*(*btb+niv))--;
4062 lg_tb_dct0=lg_tb_dct;
4063 niv0=niv;
4064 (*baf)--;(*(*bnb_tb+niv))--;
4065 byam=yam+j;
4066 (*(*byam+niv))++;tp= *(*byam+niv);
4067 byam++;j++;
4068 for(;j<k;j++)
4069 {
4070 tp += *(*bnb_tb+niv-1);
4071 *(*byam+niv)=tp;bnb_tb++;byam++;
4072 }
4073 /*bas est le numero de la lettre qu'on va placer*/
4074 bas=i+pos[niv-1];
4075 tmp= *(*bnb_tb+niv-1);
4076 bnb_tb++;
4077 /*
4078 La ieme lettre de valeur niv peut se placer a la ligne j. Ne pas la placer.
4079 Le placement de cette ieme lettre et de ses suivantes se fait dans le case 1
4080 */
4081 ssetat=1;btb=tb+j;baf=af+j;
4082 }/*k>lg*/
4083 break;
4084 }/*if(topc>topd)*/
4085 ctb++;dtb++;
4086 }/*for(k=j+1;k<=av;k++)*/
4087 if(etat==1)break;
4088 tp= *(*bnb_tb+niv);av=j;i-=tp;
4089 bnb_tb--;btb--;j--;baf--;
4090 }/*else du if(*(*bnb_tb+niv)==0)*/
4091 }/*while(i>0)*/
4092 if(etat==1)break;
4093 if(*(*(tb+lg_tb_dct)+niv-1)==0) lg_tb_dct--;
4094 niv--;
4095 break;/*Sortie du case 0*/
4096
4097 case 1:
4098
4099 if(ssetat==0)
4100 {
4101 /*
4102 On commence a placer la premiere lettre de valeur niv
4103 */
4104 i=1;j=niv; /* premiere lettre niv*/
4105 btb=tb+j;byam=yam+j;baf=af+j;
4106 bnb_tb=nb_tb+j;
4107 }
4108 /*j est forcement > 1*/
4109 /*Essai de placer toutes les lettres niv de i a ev_niv*/
4110 ev_niv=ev[niv-1];
4111 while((j<=lg_tb_dct)||(i<=ev_niv))
4112 {
4113 if(j>lg)
4114 {
4115 if(ttp>0)
4116 {
4117 etat=0;ssetat=1;niv=niv0;
4118 }
4119 else
4120 {
4121 etat=0; ssetat=0; niv=niv0-1;
4122 if(*(*(tb+lg_tb_dct0)+niv)==0)
4123 lg_tb_dct=lg_tb_dct0-1;
4124 else
4125 lg_tb_dct=lg_tb_dct0;
4126 }
4127 break;
4128 }
4129 topc= *(*(btb-1)+niv-1);
4130 topd= *(*btb+niv-1);
4131 tmp=topc-topd;
4132 ym= *(*(byam-1)+niv)+ *(*(bnb_tb-1)+niv-1);
4133 if((tmp>0)&&(ym>0))
4134 {
4135 if(tmp>ym)tmp=ym;
4136 dsp=ev_niv-i+1;
4137 if(tmp>dsp)tmp=dsp;
4138 *(*byam+niv) =ym-tmp;
4139 *(*bnb_tb+niv)=tmp;
4140 *(*btb+niv)=topd+tmp;
4141 *baf=topd+tmp;
4142 i+=tmp;
4143 if(j>lg_tb_dct)
4144 {
4145 lg_tb_dct++;
4146 }
4147 }
4148 else
4149 {
4150 *(*byam+niv)=ym;
4151 *(*btb+niv) =topd;
4152 *baf=topd;
4153 *(*bnb_tb+niv)=0;
4154 }
4155 btb++;bnb_tb++;byam++;baf++;j++;
4156 }/*while((j<=lg_tb_dct)||(i<=ev_niv))*/
4157 if(etat==0)
4158 break;
4159
4160 topd= *(*btb+niv-1);
4161 for(;j<=lg_old;j++)
4162 {
4163 *(*btb+niv)=topd;
4164 btb++;
4165 }
4166
4167
4168 niv++;ssetat=0;
4169 break;/*Sortie de case 1*/
4170 }
4171 if(niv >nb_lt)
4172 {
4173 etat=0;
4174 if(lg_tb_dct<lg_old)
4175 {
4176 i=lg_tb_dct+1;
4177 btb=tb+i;
4178 bfi=fi+i-1;
4179 for(;i<=lg_fi;i++)
4180 {
4181 bpos= *btb+fr;
4182 for(j=fr;j<=nb_lt;j++)
4183 *bpos++ = *bfi;
4184 bfi++;btb++;
4185 }
4186 for(;i<=lg_old;i++)
4187 {
4188 bpos= *btb+fr;
4189 for(j=fr;j<=nb_lt;j++)
4190 *bpos++ = 0;
4191 btb++;
4192 }
4193 }
4194 lg_old=lg_tb_dct;
4195 *(af+lg_tb_dct+1)=0;
4196 *af=lg_tb_dct;
4197
4198 niv--;
4199 bpc=pl[bas];
4200 ins_sch_lst(af,coef,&bpc);
4201 bpl=pl+bas;
4202 for(i=bas;i<=pds;i++)
4203 *bpl++ =bpc;
4204 bas=pds+1;cmt++;
4205 }
4206 }
4207 SYM_free(af);SYM_free(pos);
4208 btb=tb;byam=yam;bnb_tb=nb_tb;
4209 for(i=0;i<lg_tb+2;i++)
4210 {
4211 SYM_free(*byam);SYM_free(*bnb_tb);SYM_free(*btb);
4212 byam++;bnb_tb++;btb++;
4213 }
4214 SYM_free(*byam);SYM_free(*bnb_tb);SYM_free(*btb);
4215 SYM_free((signed char *)tb);SYM_free((signed char *)nb_tb);SYM_free((signed char *)yam);
4216 /*CC 27/02*/
4217 SYM_free(pl);
4218
4219 return lst1;
4220 }
4221
4222 /*
4223 Produit de sommes de fonctions de Schur
4224 le resultat res est tronque selon la longueur des partitions
4225 lst1 et lst2 sont triees
4226 lst2 est non vide
4227 */
4228
fct_sch_lg_srt(lst1,lst2,lg,res)4229 static INT fct_sch_lg_srt(lst1,lst2,lg,res)
4230 struct liste *lst1,*lst2,*res;
4231 signed char lg;
4232 {
4233 register struct liste *bp;
4234 struct liste *bnv1,*bnv2;
4235
4236 lst1=lst1->suivant;
4237 bnv1=res;
4238 while(lst1!=NULL)
4239 {
4240 bp=lst2->suivant;
4241 bnv1=pro_lg(lst1->tab,bp->tab,lst1->coef,bp->coef,lg,bnv1);
4242 bnv2=bnv1;
4243 bp=bp->suivant;
4244 while(bp!=NULL)
4245 {
4246 bnv2=pro_lg(lst1->tab,bp->tab,lst1->coef,bp->coef,lg,bnv2);
4247 bp=bp->suivant;
4248 }
4249 lst1=lst1->suivant;
4250 }
4251 return OK;
4252 }
4253
4254 /*
4255 Product of Schur functions S_{pa}*S_{pb}
4256 pa and pb are partition objects.
4257 */
4258
outerproduct_schur_lrs(pa,pb,c)4259 INT outerproduct_schur_lrs(pa,pb,c) OP pa,pb,c;
4260 {
4261 OP prt,tmp,cf,v,d;
4262 signed char *va,*vb,*baf,*bva,*bvb;
4263 INT i,na,nb,lg,k;
4264 struct liste str,*lst,*bp;
4265
4266 if(S_O_K(pa)!= PARTITION)
4267 return error("outerproduct_schur_lrs: Wrong first type");
4268 if(S_O_K(pb)!= PARTITION)
4269 return error("outerproduct_schur_lrs: Wrong second type");
4270
4271 if(S_PA_LI(pa)==0L && S_PA_LI(pb)==0L)
4272 {
4273 if(not EMPTYP(c)) freeself(c);
4274 M_I_I(1L,c); return OK;
4275 }
4276 if(S_PA_LI(pa)==0L)
4277 {
4278 if(not EMPTYP(c)) freeself(c);
4279 m_skn_s(pb,cons_eins,NULL,c);
4280 return OK;
4281 }
4282 if(S_PA_LI(pb)==0L)
4283 {
4284 if(not EMPTYP(c)) freeself(c);
4285 m_skn_s(pa,cons_eins,NULL,c);
4286 return OK;
4287 }
4288 init(SCHUR,c);d=c;
4289 va=(signed char *)SYM_MALLOC(S_PA_LI(pa)+1L);
4290 vb=(signed char *)SYM_MALLOC(S_PA_LI(pb)+1L);
4291 na=0L;nb=0L;bva=va;bvb=vb;
4292 for(i=S_PA_LI(pa)-1L;i>=0L;i--)
4293 {
4294 *bva++ =(signed char) S_PA_II(pa,i);
4295 na++;
4296 }
4297 *bva=0;
4298 for(i=S_PA_LI(pb)-1L;i>=0L;i--)
4299 {
4300 *bvb++ =(signed char) S_PA_II(pb,i);
4301 nb++;
4302 }
4303 *bvb=0;
4304 str.suivant=NULL;
4305 if(na>nb)
4306 proprt(va,vb,1L,1L,99L,&str);
4307 else
4308 proprt(vb,va,1L,1L,99L,&str);
4309 lst=str.suivant;
4310 SYM_free(va); SYM_free(vb);
4311 while(lst!=NULL)
4312 {
4313 cf=callocobject();tmp=callocobject();
4314 M_I_I(lst->coef,cf);
4315 prt=callocobject();v=callocobject();
4316 baf=lst->tab;
4317 while(*baf)baf++;
4318 lg=(INT)(baf-lst->tab);
4319 m_il_v(lg,v);
4320 baf--;
4321 for(k=0L;k<lg-1L;k++)
4322 {
4323 M_I_I((INT)(*baf),S_V_I(v,k));
4324 baf--;
4325 }
4326 M_I_I((INT)(*baf),S_V_I(v,lg-1L));
4327 b_ks_pa(VECTOR,v,prt);
4328 b_skn_s(prt,cf,NULL,tmp);
4329 /*
4330 insert(tmp,c,add_koeff,comp_monomvector_monomvector);
4331 */
4332 c_l_n(d,tmp);d=tmp;
4333 /*
4334 add_apply(tmp,c);
4335 */
4336 SYM_free(lst->tab);
4337 bp=lst;
4338 lst=lst->suivant;
4339 SYM_free((char *)bp);
4340 }
4341 if(S_L_N(c)!=NULL)
4342 {
4343 /*CC 24/01/97*/
4344 d=S_L_N(c);
4345 c_l_s(c,S_L_S(S_L_N(c)));
4346 c_l_n(c,S_L_N(S_L_N(c)));
4347 c_l_n(d,NULL);
4348 c_l_s(d,NULL);
4349 freeall(d);
4350 }
4351 return OK;
4352 }
4353
4354
4355 /*
4356 Product of Schur functions S_{pa}*S_{pb}
4357 restricted with parts <= mx
4358 pa and pb are partition objects.
4359 */
4360
mx_outerproduct_schur_lrs(mx,pa,pb,c)4361 INT mx_outerproduct_schur_lrs(mx,pa,pb,c) OP pa,pb,c,mx;
4362 {
4363 OP prt,tmp,cf,v,d;
4364 signed char *va,*vb,*baf,*bva,*bvb;
4365 INT i,na,nb,lg,k;
4366 struct liste str,*lst,*bp;
4367
4368 if(S_O_K(pa)!= PARTITION)
4369 return error("outerproduct_schur_lrs: Wrong first type");
4370 if(S_O_K(pb)!= PARTITION)
4371 return error("outerproduct_schur_lrs: Wrong second type");
4372
4373 if(S_I_I(mx)<0L)
4374 {
4375 init(SCHUR,c);
4376 return OK;
4377 }
4378
4379 if(S_PA_LI(pa)==0L && S_PA_LI(pb)==0L)
4380 {
4381 if(not EMPTYP(c)) freeself(c);
4382 M_I_I(1L,c); return OK;
4383 }
4384 if(S_PA_LI(pa)==0L)
4385 {
4386 if(S_PA_II(pb,S_PA_LI(pb)-1L)<=S_I_I(mx))
4387 {
4388 if(not EMPTYP(c)) freeself(c);
4389 m_skn_s(pb,cons_eins,NULL,c);
4390 }
4391 else
4392 init(SCHUR,c);
4393 return OK;
4394 }
4395 if(S_PA_LI(pb)==0L)
4396 {
4397 if(S_PA_II(pa,S_PA_LI(pa)-1L)<=S_I_I(mx))
4398 {
4399 if(not EMPTYP(c)) freeself(c);
4400 m_skn_s(pa,cons_eins,NULL,c);
4401 }
4402 else
4403 init(SCHUR,c);
4404 return OK;
4405 }
4406
4407 init(SCHUR,c);d=c;
4408 str.suivant=NULL;
4409 va=(signed char *)SYM_MALLOC(S_PA_LI(pa)+1L);
4410 vb=(signed char *)SYM_MALLOC(S_PA_LI(pb)+1L);
4411 na=0L;nb=0L;bva=va;bvb=vb;
4412 for(i=S_PA_LI(pa)-1L;i>=0L;i--)
4413 {
4414 *bva++ =(signed char) S_PA_II(pa,i);
4415 na++;
4416 }
4417 *bva=0;
4418 for(i=S_PA_LI(pb)-1L;i>=0L;i--)
4419 {
4420 *bvb++ =(signed char) S_PA_II(pb,i);
4421 nb++;
4422 }
4423 *bvb=0;
4424 if(na>nb)
4425 proprt(va,vb,1L,1L,(signed char)S_I_I(mx),&str);
4426 else
4427 proprt(vb,va,1L,1L,(signed char)S_I_I(mx),&str);
4428 lst=str.suivant;
4429 SYM_free(va); SYM_free(vb);
4430 while(lst!=NULL)
4431 {
4432 cf=callocobject();tmp=callocobject();v=callocobject();
4433 M_I_I(lst->coef,cf);
4434 prt=callocobject();
4435 baf=lst->tab;
4436 while(*baf)baf++;
4437 lg=(INT)(baf-lst->tab);
4438 m_il_v(lg,v);
4439 baf--;
4440 for(k=0L;k<lg-1L;k++)
4441 {
4442 M_I_I((INT)(*baf),S_V_I(v,k));
4443 baf--;
4444 }
4445 M_I_I((INT)(*baf),S_V_I(v,lg-1L));
4446 b_ks_pa(VECTOR,v,prt);
4447 b_skn_s(prt,cf,NULL,tmp);
4448 c_l_n(d,tmp);d=tmp;
4449
4450 SYM_free(lst->tab);
4451 bp=lst;
4452 lst=lst->suivant;
4453 SYM_free((char *)bp);
4454 }
4455 if(S_L_N(c)!=NULL)
4456 {
4457 /*CC 24/01/97*/
4458 d=S_L_N(c);
4459 c_l_s(c,S_L_S(S_L_N(c)));
4460 c_l_n(c,S_L_N(S_L_N(c)));
4461 c_l_n(d,NULL);
4462 c_l_s(d,NULL);
4463 freeall(d);
4464 }
4465 return OK;
4466 }
4467
4468
4469 /*
4470 Product of Schur functions S_{pa}*S_{pb}
4471 restricted upon lengths <=le
4472 pa and pb are partition objects.
4473 */
4474
l_outerproduct_schur_lrs(le,pa,pb,c)4475 INT l_outerproduct_schur_lrs(le,pa,pb,c) OP pa,pb,c,le;
4476 {
4477 OP prt,tmp,cf,v,d;
4478 signed char *va,*vb,*baf,*bva,*bvb;
4479 INT i,na,nb,lg,k;
4480 struct liste str,*lst,*bp;
4481
4482 if(S_O_K(pa)!= PARTITION)
4483 return error("outerproduct_schur_lrs: Wrong first type");
4484 if(S_O_K(pb)!= PARTITION)
4485 return error("outerproduct_schur_lrs: Wrong second type");
4486
4487 if(S_I_I(le)<0L)
4488 {
4489 init(SCHUR,c);
4490 return OK;
4491 }
4492
4493 if(S_PA_LI(pa)==0L && S_PA_LI(pb)==0L)
4494 {
4495 if(not EMPTYP(c)) freeself(c);
4496 M_I_I(1L,c); return OK;
4497 }
4498 if(S_PA_LI(pa)==0L)
4499 {
4500 if(S_PA_LI(pb)<=S_I_I(le))
4501 {
4502 if(not EMPTYP(c)) freeself(c);
4503 m_skn_s(pb,cons_eins,NULL,c);
4504 }
4505 else
4506 init(SCHUR,c);
4507 return OK;
4508 }
4509 if(S_PA_LI(pb)==0L)
4510 {
4511 if(S_PA_LI(pa)<=S_I_I(le))
4512 {
4513 if(not EMPTYP(c)) freeself(c);
4514 m_skn_s(pa,cons_eins,NULL,c);
4515 }
4516 else
4517 init(SCHUR,c);
4518 return OK;
4519 }
4520
4521 init(SCHUR,c); d=c;
4522 str.suivant=NULL;
4523 va=(signed char *)SYM_MALLOC(S_PA_LI(pa)+1L);
4524 vb=(signed char *)SYM_MALLOC(S_PA_LI(pb)+1L);
4525 na=0L;nb=0L;bva=va;bvb=vb;
4526 for(i=S_PA_LI(pa)-1L;i>=0L;i--)
4527 {
4528 *bva++ =(signed char) S_PA_II(pa,i);
4529 na++;
4530 }
4531 *bva=0;
4532 for(i=S_PA_LI(pb)-1L;i>=0L;i--)
4533 {
4534 *bvb++ =(signed char) S_PA_II(pb,i);
4535 nb++;
4536 }
4537 *bvb=0;
4538 if(na>nb)
4539 pro_lg(va,vb,1L,1L,(signed char)S_I_I(le),&str);
4540 else
4541 pro_lg(vb,va,1L,1L,(signed char)S_I_I(le),&str);
4542 lst=str.suivant;
4543 SYM_free(va); SYM_free(vb);
4544 while(lst!=NULL)
4545 {
4546 cf=callocobject();tmp=callocobject();v=callocobject();
4547 M_I_I(lst->coef,cf);
4548 prt=callocobject();
4549 baf=lst->tab;
4550 while(*baf)baf++;
4551 lg=(INT)(baf-lst->tab);
4552 m_il_v(lg,v);
4553 baf--;
4554 for(k=0L;k<lg-1L;k++)
4555 {
4556 M_I_I((INT)(*baf),S_V_I(v,k));
4557 baf--;
4558 }
4559 M_I_I((INT)(*baf),S_V_I(v,lg-1L));
4560 b_ks_pa(VECTOR,v,prt);
4561 b_skn_s(prt,cf,NULL,tmp);
4562 c_l_n(d,tmp);d=tmp;
4563 SYM_free(lst->tab);
4564 bp=lst;
4565 lst=lst->suivant;
4566 SYM_free((char *)bp);
4567 }
4568 if(S_L_N(c)!=NULL)
4569 {
4570 /*CC 24/01/97*/
4571 d=S_L_N(c);
4572 c_l_s(c,S_L_S(S_L_N(c)));
4573 c_l_n(c,S_L_N(S_L_N(c)));
4574 c_l_n(d,NULL);
4575 c_l_s(d,NULL);
4576 freeall(d);
4577 }
4578 return OK;
4579 }
4580
4581 /*
4582 The plethysmes S_n(S_I) of the different components of the
4583 Schur functions being in newton,
4584 det computes the plethysm S_I(S_J)
4585 */
detr(ext,m,le,newton,boo,lst)4586 static INT detr(ext,m,le,newton,boo,lst)
4587 signed char m,le,*boo,*ext;
4588 struct liste *lst,*newton;
4589 {
4590 signed char i,j,sig,tmp,pds;
4591 struct liste lst1[1],lst2[1],*bp;
4592
4593 lst1->suivant=NULL;
4594 lst2->suivant=NULL;
4595 i=1;j=1;
4596 while(i!= m+1)
4597 {
4598 if(boo[j]==0)
4599 {
4600 if(m==1)
4601 {
4602 tmp=le-j+ *(ext+le-1);
4603 lst->suivant=(newton+tmp)->suivant;
4604 return OK;
4605 }
4606 else
4607 {
4608 tmp=le-m+1-j+ *(ext+le-m);
4609 if(tmp < 0) return OK;
4610 if(i%2==1) sig=1;
4611 else sig= -1;
4612 boo[j]=1;
4613 detr(ext,m-1,le,newton,boo,lst1);
4614 boo[j]=0;
4615 if(tmp==0)
4616 {
4617 shuffle_sig(lst1,sig,lst);
4618 if(m!=2)
4619 free_lst(lst1);
4620 else
4621 lst1->suivant=NULL;
4622 return OK;
4623 }
4624 else
4625 {
4626 pds=poids(lst1);
4627 if(pds!=0)
4628 {
4629 if(booo==1)
4630 {
4631 if(poids(newton+tmp)< pds)
4632 fct_sch_prt_srt(lst1,newton+tmp,lng,lst2);
4633 else
4634 fct_sch_prt_srt(newton+tmp,lst1,lng,lst2);
4635 }
4636 else
4637 {
4638 if(poids(newton+tmp)<pds)
4639 fct_sch_lg_srt(lst1,newton+tmp,lng,lst2);
4640 else
4641 fct_sch_lg_srt(newton+tmp,lst1,lng,lst2);
4642 }
4643
4644 /*CC 04/03/97 */
4645 if(booo==1) SYM_free(lst2->tab);
4646
4647 if(m!=2)
4648 free_lst(lst1);
4649 else
4650 lst1->suivant=NULL;
4651 if(lst->suivant!=NULL)
4652 {
4653 shuffle_sig(lst2,sig,lst);
4654 free_lst(lst2);
4655 }
4656 else
4657 {
4658 if (sig!=1)
4659 {
4660 bp=lst2->suivant;
4661 while(bp!=NULL)
4662 {
4663 bp->coef= -bp->coef;
4664 bp=bp->suivant;
4665 }
4666 }
4667 lst->suivant=lst2->suivant;
4668 lst2->suivant=NULL;
4669 }
4670 }
4671 i++;
4672 }
4673 }/*else du if(m==1)*/
4674 }/*if(boo[j]==0)*/
4675 j++;
4676 }
4677 return OK;
4678 }
4679
4680 /*
4681 conjugates the partition being in decreasing order (4 3 1 for example
4682 gives 3 2 2 1)
4683 */
4684
cjg_rv(ttab)4685 static INT cjg_rv(ttab) signed char **ttab;
4686 {
4687 signed char *tab,*btab,*af,*baf;
4688 signed char lg,av,k,tp,j,tmp;
4689
4690 tab= *ttab;
4691 lg= *tab;
4692 af=(signed char *)SYM_MALLOC(lg+1);
4693 baf=af+lg;
4694 *baf-- =0;
4695 btab=tab;
4696 av = *btab++;
4697 k=1;tp= *btab;
4698 while(tp)
4699 {
4700 if(av != tp)
4701 {
4702 tmp=av-tp;
4703 for(j=0;j<tmp;j++)
4704 *baf-- =k;
4705 }
4706 av= tp; k++;
4707 btab++;
4708 tp= *btab;
4709 }
4710 for(j=1;j<av;j++)
4711 *baf-- =k;
4712 *baf=k;
4713 *ttab=af;
4714 SYM_free(tab);
4715 return OK;
4716 }
4717
4718 /*
4719 Conjugates all the cells of a list with decreasing partition
4720 */
4721
cjg_rv_lst(lst)4722 static INT cjg_rv_lst(lst)
4723 struct liste *lst;
4724 {
4725 lst=lst->suivant;
4726 while(lst!=NULL)
4727 {
4728 cjg_rv(&lst->tab);
4729 lst=lst->suivant;
4730 }
4731 return OK;
4732 }
4733
pl_schur_schur(inn,ext,cond1,cond2,cond3,lst)4734 static INT pl_schur_schur(inn,ext,cond1,cond2,cond3,lst)
4735 signed char *inn,*ext,cond1,cond2,cond3;
4736 struct liste *lst;
4737 {
4738 signed char mx,*bx,le,*boo;
4739 struct liste *newton;
4740
4741 le= -1;
4742 bx=ext;
4743 while(*bx)
4744 {
4745 le++;bx++;
4746 }
4747 mx= *(bx-1)+le;
4748 newton=(struct liste *)SYM_MALLOC((mx+1)*sizeof(struct liste));
4749 plth2(inn,cond1,cond2,cond3,mx,newton);
4750 le++;
4751 boo=(signed char *)SYM_calloc(le+2,1);
4752 lst->suivant=NULL;
4753 if(cond3==1)
4754 {
4755 if(booo==1) booo=0;
4756 else booo=1;
4757 }
4758 detr(ext,le,le,newton,boo,lst);
4759
4760 /*
4761 printf("booo %d le %d mx %d *(ext) %d\n",booo,le,mx,*ext);
4762 */
4763
4764 /* CC 24/01/97 */
4765 if(le==1)
4766 free_newton(newton, mx-1);
4767 else
4768 /* CC 27/02/97 */
4769 free_newton(newton, mx);
4770
4771 SYM_free(newton);
4772 if(cond3==1)
4773 {
4774 if(booo==1) booo=0;
4775 else booo=1;
4776 }
4777 if(booo==1) cjg_rv_lst(lst);
4778 SYM_free(boo);
4779 return OK;
4780 }
4781
cc_plethysm(m,otab,cond1,ores)4782 static INT cc_plethysm(m,otab,cond1,ores)
4783 signed char m,cond1; OP otab,ores;
4784 {
4785 OP sc,ve,pa,cf;
4786 signed char tab[20];
4787 signed char *s,*bs,*btab,*baf,*af,*bch,*tab1;
4788 signed char condition,parite,mx,np,npt,le,inv;
4789 INT cof;
4790 INT c;
4791 signed char n,in;
4792 signed char k;
4793 signed char cond,cond2,high,mid;
4794 register signed char i,j,temp;
4795 struct liste str,*newton,*bp,*liste,*liste1;
4796
4797 for (i=0;i<20;i++) tab[(int)i]=0;
4798
4799 inv = 0;
4800 le = (signed char)S_PA_LI(otab);
4801 if(le > 19)
4802 {
4803 fprintf(stderr,"partition too long\n");
4804 exit(inv);
4805 }
4806 btab = tab;
4807 mx = 0;
4808 for(c = 0L; c < le; c++)
4809 {
4810 *btab = (signed char)S_PA_II(otab,c);
4811 mx += *btab++;
4812 }
4813 if(( le * mx) > 127)
4814 {
4815 fprintf(stderr,"too big plethysm for my little structures\n");
4816 exit(inv);
4817 }
4818 *btab = 0;
4819 cond2 = 0;
4820
4821
4822 newton = (struct liste *)SYM_MALLOC( (m+1) * sizeof(struct liste) );
4823 if(*(btab - 1) < le)
4824 {
4825 inv = 1;
4826 tab1 = (signed char *)SYM_MALLOC(*(btab - 1) + 1);
4827 bs = tab1;
4828 btab = tab;
4829 af = (signed char *)SYM_MALLOC(le + 1);
4830 baf = af;
4831 while(*btab != 0)
4832 *baf++ = *btab++;
4833 *baf = 0;
4834
4835 cond = -1;
4836 j = le - 1;
4837 btab = af + j;
4838 mid = *btab;
4839 j++;
4840 temp = 0;
4841 while(j >= 0)
4842 {
4843 high = 0;
4844 while(*btab == mid)
4845 {
4846 j--;
4847 high++;
4848 if(j == 0)
4849 {
4850 *btab = 0;
4851 j--;
4852 break;
4853 }
4854 btab--;
4855 }
4856 temp = temp+high;
4857 for(i = *btab;i < mid;i++)
4858 {
4859 cond++;
4860 *bs++ = temp;
4861 }
4862 mid = *btab;
4863 }
4864 *bs = 0;
4865 SYM_free(af);
4866 }
4867 else
4868 {
4869 tab1 = (signed char *)SYM_MALLOC(le + 1);
4870 btab = tab;
4871 bch = tab1;
4872 while(*btab != 0)
4873 *bch++ = *btab++;
4874 *bch = 0;
4875 }
4876
4877 booo = 0;
4878 if((( cond2 == 0) && (inv == 0)) || ((cond2 == 1) && (inv == 1)))
4879 booo = 1;
4880 if(cond2 == 0)
4881 {
4882 if(lng < le)
4883 {
4884 fprintf(stderr,"No elements of the length %d in this plethysm\n",m);
4885 exit(inv);
4886 }
4887 }
4888 else
4889 if(lng < *(tab + le - 1))
4890 {
4891 fprintf(stderr,"No elements of the length %d in this plethysm\n",m);
4892 exit(inv);
4893 }
4894
4895
4896
4897 liste1 = &str;
4898
4899 if ( cond2 == 0)
4900
4901 if(cond1 == 0)
4902
4903 if((mx%2 == 0) || ((mx%2 == 1)&&(inv == 1)))
4904 condition = 0;
4905 else
4906
4907 condition = 1;
4908 else
4909
4910 if((mx%2 == 0) || ((mx%2 == 1)&&(inv == 1)))
4911 condition = 1;
4912 else
4913 condition = 0;
4914 else
4915
4916 if(cond1 == 0)
4917 if((inv == 0) || ((inv == 1) && (mx%2 == 0)))
4918 condition = 0;
4919 else
4920
4921 condition = 1;
4922 else
4923 if((inv == 0) || ((inv == 1) && (mx%2 == 0)))
4924 condition = 1;
4925 else
4926
4927 condition = 0;
4928 liste = (struct liste *)SYM_MALLOC(sizeof(struct liste));
4929 liste->coef = 1L;
4930 liste->suivant = NULL;
4931 liste1->suivant = liste;
4932 bs = (signed char *)SYM_MALLOC(1);
4933 if (bs == NULL)
4934 return no_memory();
4935 liste->tab = bs;
4936 *bs = (signed char) 0;
4937 (newton)->suivant = liste1->suivant;
4938
4939 for(n = 1;n <= m;n++)
4940 {
4941 liste1->suivant = NULL;
4942 np = n * mx;
4943 npt = np;
4944 if( n == 1)
4945 {
4946 liste = (struct liste *)SYM_MALLOC(sizeof(struct liste));
4947 liste->coef = 1L;
4948 liste->suivant = NULL;
4949 liste1->suivant = liste;
4950 if (inv == 0)
4951 {
4952 bs = (signed char *)SYM_calloc(tab[le - 1] + 1,sizeof(char));
4953 liste->tab = bs;
4954 btab = tab;
4955 af = (signed char *)SYM_calloc(le + 1,sizeof(char));
4956 baf = af;
4957 while(*btab != (signed char)0)
4958 *baf++ = *btab++;
4959 *baf = (signed char)0;
4960
4961 cond = (signed char)-1;
4962 j = le - 1;
4963 btab = af + j;
4964 mid = *btab;
4965 j++;
4966 temp = (signed char)0;
4967 while(j >= (signed char)0)
4968 {
4969 high = (signed char)0;
4970 while(*btab == mid)
4971 {
4972 j--;
4973 high++;
4974 if(j == (signed char)0)
4975 {
4976 *btab = (signed char)0;
4977 j--;
4978 break;
4979 }
4980 btab--;
4981 }
4982 temp = temp+high;
4983 for(i = *btab;i < mid;i++,bs++)
4984 {
4985 cond++;
4986 *bs = temp;
4987 }
4988 mid = *btab;
4989 }
4990 *bs = 0;
4991 temp = mx - 1;
4992 bs--;
4993 for(i = 0 ;i <= cond; i++)
4994 {
4995 (*bs) += temp;
4996 temp--;
4997 if(i != cond)
4998 bs--;
4999 }
5000 if(bs == NULL)
5001 return OK;
5002 SYM_free(af);
5003
5004 }
5005 else
5006 {
5007 liste->tab = (signed char *)SYM_MALLOC(le + 1);
5008 bs = liste->tab + le;
5009 *bs-- = 0;
5010 btab = tab + le - 1;
5011 temp = mx - 1;
5012 for(i = 1 ;i <= le; i++)
5013 {
5014 *bs = *btab + temp;
5015 temp--;
5016 if(i != le)
5017 {
5018 btab--;
5019 bs--;
5020 }
5021 }
5022 }
5023 }
5024 else
5025 {
5026 for(in = 0;in < n;in++)
5027 {
5028
5029
5030 if(condition == 1)
5031 {
5032 i = (n+1+in)%2;
5033 if(i == 0)
5034 parite = 1;
5035 else
5036 parite = -1;
5037 }
5038 else
5039 parite = 1;
5040
5041
5042 liste = (newton+in)->suivant;
5043
5044 while(liste != NULL)
5045 {
5046 baf = liste->tab;
5047 temp = np - npt;
5048 s = (signed char *)SYM_MALLOC(temp + 1);
5049 if(temp != 0)
5050 {
5051 temp--;
5052 j = 0;
5053 while(*baf != '\0')
5054 {
5055 j++;
5056 baf++;
5057 }
5058
5059 baf--;
5060 btab = s + j;
5061 *btab-- = 0;
5062 for(k = j-1;k >= 0;k--)
5063 {
5064 *btab = (*baf) - temp;
5065 if(k != 0)
5066 {
5067 btab--;
5068 baf--;
5069 temp--;
5070 }
5071 }
5072 }
5073 else
5074 *s = '\0';
5075
5076 cof = liste->coef;
5077 gvr = 0;
5078
5079 calcul(tab1,(int) n - in,s,liste1,cof,parite,n);
5080
5081
5082 SYM_free(s); /* AK 181291 */
5083 liste = liste->suivant;
5084 }
5085 npt = npt - mx;
5086
5087 }
5088 /* End of the loop for (in = 0;in < n ;in++) */
5089
5090 }
5091 liste = liste1->suivant;
5092
5093 while(liste != NULL)
5094 {
5095 liste->coef = liste->coef/n;
5096 liste = liste->suivant;
5097 }
5098
5099 (newton + n)->suivant = liste1->suivant;
5100
5101 }
5102
5103 /* End of the loop with n*/
5104 liste = newton + 1;
5105
5106 /*START OF THE THIRD PART WRITING IN THE LIST ores*/
5107
5108 for(in = 1;in < m;in++)
5109 {
5110 bp = liste->suivant;
5111 while(bp != NULL)
5112 {
5113 SYM_free(bp->tab);
5114 liste1 = bp;
5115 bp = bp->suivant;
5116 SYM_free((signed char *)liste1);
5117 }
5118 /*liste1 = liste; Suppress */
5119 liste++;
5120 /* SYM_free((signed char *)liste1); AK 140192 wg sun */
5121 }
5122 bp = liste->suivant;
5123 k = in * mx;
5124 init(SCHUR,ores); /* d=ores; */
5125
5126 while(bp != NULL)
5127 {
5128 btab = bp->tab;
5129 j = -1;
5130 while(*btab != '\0')
5131 {
5132 btab++;
5133 j++;
5134 }
5135 btab--;
5136 temp = k-1;
5137
5138 for(i = j;i >= 0;i--)
5139 {
5140 (*btab--) -= temp;
5141 temp--;
5142 }
5143
5144 /*ALLOCATION OF A NEW MEMORY FOR THE VECTOR ve AND THE SCHUR FUNCTION sc.
5145 THE RESULT ores */
5146
5147 sc = callocobject(); ve = callocobject();
5148 pa=callocobject(); cf=callocobject();
5149
5150 if(booo == 1)
5151 conjug( bp->tab , j , ve);
5152 else
5153 {
5154 btab = bp->tab;
5155 m_il_v( (INT)(j+1), ve );
5156 for(i = 0; i<=j ;i++)
5157 {
5158 M_I_I( (INT)(*btab), S_V_I(ve, (INT) i));
5159 btab++;
5160 }
5161 }
5162 b_ks_pa(VECTOR,ve,pa);
5163 M_I_I(bp->coef,cf);
5164 b_skn_s(pa,cf,NULL,sc);
5165 insert(sc,ores,NULL,NULL); /* AK 151298 */
5166
5167 SYM_free(bp->tab);
5168 liste1 = bp;
5169 bp = bp->suivant;
5170 SYM_free((signed char *)liste1);
5171 }
5172
5173
5174 SYM_free(tab1);
5175
5176
5177 /*CC 24/01/97*/
5178 SYM_free(newton->suivant->tab); SYM_free(newton->suivant);
5179 SYM_free((signed char *)newton);
5180
5181 return OK;
5182 }
5183
t_list_coef_SYM(lst,cof,np,res)5184 static INT t_list_coef_SYM(lst,cof,np,res)
5185 struct liste * lst; OP res,cof;signed char np;
5186 {
5187 signed char lg;
5188 register signed char *baf,i;
5189 struct liste *q;
5190 OP pol,pa,v,cf,d;
5191
5192 lst=lst->suivant;
5193 init(SCHUR,res);
5194 d=res;
5195 while(lst!=NULL)
5196 {
5197 pol=callocobject();
5198 v=callocobject();
5199 pa=callocobject();
5200 cf=callocobject();
5201 baf=lst->tab;
5202 while(*baf) baf++;
5203 lg=(INT)(baf-lst->tab);
5204 m_il_v((INT)lg,v);
5205 i=np;
5206 baf--;
5207 for(;;)
5208 {
5209 *baf -=i;
5210 if(baf==lst->tab) break;
5211 i--;baf--;
5212 }
5213
5214 for(i=0;i<lg-1L;i++)
5215 {
5216 M_I_I((INT)(*baf),S_V_I(v,i));
5217 baf++;
5218 }
5219 M_I_I((INT)(*baf),S_V_I(v,i));
5220 b_ks_pa(VECTOR,v,pa);
5221 M_I_I((INT)lst->coef,cf);mult_apply(cof,cf);
5222 b_skn_s(pa,cf,NULL,pol);
5223 c_l_n(d,pol);d=pol;
5224 q=lst;
5225 lst=lst->suivant;
5226 SYM_free(q->tab);
5227 SYM_free((char *)q);
5228 }
5229 if(S_L_N(res)!=NULL)
5230 {
5231 /*CC 24/01/97*/
5232 d=S_L_N(res);
5233 c_l_s(res,S_L_S(S_L_N(res)));
5234 c_l_n(res,S_L_N(S_L_N(res)));
5235 c_l_n(d,NULL);
5236 c_l_s(d,NULL);
5237 freeall(d);
5238 }
5239 return OK;
5240 }
5241
5242
5243
t_list_SYM(lst,res)5244 static INT t_list_SYM(lst,res)struct liste * lst; OP res;
5245 {
5246 signed char lg;
5247 register signed char *baf,i;
5248 struct liste *q;
5249 OP pol,pa,v,cf,d;
5250
5251 lst=lst->suivant;
5252 init(SCHUR,res);
5253 d=res;
5254 while(lst!=NULL)
5255 {
5256 pol=callocobject();
5257 v=callocobject();
5258 pa=callocobject();
5259 cf=callocobject();
5260 baf=lst->tab;
5261 while(*baf) baf++;
5262 lg=baf-lst->tab;
5263 m_il_v((INT)lg,v);
5264 baf--;
5265
5266 for(i=0;i<lg-1L;i++)
5267 {
5268 M_I_I((INT)(*baf),S_V_I(v,i));
5269 baf--;
5270 }
5271 M_I_I((INT)(*baf),S_V_I(v,i));
5272 b_ks_pa(VECTOR,v,pa);
5273 M_I_I((INT)lst->coef,cf);
5274 b_skn_s(pa,cf,NULL,pol);
5275 c_l_n(d,pol);d=pol;
5276 q=lst;
5277 lst=lst->suivant;
5278 SYM_free(q->tab);
5279 SYM_free((char *)q);
5280 }
5281 if(S_L_N(res)!=NULL)
5282 {
5283 /*CC 24/01/97*/
5284 d=S_L_N(res);
5285 c_l_s(res,S_L_S(S_L_N(res)));
5286 c_l_n(res,S_L_N(S_L_N(res)));
5287 c_l_n(d,NULL);
5288 c_l_s(d,NULL);
5289 freeall(d);
5290 }
5291 return OK;
5292 }
5293
5294 /*
5295 a= \sum n_I*S_I => a= \sum n_I*S_I\tilde
5296 */
5297
5298 /*
5299 The partitions of the a=\sum n_I*S_I
5300 are put in its growing order
5301 */
5302
growingorder_schur(a)5303 INT growingorder_schur(a) OP a;
5304 {
5305 OP z,ap,b;
5306 b=callocobject();init(SCHUR,b);
5307 if(S_O_K(a) == SCHUR)
5308 {
5309 if(not nullp(a))
5310 {
5311 z=S_L_N(a);
5312 c_l_s(b,S_L_S(a));
5313 while(z!=NULL)
5314 {
5315 ap=S_L_N(z);
5316 C_L_N(z,NULL);
5317 insert(z,b,add_koeff,comp_monomvector_monomvector);
5318 z=ap;
5319 }
5320 c_l_s(a,s_l_s(b));
5321 c_l_n(a,s_l_n(b));
5322
5323 }
5324 }
5325 return OK;
5326 }
5327
5328
l_complete_schur_plet(olng,b,c,res)5329 INT l_complete_schur_plet(olng,b,c,res) OP c,res,olng,b;
5330 /*l_complete_schur_plet COMPUTES THE TERMS OF S_n(S_I) LESS THAN lng.*/
5331 /* result is of type SCHUR */
5332 /* CC 1996 */
5333 /* AK 210704 V3.0 */
5334 {
5335 INT erg = OK;
5336 CTO(INTEGER,"l_complete_schur_plet(1)",olng);
5337 CTO(INTEGER,"l_complete_schur_plet(2)",b);
5338 CTTO(PARTITION,INTEGER,"l_complete_schur_plet(3)",c);
5339 {
5340 OP part_inn,tmp;
5341 if(S_I_I(olng)<0L)
5342 {
5343 init(SCHUR,res);
5344 }
5345 else if(S_I_I(b)==0L)
5346 {
5347 erg += m_scalar_schur(cons_eins,res);
5348 }
5349 else if(S_I_I(b)<0L)
5350 {
5351 init(SCHUR,res);
5352 }
5353 else if ( (S_O_K(c)==INTEGER)&&(S_I_I(c)<=0L))
5354 {
5355 init(SCHUR,res);
5356 }
5357 else
5358 {
5359 part_inn=callocobject();
5360 if(S_O_K(c)==INTEGER)
5361 {
5362 erg += m_i_pa(c,part_inn);
5363 }
5364 else
5365 {
5366 COPY(c,part_inn);
5367 }
5368
5369 lng = (signed char)(S_I_I(olng));
5370 FREESELF(res);
5371 if(lng<S_PA_LI(part_inn))
5372 {
5373 init(SCHUR,res);
5374 }
5375 else
5376 {
5377 erg += cc_plethysm((signed char)(S_I_I(b)),
5378 part_inn,(signed char)0,res);
5379 lng = 127;
5380 }
5381 FREEALL(part_inn);
5382 }
5383 }
5384 ENDR("l_complete_schur_plet");
5385 }
5386
5387
complete_schur_plet(om,otab,res)5388 INT complete_schur_plet(om,otab,res) OP otab,res,om;
5389 /* CC 220596 */
5390 /* AK 210704 V3.0 */
5391 {
5392 INT erg = OK;
5393 CTO(INTEGER,"complete_schur_plet(1)",om);
5394 CTTO(PARTITION,INTEGER,"complete_schur_plet(2)",otab);
5395 {
5396 OP lgo=callocobject();
5397 M_I_I(127L,lgo);
5398 erg += l_complete_schur_plet(lgo,om,otab,res);
5399 FREEALL(lgo);
5400 }
5401 ENDR("complete_schur_plet");
5402 }
5403
5404
5405 /*l_elementary_schur_plet COMPUTES THE TERMS OF L_n(S_I)
5406 LESS THAN lng.*/
5407
l_elementary_schur_plet(olng,b,c,res)5408 INT l_elementary_schur_plet(olng,b,c,res) OP c,res,olng,b;
5409 {
5410 INT erg = OK;
5411 OP part_inn,tmp;
5412
5413 CTO(INTEGER,"l_elementary_schur_plet",olng);
5414 CTO(INTEGER,"l_elementary_schur_plet",b);
5415 CTTO(INTEGER,PARTITION,"l_elementary_schur_plet",b);
5416
5417 if(S_I_I(olng)<0L)
5418 {
5419 erg += init(SCHUR,res);
5420 goto endr_ende;
5421 }
5422 if(S_I_I(b)==0L)
5423 {
5424 erg += m_i_i(1L,res);
5425 goto endr_ende;
5426 }
5427 if(S_I_I(b)<0L)
5428 {
5429 erg += init(SCHUR,res);
5430 goto endr_ende;
5431 }
5432
5433 if(S_O_K(c)==INTEGER)
5434 {
5435 if(S_I_I(c)<=0L)
5436 {
5437 erg += init(SCHUR,res);
5438 goto endr_ende;
5439 }
5440 part_inn=callocobject();
5441 tmp=callocobject();
5442 erg += m_il_v(1L,tmp);
5443 M_I_I(S_I_I(c),S_V_I(tmp,0L));
5444 erg += b_ks_pa(VECTOR,tmp,part_inn);
5445 }
5446 else
5447 {
5448 part_inn=callocobject();
5449 erg += copy(c,part_inn);
5450 }
5451
5452 lng = (signed char)(S_I_I(olng));
5453 if(lng<S_PA_LI(part_inn))
5454 {
5455 erg += freeall(part_inn);
5456 erg += init(SCHUR,res);
5457 goto endr_ende;
5458 }
5459 if(not EMPTYP(res))
5460 erg += freeself(res);
5461
5462 erg += cc_plethysm((signed char)(S_I_I(b)),part_inn,(signed char)1,res);
5463 erg += freeall(part_inn);
5464 lng = 127;
5465 ENDR("l_elementary_schur_plet");
5466 }
5467
5468
elementary_schur_plet(om,otab,ores)5469 INT elementary_schur_plet(om,otab,ores) OP otab,ores,om;
5470 /* CC 220596 */
5471 {
5472 OP lgo;
5473 lgo=callocobject();
5474 M_I_I(127L,lgo);
5475 l_elementary_schur_plet(lgo,om,otab,ores);
5476 freeall(lgo);
5477 return OK;
5478 }
5479
5480
l_complete_complete_plet(lgo,om,c,ores)5481 INT l_complete_complete_plet(lgo,om,c,ores) OP lgo,c,ores,om;
5482 /* CC 220596 */
5483 /* AK 210704 V3.0 */
5484 {
5485 INT erg = OK;
5486 CTO(INTEGER,"l_complete_complete_plet(1)",lgo);
5487 CTO(INTEGER,"l_complete_complete_plet(2)",om);
5488 CTO(INTEGER,"l_complete_complete_plet(3)",c);
5489 {
5490 erg += l_complete_schur_plet(lgo,om,c,ores);
5491 }
5492 ENDR("l_complete_complete_plet");
5493 }
5494
5495
complete_complete_plet(om,otab,ores)5496 INT complete_complete_plet(om,otab,ores) OP otab,ores,om;
5497 /* CC 220596 */
5498 {
5499 INT erg = OK;
5500 OP c,lgo;
5501
5502 CTO(INTEGER,"complete_complete_plet(1)",om);
5503 CTO(INTEGER,"complete_complete_plet(2)",otab);
5504
5505 c = callocobject();
5506 lgo=callocobject();
5507 erg += m_i_pa(otab,c);
5508 M_I_I(127L,lgo);
5509 erg += l_complete_schur_plet(lgo,om,c,ores);
5510 erg += freeall(c);
5511 erg += freeall(lgo);
5512 CTO(SCHUR,"complete_complete_plet(3-ende)",ores);
5513 ENDR("complete_complete_plet");
5514 }
5515
5516
5517
l_schur_schur_plet(a,b,c,res)5518 INT l_schur_schur_plet(a,b,c,res)OP a,b,c,res;
5519 {
5520 signed char *binn,*bext,*inn,*ext,boo1,cond1;
5521 OP part_inn, part_ext,tmp;
5522 char lext,linn,i;
5523 struct liste lst[1];
5524 INT erg = OK;
5525 CTO(INTEGER,"l_schur_schur_plet(1)",a);
5526 CTTO(PARTITION,INTEGER,"l_schur_schur_plet(2)",b);
5527 CTTO(PARTITION,INTEGER,"l_schur_schur_plet(3)",c);
5528
5529
5530
5531 if(S_I_I(a)<0L)
5532 {
5533 init(SCHUR,res);
5534 return OK;
5535 }
5536
5537 if ((S_O_K(b) == PARTITION) && (S_PA_LI(b) == 1))
5538 {
5539 return (l_complete_schur_plet(a,S_PA_I(b,0),c,res));
5540 }
5541
5542 if(S_O_K(b)==INTEGER)
5543 return (l_complete_schur_plet(a,b,c,res));
5544
5545 if(S_O_K(c)==INTEGER)
5546 {
5547 if(S_I_I(c)<=0L)
5548 {
5549 init(SCHUR,res); return OK;
5550 }
5551 part_inn=callocobject();
5552 tmp=callocobject();
5553 m_il_v(1L,tmp);
5554 M_I_I(S_I_I(c),S_V_I(tmp,0L));
5555 b_ks_pa(VECTOR,tmp,part_inn);
5556 }
5557 else
5558 {
5559 part_inn=callocobject();
5560 copy(c,part_inn);
5561 }
5562 part_ext=callocobject();
5563 copy(b,part_ext);
5564 lng=(signed char)S_I_I(a);
5565 linn=(signed char)S_PA_LI(part_inn);
5566 lext=(signed char)S_PA_LI(part_ext);
5567 if(lext==0)
5568 {
5569 freeall(part_inn);freeall(part_ext);
5570 m_i_i(1L,res);
5571 return OK;
5572 }
5573 if(lng<linn)
5574 {
5575 freeall(part_inn);freeall(part_ext);
5576 init(SCHUR,res);
5577 return OK;
5578 }
5579 if(linn== 0)
5580 {
5581 freeall(part_inn);freeall(part_ext);
5582 init(SCHUR,res);
5583 return OK;
5584 }
5585 lext=(signed char)S_PA_LI(part_ext);
5586 ext=(signed char*)SYM_MALLOC(lext+1L);
5587 bext=ext;
5588 for(i=0;i<lext;i++)
5589 *bext++ = (signed char)S_PA_II(part_ext,i);
5590 *bext=0;
5591
5592 inn=(signed char*)SYM_MALLOC(linn+1L);
5593 binn=inn;
5594 for(i=0;i<linn;i++)
5595 *binn++ = (signed char)S_PA_II(part_inn,i);
5596 *binn=0;
5597
5598 boo1= *(bext-1);
5599 bext=ext;cond1=0;
5600 if(boo1<lext)
5601 {
5602 lext--;
5603 cond1=1;
5604 plet_conj(&bext,&lext);
5605 }
5606 if(not EMPTYP(res)) freeself(res);
5607 pl_schur_schur(inn,bext,cond1,0,0,lst);
5608
5609 t_list_SYM(lst,res);
5610
5611 freeall(part_inn);
5612 freeall(part_ext);
5613 SYM_free(inn); SYM_free(bext);
5614 return OK;
5615 ENDR("l_schur_schur_plet");
5616 }
5617
5618
schur_schur_plet(part_ext,part_inn,res)5619 INT schur_schur_plet(part_ext,part_inn,res) OP part_ext,part_inn,res;
5620 /* CC */
5621 /* AK 251198 V2.0 */
5622 {
5623 OP lgo;
5624 INT erg = OK;
5625 CTTO(INTEGER,PARTITION,"schur_schur_plet(1)",part_ext);
5626 CTTO(PARTITION,INTEGER,"schur_schur_plet(2)",part_inn);
5627 lgo=callocobject();
5628 M_I_I(127,lgo);
5629 erg += l_schur_schur_plet(lgo,part_ext,part_inn,res);
5630 erg += freeall(lgo);
5631 ENDR("schur_schur_plet");
5632 }
5633
5634 /*
5635 computes in res the decomposition of the plethysm
5636 S_b(S_c) for parts <=a.
5637 */
5638
mx_schur_schur_plet(a,b,c,res)5639 INT mx_schur_schur_plet(a,b,c,res) OP a,b,c,res;
5640 {
5641 signed char *binn,*bext,*inn,*ext,boo1,cond1;
5642 OP part_inn, part_ext,tmp;
5643 char lext,linn,i;
5644 struct liste lst[1];
5645
5646 if(S_O_K(a)!=INTEGER)
5647 return error("mx_schur_schur_plet: wrong first type");
5648
5649 if(S_O_K(b)!=INTEGER && S_O_K(b)!=PARTITION)
5650 return error("mx_schur_schur_plet: wrong second type");
5651
5652 if(S_O_K(c)!=INTEGER && S_O_K(c)!=PARTITION)
5653 return error("mx_schur_schur_plet: wrong third type");
5654
5655 if(S_I_I(a)<0L)
5656 {
5657 init(SCHUR,res);
5658 return OK;
5659 }
5660 if(S_O_K(b)==INTEGER)
5661 {
5662 if(S_I_I(b)<0L)
5663 {
5664 init(SCHUR,res);
5665 return OK;
5666 }
5667 if(S_I_I(b)==0L)
5668 {
5669 if(not EMPTYP(res)) freeself(res);
5670 M_I_I(1L,res);return OK;
5671 }
5672 }
5673
5674 if(S_O_K(c)==INTEGER)
5675 {
5676 if(S_I_I(c)<=0L)
5677 {
5678 init(SCHUR,res); return OK;
5679 }
5680 part_inn=callocobject();
5681 tmp=callocobject();
5682 m_il_v(1L,tmp);
5683 M_I_I(S_I_I(c),S_V_I(tmp,0L));
5684 b_ks_pa(VECTOR,tmp,part_inn);
5685 }
5686 else
5687 {
5688 part_inn=callocobject();
5689 copy(c,part_inn);
5690 }
5691 part_ext=callocobject();
5692 copy(b,part_ext);
5693 lng=(signed char)S_I_I(a);
5694 linn=(signed char)S_PA_LI(part_inn);
5695 lext=(signed char)S_PA_LI(part_ext);
5696 if(lext==0)
5697 {
5698 if(not EMPTYP(res)) freeself(res);
5699 freeall(part_inn);freeall(part_ext);
5700 M_I_I(1L,res);
5701 return OK;
5702 }
5703 if(lng<S_PA_II(part_inn,linn-1L))
5704 {
5705 freeall(part_inn);freeall(part_ext);
5706 init(SCHUR,res);
5707 return OK;
5708 }
5709 if(linn== 0)
5710 {
5711 freeall(part_inn);freeall(part_ext);
5712 init(SCHUR,res);
5713 return OK;
5714 }
5715 lext=(signed char)S_PA_LI(part_ext);
5716 ext=(signed char*)SYM_MALLOC(lext+1L);
5717 bext=ext;
5718 for(i=0;i<lext;i++)
5719 *bext++ = (signed char)S_PA_II(part_ext,i);
5720 *bext=0;
5721
5722 inn=(signed char*)SYM_MALLOC(linn+1L);
5723 binn=inn;
5724 for(i=0;i<linn;i++)
5725 *binn++ = (signed char)S_PA_II(part_inn,i);
5726 *binn=0;
5727
5728 boo1= *(bext-1);
5729 bext=ext;cond1=0;
5730 if(boo1<lext)
5731 {
5732 lext--;
5733 cond1=1;
5734 plet_conj(&bext,&lext);
5735 }
5736 if(not EMPTYP(res)) freeself(res);
5737 pl_schur_schur(inn,bext,cond1,0,1,lst);
5738
5739 t_list_SYM(lst,res);
5740
5741 SYM_free(inn);SYM_free(bext);
5742 freeall(part_inn);freeall(part_ext);
5743 return OK;
5744 }
5745
mx_power_schur_plet(mx,a,b,c)5746 INT mx_power_schur_plet(mx,a,b,c) OP mx,a,b,c;
5747 /*
5748 res is \psi_a(S_b) and restricts the result to partitions which biggest part
5749 is <= mx
5750 */
5751
5752 {
5753 OP on,os;
5754 if(S_O_K(mx)!=INTEGER) return error("mx_power_schur_plet: wrong first type");
5755 lng=S_I_I(mx);
5756 on=callocobject(); os=callocobject();
5757 m_il_v(0L,on); b_ks_pa(VECTOR,on,os);
5758 plth1(os,a,b,1,c);
5759 freeall(os); return OK;
5760 }
5761
5762
5763
l_power_schur_plet(ol,a,b,c)5764 INT l_power_schur_plet(ol,a,b,c) OP ol,a,b,c;
5765
5766 /*
5767 res is \psi_a(S_b) and restricts the result to partitions of length < ol
5768 */
5769
5770 {
5771 OP on,os;
5772 if(S_O_K(ol)!=INTEGER) return error("l_power_schur_plet: wrong first type");
5773 lng=S_I_I(ol);
5774 on=callocobject(); os=callocobject();
5775 m_il_v(0L,on); b_ks_pa(VECTOR,on,os);
5776 plth1(os,a,b,0,c);
5777 freeall(os); return OK;
5778 }
5779
power_schur_plet(a,b,c)5780 INT power_schur_plet(a,b,c) OP a,b,c;
5781 /* res is \psi_a(S_b) */
5782 {
5783 OP on,os;
5784 INT erg = OK;
5785 CTO(INTEGER,"power_schur_plet",a);
5786
5787 on=callocobject(); os=callocobject();
5788 erg += m_il_v(0L,on);
5789 erg += b_ks_pa(VECTOR,on,os);
5790 lng=127;
5791 plth1(os,a,b,0,c);
5792 erg += freeall(os);
5793 ENDR("power_schur_plet");
5794 }
5795
5796
schur_power_schur_plet_mult(a,b,c,d)5797 INT schur_power_schur_plet_mult(a,b,c,d) OP a,b,c,d;
5798
5799 /*
5800 res is S_a* \psi_b(S_c)
5801 */
5802
5803 {
5804 lng=127;
5805 plth1(a,b,c,0,d);
5806 return OK;
5807 }
5808
l_schur_power_schur_plet_mult(ol,a,b,c,d)5809 INT l_schur_power_schur_plet_mult(ol,a,b,c,d) OP ol,a,b,c,d;
5810
5811 /*
5812 res is S_a* \psi_b(S_c) for length <=a
5813 */
5814
5815 {
5816 if(S_O_K(ol)!=INTEGER) return error("l_schur_power_schur_plet: wrong first type");
5817 lng=S_I_I(ol);
5818 plth1(a,b,c,0,d);
5819 return OK;
5820 }
5821
mx_schur_power_schur_plet_mult(ol,a,b,c,d)5822 INT mx_schur_power_schur_plet_mult(ol,a,b,c,d) OP ol,a,b,c,d;
5823
5824 /*
5825 res is S_a* \psi_b(S_c) in the basis of Schur functions with parts <=a.
5826 */
5827
5828 {
5829 if(S_O_K(ol)!=INTEGER) return error("l_schur_power_schur_plet: wrong first type");
5830 lng=S_I_I(ol);
5831 plth5(a,b,c,1,d);
5832 return OK;
5833 }
5834
schur_powerproduct_schur_plet_mult(a,b,c,d)5835 INT schur_powerproduct_schur_plet_mult(a,b,c,d) OP a,b,c,d;
5836
5837 /*
5838 res is S_a* \psi_b(S_c) where a,b,c are partitions
5839 */
5840
5841 {
5842 lng=127;
5843 plth5(a,b,c,0,d);
5844 return OK;
5845 }
5846
l_schur_powerproduct_schur_plet_mult(ol,a,b,c,d)5847 INT l_schur_powerproduct_schur_plet_mult(ol,a,b,c,d) OP ol,a,b,c,d;
5848
5849 /*
5850 res is S_a* \psi_b(S_c) for length <=a, with a,b,c partitions
5851 */
5852
5853 {
5854 if(S_O_K(ol)!=INTEGER) return error("l_schur_power_schur_plet: wrong first type");
5855 lng=S_I_I(ol);
5856 plth5(a,b,c,0,d);
5857 return OK;
5858 }
5859
mx_schur_powerproduct_schur_plet_mult(ol,a,b,c,d)5860 INT mx_schur_powerproduct_schur_plet_mult(ol,a,b,c,d) OP ol,a,b,c,d;
5861
5862 /*
5863 res is S_a* \psi_b(S_c) in the basis of Schur functions with parts <=a,
5864 with a,b,c partitions.
5865 */
5866
5867 {
5868 if(S_O_K(ol)!=INTEGER) return error("l_schur_power_schur_plet: wrong first type");
5869 lng=S_I_I(ol);
5870 plth5(a,b,c,1,d);
5871 return OK;
5872 }
5873 /*
5874 puts in c the decomposition of the plethysm \psi^a(s_b)
5875 in the basis of Schur functions.
5876 a and b are partition or integer objects.
5877 */
5878
powerproduct_schur_plet(a,b,c)5879 INT powerproduct_schur_plet(a,b,c) OP a,b,c;
5880 {
5881 lng=127;
5882 return plth3(a,b,0,c);
5883 }
5884
5885 /*
5886 puts in c the decomposition of the plethysm \psi^a(s_b)
5887 in the basis of Schur functions restricted upon the length <= ol.
5888 a and b are partition or integer objects.
5889 */
5890
l_powerproduct_schur_plet(ol,a,b,c)5891 INT l_powerproduct_schur_plet(ol,a,b,c) OP a,b,c,ol;
5892 {
5893 if(S_O_K(ol) != INTEGER)
5894 return error ("l_powerproduct_schur_plet: Wrong first type");
5895 lng=S_I_I(ol);
5896 plth3(a,b,0,c);
5897 return OK;
5898 }
5899
5900 /*
5901 puts in c the decomposition of the plethysm \psi^a(s_b)
5902 in the basis of Schur functions restricted upon the parts <= mx.
5903 a and b are partition or integer objects.
5904 */
5905
mx_powerproduct_schur_plet(mx,a,b,c)5906 INT mx_powerproduct_schur_plet(mx,a,b,c) OP a,b,c,mx;
5907 {
5908 if(S_O_K(mx) != INTEGER)
5909 return error("mx_powerproduct_schur_plet: Wrong first type");
5910 lng=S_I_I(mx);
5911 plth3(a,b,1,c);
5912 return OK;
5913 }
5914
5915 /*
5916 puts in c the decomposition of the plethysm S_a(s_b)
5917 in the basis of Schur functions.
5918 a and b are partition or integer objects.
5919 */
5920
schur_schur_pletbis(a,b,c)5921 INT schur_schur_pletbis(a,b,c) OP a,b,c;
5922 {
5923 lng=127;
5924 plth4(a,b,0,c);
5925 return OK;
5926 }
5927
5928 /*
5929 puts in c the decomposition of the plethysm S_a(s_b)
5930 in the basis of Schur functions restricted upon the length <= ol.
5931 a and b are partition or integer objects.
5932 */
5933
l_schur_schur_pletbis(ol,a,b,c)5934 INT l_schur_schur_pletbis(ol,a,b,c) OP a,b,c,ol;
5935 {
5936 if(S_O_K(ol) != INTEGER)
5937 return error ("l_schur_schur_pletbis: Wrong first type");
5938 lng=S_I_I(ol);
5939 plth4(a,b,0,c);
5940 return OK;
5941 }
5942
5943 /*
5944 puts in c the decomposition of the plethysm S^a(s_b)
5945 in the basis of Schur functions restricted upon the parts <= mx.
5946 a and b are partition or integer objects.
5947 */
5948
mx_schur_schur_pletbis(mx,a,b,c)5949 INT mx_schur_schur_pletbis(mx,a,b,c) OP a,b,c,mx;
5950 {
5951 if(S_O_K(mx) != INTEGER)
5952 return error("mx_schur_schur_pletbis: Wrong first type");
5953 lng=S_I_I(mx);
5954 plth4(a,b,1,c);
5955 return OK;
5956 }
5957
power_schur_plet_old(jvalu,part,res)5958 INT power_schur_plet_old(jvalu,part,res) OP part,jvalu,res;
5959 /* CC 0589 */ /* AK 181289 V1.1 */
5960 /* AK 200891 V1.3 */
5961 {
5962 OP a,b,e,f,d,z;
5963 OP gl = callocobject(); /* global list */
5964
5965 signed char i, n,temp,max;
5966 signed char *btab,*baf,*af,tab[50];
5967
5968 if (not EMPTYP(res)) freeself(res);
5969 if (einsp(jvalu)) { m_pa_s(part,res); return(OK); }
5970
5971 for(i=0;i<S_PA_LI(part);i++) tab[(int) i]=( signed char)S_PA_II(part,(INT)i);
5972
5973 n = ( signed char)S_I_I(jvalu);
5974 temp = 0; btab = tab;
5975
5976 temp = ( signed char)S_PA_LI(part);
5977 max = temp * n;
5978
5979 btab = tab;
5980 baf = ( signed char *)SYM_MALLOC(max);
5981 if (baf == NULL) return no_memory();
5982 af = baf;
5983
5984 for(i = 0; i < max - temp ; i++) { *baf = (n*i)-i; baf++; }
5985 for(; i < max; i++)
5986 {
5987 *baf = (n * ((*btab) + i)) - i;
5988 baf++; btab++;
5989 }
5990 baf = af;
5991
5992 b_skn_s(callocobject(),callocobject(),NULL,gl);
5993 M_I_I(1L,S_S_K(gl));
5994 b_ks_pa(VECTOR,callocobject(),S_S_S(gl));
5995
5996 if (max >1) m_il_v((INT)max-1,S_PA_S(S_S_S(gl)));
5997 else m_il_v(1L,S_PA_S(S_S_S(gl)));
5998
5999 baf = af;
6000 if (max>1)baf++;
6001 if(max > 1)
6002 for (i=0;i<max-1;i++)
6003 M_I_I((INT)(*baf++) ,S_PA_I(S_S_S(gl),(INT)i));
6004 else M_I_I((INT)(*baf++) ,S_PA_I(S_S_S(gl),0L));
6005
6006 a = callocobject(); /* part 1 */
6007 b = callocobject(); /* part 2*/
6008 d = callocobject(); /* result */
6009 e = callocobject(); /*limit*/
6010
6011 b_ks_pa(VECTOR,callocobject(),a);
6012 b_ks_pa(VECTOR,callocobject(),b);
6013 if(max>1)
6014 m_il_v((INT)max-1,S_PA_S(b));
6015 else
6016 m_il_v(1L,S_PA_S(b));
6017 if(max>1)
6018 for(i=1;i<max;i++)
6019 M_I_I((INT)(i*n - i ),S_PA_I(b,(INT)i-1));
6020 else M_I_I(1L,S_PA_I(b,0L));
6021 marke:
6022 if (not EMPTYP(gl))
6023 if (S_L_S(gl) != NULL)
6024 {
6025 INT zz,kk;
6026 z = S_S_S(gl);
6027 kk = max - S_PA_LI(z);
6028 for (i=0;i<S_PA_LI(z);i++)
6029 if (S_PA_II(z,(INT)i) > (INT)(i+kk)*(n-1) ) break;
6030
6031 m_il_v(S_PA_LI(z)-i,S_PA_S(a));
6032 for (zz=0;zz<S_PA_LI(a);zz++,i++)
6033 M_I_I(S_PA_II(z,(INT)i)-(i+kk)*(n-1),S_PA_I(a,zz));
6034
6035 }
6036 else goto ende;
6037 else goto ende;
6038
6039 M_I_I((INT)max,e);
6040 outerproduct_schur_limit(a,b,d,e);
6041 /*Remove the dominant terms */
6042
6043
6044
6045 mult (d, S_S_K(gl), d);
6046 f = callocobject();
6047 m_skn_s(a,S_S_K(gl),NULL,f);
6048 add_apply(f,res);
6049 addinvers(d,f);
6050 insert(f,gl,add_koeff,comp_colex_schurmonom);
6051 goto marke;
6052
6053 ende:
6054 freeall(a); freeall(b); freeall(d); freeall(e); SYM_free(af);
6055 return OK;
6056 }
6057
6058 #endif /* PLETTRUE */
6059
6060 #ifdef PLETTRUE
test_plet()6061 INT test_plet()
6062 {
6063 OP a,b,c;
6064 a = callocobject();
6065 b = callocobject();
6066 c = callocobject();
6067 printeingabe("test_plet:complete_complete_plet(3L,3L,c)");
6068 m_i_i(3L,a);
6069 m_i_i(3L,b);
6070 complete_complete_plet(a,b,c);
6071 println(c);
6072 printeingabe("test_plet:complete_schur_plet(3L,PARTITION,c)");
6073 scan(PARTITION,b);
6074 complete_schur_plet(a,b,c);
6075 println(c);
6076 printeingabe("test_plet:power_schur_plet_old(2L,PARTITION,c)");
6077 scan(PARTITION,b);
6078 power_schur_plet_old(cons_zwei,b,c);
6079 println(c);
6080 printeingabe("test_plet:schur_schur_plet(PARTITION,PARTITION,c)");
6081 scan(PARTITION,a);
6082 scan(PARTITION,b);
6083 schur_schur_plet(a,b,c);
6084 println(c);
6085 freeall(a);
6086 freeall(b);
6087 freeall(c);
6088 return OK;
6089 }
6090
plethysm_schur_schur(a,b,c)6091 INT plethysm_schur_schur(a,b,c) OP a,b,c;
6092 /* AK 190299 */
6093 {
6094 INT erg = OK;
6095 CTO(SCHUR,"plethysm_schur_schur",a);
6096 CTO(SCHUR,"plethysm_schur_schur",b);
6097
6098 if ((S_S_N(a) != NULL) || (S_S_SLI(a) != 1))
6099 {
6100 error("plethysm_schur_schur:for the moment only for outer S_n");
6101 goto endr_ende;
6102 }
6103 if (S_S_N(b) != NULL)
6104 {
6105 error("plethysm_schur_schur:for the moment only for inner single S_I");
6106 goto endr_ende;
6107 }
6108
6109 erg += schur_schur_plet(S_S_SI(a,0), S_S_S(b) ,c);
6110
6111 ENDR("plethysm_schur_schur");
6112 }
6113
6114
6115
6116 static INT plet_sn_mI();
6117 static INT plet_sn_MONOMIAL();
6118 static INT inc_weight_monomial();
6119
plethysm_schur_monomial(a,b,c)6120 INT plethysm_schur_monomial(a,b,c) OP a,b,c;
6121 /* AK 190299 */
6122 {
6123 INT erg = OK;
6124 CTO(SCHUR,"plethysm_schur_monomial(1)",a);
6125 CTO(MONOMIAL,"plethysm_schur_monomial(2)",b);
6126
6127 if ((S_S_N(a) != NULL) || (S_S_SLI(a) != 1))
6128 {
6129 error("plethysm_schur_monomial: for the moment only for S_n");
6130 goto endr_ende;
6131 }
6132
6133 erg += plet_sn_MONOMIAL(S_S_SI(a,0), b,c);
6134
6135 ENDR("plethysm_schur_monomial");
6136 }
6137
6138
plet_sn_MONOMIAL(OP n,OP I,OP r)6139 static INT plet_sn_MONOMIAL(OP n, OP I, OP r)
6140 /* compute s_n[m_I] in the basis of monomial */
6141 {
6142 INT erg = OK;
6143 OP l;
6144 OP n1,n2,h1,h2;
6145 OP z2 = S_S_N(I);
6146 OP z1;
6147 INT i,wi;
6148
6149 CTO(INTEGER,"plet_sn_MONOMIAL",n);
6150 CTO(MONOMIAL,"plet_sn_MONOMIAL",I);
6151
6152 l = callocobject();
6153 length(I,l);
6154 if (einsp(l))
6155 {
6156 if (einsp(S_S_K(I)))
6157 plet_sn_mI(n,S_S_S(I),r);
6158 else {
6159 CTO(INTEGER,"plet_sn_MONOMIAL:non integer coefficient",S_S_K(I));
6160
6161 init(MONOMIAL,r);
6162 h1 = callocobject();
6163 h2 = callocobject(); /* composition */
6164 n1 = callocobject(); /* faktor = binom */
6165 z2 = callocobject();
6166 first_composition(n,n,h2);
6167 do {
6168 z1 = callocobject();
6169 m_i_i(0,h1);wi=0;
6170 for (i=0;i<S_V_LI(h2);i++)
6171 {
6172 if (S_V_II(h2,i) != 0) {
6173 wi += S_V_II(h2,i);
6174 if (S_I_I(h1) == 0)
6175 {
6176 plet_sn_mI(S_V_I(h2,i), S_S_S(I), z1);
6177 }
6178 else {
6179 plet_sn_mI(S_V_I(h2,i), S_S_S(I), z2);
6180 mult_apply(z2,z1);
6181 }
6182 INC_INTEGER(h1);
6183 }
6184 else break;
6185 }
6186 if (wi == S_I_I(n)) {
6187 binom(S_S_K(I),h1,n1);
6188 if (nullp(n1)) {
6189 freeall(z1);
6190 }
6191 else {
6192 mult_apply(n1,z1);
6193 insert(z1,r,NULL,NULL);
6194 }
6195 }
6196 else freeall(z1);
6197 } while(next(h2,h2));
6198
6199 freeall(n1);
6200 freeall(h1);
6201 freeall(h2);
6202 freeall(z2);
6203 }
6204 }
6205 else
6206 {
6207
6208 init(MONOMIAL,r);
6209 h1 = callocobject();
6210 n1 = callocobject();
6211 n2 = callocobject();
6212 z1 = callocobject();
6213 m_pa_mon(S_S_S(I),z1);
6214 copy(S_S_K(I),S_S_K(z1));
6215
6216 for (i=1;i<S_I_I(n);i++)
6217 {
6218 h2 = callocobject();
6219 M_I_I(i,n1);
6220 M_I_I(S_I_I(n)-i,n2);
6221 plet_sn_MONOMIAL(n1,z1,h1);
6222 plet_sn_MONOMIAL(n2,z2,h2);
6223 mult_apply(h1,h2);
6224 insert(h2,r,NULL,NULL);
6225 }
6226 plet_sn_MONOMIAL(n,z1,h1); insert(h1,r,NULL,NULL);
6227 plet_sn_MONOMIAL(n,z2,z1); insert(z1,r,NULL,NULL);
6228
6229 freeall(n1);
6230 freeall(n2);
6231 }
6232 freeall(l);
6233 ENDR("plet_sn_MOMOMIAL");
6234 }
6235
ak_plet_phm_integer_partition_(a,b,c,f)6236 INT ak_plet_phm_integer_partition_(a,b,c,f) OP a,b,c,f;
6237 {
6238 OP m;
6239 INT erg = OK;
6240 CTO(INTEGER,"ak_plet_phm_integer_partition_(1)",a);
6241 CTO(PARTITION,"ak_plet_phm_integer_partition_(2)",b);
6242 m = CALLOCOBJECT();
6243 plet_sn_mI(a,b,m);
6244 MULT_APPLY(f,m);
6245 if (S_O_K(c) == MONOMIAL)
6246 insert_list_list(m,c,add_koeff,comp_monommonomial);
6247 else
6248 insert_monomial_hashtable(m,c,add_koeff,eq_monomsymfunc,hash_monompartition);
6249 ENDR("ak_plet_phm_integer_partition_");
6250 }
6251
plet_sn_mI(OP n,OP I,OP r)6252 static INT plet_sn_mI(OP n, OP I, OP r)
6253 /* compute s_n[m_I] in the basis of monomial */
6254 {
6255 INT i,j;
6256 OP parts,v;
6257 INT erg = OK;
6258 static int recdeb=0;
6259 CTO(INTEGER,"plet_sn_mI(1)",n);
6260 CTO(PARTITION,"plet_sn_mI(2)",I);
6261 if (S_I_I(n)< 0) { error("plet_sn_mI: defined for n>=0");goto endr_ende; }
6262
6263 if (S_PA_LI(I) == 0) {
6264 m_pa_mon(I,r);
6265 goto ende;
6266 }
6267 if (S_I_I(n) == 0) {
6268 m_pa_mon(I,r);
6269 first_partition(cons_null,S_S_S(r));
6270 M_I_I(1,S_S_K(r));
6271 goto ende;}
6272 if (S_I_I(n) == 1) {
6273 m_pa_mon(I,r);
6274 goto ende;
6275 }
6276 /* loop over all partitions with parts from I and length <= n */
6277 j=1;for (i=1;i<S_PA_LI(I);i++) if (S_PA_II(I,i) != S_PA_II(I,i-1)) j++;
6278 /* is the number of different parts */
6279 parts = callocobject();m_il_v(j,parts);
6280 M_I_I(S_PA_II(I,0),S_V_I(parts,0));
6281 j=1;for (i=1;i<S_PA_LI(I);i++)
6282 if (S_PA_II(I,i) != S_PA_II(I,i-1))
6283 { M_I_I(S_PA_II(I,i),S_V_I(parts,j));j++; }
6284 /* parts is the vector with the different parts, increasing */
6285
6286 /* first partition */
6287 v = callocobject();
6288 m_il_v(S_I_I(n),v);
6289 for (i=0;i<S_V_LI(v);i++) M_I_I(S_V_LI(parts),S_V_I(v,i));
6290
6291
6292 init(MONOMIAL,r);
6293 do {
6294 INT w;
6295 OP level = callocobject();
6296 init(MONOMIAL,level);
6297 /* check auf gewicht */
6298 w = 0; for (i=0;i<S_V_LI(v);i++) if (S_V_II(v,i)) w += S_V_II(parts,S_V_II(v,i)-1);
6299 if (w < S_PA_II(I,S_PA_LI(I)-1)) goto next;
6300 /* es werden nur solche genommen, wo das gewicht >= maximalen teil */
6301
6302 j = 0;
6303 for (i=1;i<=S_V_LI(v);i++)
6304 {
6305 if ((i == S_V_LI(v)) || (S_V_II(v,i) != S_V_II(v,i-1)))
6306 {
6307 INT k;
6308 OP new_I = callocobject();
6309 OP new_n = callocobject();
6310 OP new_r = callocobject();
6311 /* von j bis i ein block */
6312
6313 copy(S_PA_S(I),new_I);
6314
6315
6316
6317 for (k=0;k<S_V_LI(new_I);k++)
6318 if (S_V_II(v,i-1)>0) /* AK 121201 */
6319 if (S_V_II(new_I,k) == S_V_II(parts,S_V_II(v,i-1)-1))
6320 { M_I_I(0,S_V_I(new_I,k)); break; }
6321
6322
6323 m_v_pa(new_I,new_I);
6324 /* check ob das gewicht stimmt */
6325 M_I_I(i-j,new_n);
6326 recdeb++;
6327 if ((S_PA_LI(new_I) == 0) || (S_I_I(new_n) == 1) ) { /* AK 121201 */
6328 m_pa_mon(new_I,new_r);
6329 }
6330 else
6331 plet_sn_mI(new_n,new_I,new_r);
6332 recdeb--;
6333 if (j==0) swap(new_r,level);
6334 else mult_apply_monomial_monomial(new_r,level);
6335
6336
6337 j = i;
6338 freeall(new_I);
6339 freeall(new_n);
6340 freeall(new_r);
6341 }
6342 }
6343 /* jetzt den level um das teil w erweitern */
6344
6345 inc_weight_monomial(w,level);
6346
6347 erg += add_apply(level,r);
6348
6349
6350 {
6351 next: /* next */
6352 for (i=0;i<S_V_LI(v);i++)
6353 if (S_V_II(v,i) > 0) { DEC_INTEGER(S_V_I(v,i)); j = S_V_II(v,i); i--; break; }
6354 for (;i>=0;i--) M_I_I(j,S_V_I(v,i));
6355 }
6356 freeall(level);
6357 } while (not nullp(v));
6358 erg += freeall(v); freeall(parts);
6359 ende:
6360 CTO(INTEGER,"plet_sn_mI(1)",n);
6361 CTO(PARTITION,"plet_sn_mI(2)",I);
6362 CTO(MONOMIAL,"plet_sn_mI(3-ende)",r);
6363 /*
6364 {
6365 OP z,d = callocobject(),w=callocobject(); weight(I,d); mult_apply(n,d);
6366 FORALL(z,r, {
6367 weight(S_MO_S(z),w); if (neq(w,d)) error("");
6368 } );
6369 freeall(w); freeall(d);
6370 }
6371 */
6372 ENDR("plet_sn_mI");
6373 }
6374
inc_weight_monomial(INT w,OP s)6375 static INT inc_weight_monomial(INT w, OP s)
6376 {
6377 OP z;
6378 OP r = callocobject();
6379 init(MONOMIAL,r);
6380 FORALL(z,s,{
6381 if ((S_PA_LI(S_MO_S(z)) == 0) || (S_PA_II(S_MO_S(z), S_PA_LI(S_MO_S(z))-1) <= w))
6382 {
6383 OP p = callocobject();
6384 copy(S_MO_S(z),p);
6385 inc(p);
6386 M_I_I(w,S_PA_I(p,S_PA_LI(p)-1));
6387 m_pa_mon(p,p);
6388 copy(S_MO_K(z),S_S_K(p));
6389 insert(p,r,NULL,NULL);
6390 }
6391 });
6392 swap(r,s);
6393 freeall(r);
6394 return OK;
6395 }
6396
6397 INT p2_schursum();
p_schursum(a,b,c,f,schurf,partf,multf)6398 INT p_schursum(a,b,c,f,schurf,partf,multf)
6399 OP a,b,c,f;
6400 INT (*schurf)(), (*partf)(), (*multf)();
6401 /* AK 101201 for the expansion S_I[P+Q] */
6402 {
6403 return p2_schursum(a,b,c,f,-1,schurf,partf,multf);
6404 #ifdef UNDEF
6405 INT erg = OK;
6406 /* loop over all partitions smaller then a */
6407 /* S_a[b1+b2] = \sum_d<a S_a/d [b1] * S_d[b2] */
6408 OP b2,b1;
6409 INT w=0;
6410 INT i;
6411
6412 CTTO(PARTITION,INTEGER,"p_schursum(1)",a);
6413 CTTO(HASHTABLE,SCHUR,"p_schursum(2)",b);
6414 SYMCHECK((S_O_K(a)==PARTITION)&&(S_PA_LI(a) == 0), "p_schursum:partion of weight 0 ");
6415
6416 if (S_O_K(b) == SCHUR) {
6417 b2 = S_S_N(b);
6418 C_S_N(b,NULL);
6419 b1 = b;
6420 SYMCHECK( ( b2 == NULL) ,"p_schursum(1):no real sum");
6421 }
6422 else { /* HASHTABLE */
6423 SYMCHECK(WEIGHT_HASHTABLE(b) <= 1,"p_schursum(2):no real sum");
6424 b1 = CALLOCOBJECT();
6425 b2 = CALLOCOBJECT();
6426 split_hashtable(b,b1,b2);
6427 }
6428
6429 /* both limits to the sum */
6430 (*partf)(a,b1,c,f);
6431 (*partf)(a,b2,c,f);
6432
6433 if (S_O_K(a) == PARTITION) {
6434 for (i=0;i<S_PA_LI(a);i++) w+= S_PA_II(a,i);
6435
6436 for (i=1;i<w;i++)
6437 {
6438 OP h,p;
6439 h = CALLOCOBJECT(); M_I_I(i,h);
6440 p = CALLOCOBJECT(); first_partition(h,p);
6441 do {
6442 if (contain_comp_part(p,a)) {
6443 OP h1,h2,s1;
6444 NEW_HASHTABLE(h1);
6445 NEW_HASHTABLE(h2);
6446 NEW_HASHTABLE(s1);
6447 part_part_skewschur(a,p,s1);
6448 (*schurf)(s1,b1,h1,cons_eins);
6449 (*partf)(p,b2,h2,cons_eins);
6450 (*multf)(h1,h2,c,f);
6451 FREEALL(h1);
6452 FREEALL(h2);
6453 FREEALL(s1);
6454 }
6455 } while(next_apply(p));
6456
6457 FREEALL(h);
6458 FREEALL(p);
6459 }
6460 }
6461 else /* INTEGER */ {
6462 OP h,p;
6463 h = CALLOCOBJECT();
6464 p = CALLOCOBJECT();
6465 for (i=1;i<S_I_I(a);i++)
6466 {
6467 OP h1,h2;
6468 NEW_HASHTABLE(h1);
6469 NEW_HASHTABLE(h2);
6470 M_I_I(i,h);
6471 M_I_I(S_I_I(a)-i,p);
6472 (*partf)(p,b1,h1,cons_eins);
6473 (*partf)(h,b2,h2,cons_eins);
6474 (*multf)(h1,h2,c,f);
6475 FREEALL(h1);
6476 FREEALL(h2);
6477 }
6478 FREEALL(h);
6479 FREEALL(p);
6480 }
6481
6482 if (S_O_K(b) == SCHUR) { C_S_N(b,b2); }
6483 else /* HASHTABLE */ { FREEALL(b1); FREEALL(b2); }
6484 ENDR("p_schursum");
6485 #endif
6486 }
6487
6488
p2_schursum(a,b,c,f,m,schurf,partf,multf)6489 INT p2_schursum(a,b,c,f,m,schurf,partf,multf)
6490 OP a,b,c,f; INT m;
6491 INT (*schurf)(), (*partf)(), (*multf)();
6492 /* AK 101201 for the expansion S_I[P+Q] */
6493 /* wie p_schursum mit INT als limit */
6494 {
6495 INT erg = OK;
6496 /* loop over all partitions smaller then a */
6497 /* S_a[b1+b2] = \sum_d<a S_a/d [b1] * S_d[b2] */
6498 OP b2,b1;
6499 INT w=0;
6500 INT i;
6501 INT split_hashtable();
6502
6503 CTTO(PARTITION,INTEGER,"p2_schursum(1)",a);
6504 CTTO(HASHTABLE,SCHUR,"p2_schursum(2)",b);
6505 SYMCHECK((S_O_K(a)==PARTITION)&&(S_PA_LI(a) == 0), "p2_schursum:partion of weight 0 ");
6506
6507 if (S_O_K(b) == SCHUR) {
6508 b2 = S_S_N(b);
6509 C_S_N(b,NULL);
6510 b1 = b;
6511 SYMCHECK( ( b2 == NULL) ,"p2_schursum(1):no real sum");
6512 }
6513 else { /* HASHTABLE */
6514 SYMCHECK(WEIGHT_HASHTABLE(b) <= 1,"p2_schursum(2):no real sum");
6515 b1 = CALLOCOBJECT();
6516 b2 = CALLOCOBJECT();
6517 split_hashtable(b,b1,b2);
6518 }
6519
6520 /* both limits to the sum */
6521 (*partf)(a,b1,c,f,m);
6522 (*partf)(a,b2,c,f,m);
6523
6524 if (S_O_K(a) == PARTITION) {
6525 for (i=0;i<S_PA_LI(a);i++) w+= S_PA_II(a,i);
6526
6527 for (i=1;i<w;i++)
6528 {
6529 OP h,p;
6530 h = CALLOCOBJECT(); M_I_I(i,h);
6531 p = CALLOCOBJECT(); first_partition(h,p);
6532 do {
6533 if (contain_comp_part(p,a)) {
6534 OP h1,h2,s1;
6535 NEW_HASHTABLE(h1);
6536 NEW_HASHTABLE(h2);
6537 NEW_HASHTABLE(s1);
6538 part_part_skewschur(a,p,s1);
6539 (*schurf)(s1,b1,h1,cons_eins,m);
6540 (*partf)(p,b2,h2,cons_eins,m);
6541 (*multf)(h1,h2,c,f,m);
6542 FREEALL(h1);
6543 FREEALL(h2);
6544 FREEALL(s1);
6545 }
6546 } while(next_apply(p));
6547
6548 FREEALL(h);
6549 FREEALL(p);
6550 }
6551 }
6552 else /* INTEGER */ {
6553 OP h,p;
6554 h = CALLOCOBJECT();
6555 p = CALLOCOBJECT();
6556 for (i=1;i<S_I_I(a);i++)
6557 {
6558 OP h1,h2;
6559 NEW_HASHTABLE(h1);
6560 NEW_HASHTABLE(h2);
6561 M_I_I(i,h);
6562 M_I_I(S_I_I(a)-i,p);
6563 (*partf)(p,b1,h1,cons_eins,m);
6564 (*partf)(h,b2,h2,cons_eins,m);
6565 (*multf)(h1,h2,c,f,m);
6566 FREEALL(h1);
6567 FREEALL(h2);
6568 }
6569 FREEALL(h);
6570 FREEALL(p);
6571 }
6572
6573 if (S_O_K(b) == SCHUR) { C_S_N(b,b2); }
6574 else /* HASHTABLE */ { FREEALL(b1); FREEALL(b2); }
6575 ENDR("p2_schursum");
6576 }
6577
6578 #endif /* PLETTRUE */
6579