1 /* nc.c SYMMETRICA source code */
2 #include "def.h"
3 #include "macro.h"
4
5 static INT m_nc_sym();
6 static INT m_nc_alt();
7
8 /* PF 060292 */ /* PF 040692 */
9 /***********************************************************************/
10 /* */
11 /* Diese Routine berechnet den Vektor der Konjugiertenklassen */
12 /* der An. */
13 /* Rueckgabewert: OK oder error */
14 /* */
15 /***********************************************************************/
16
ak_make_alt_classes(n,res)17 INT ak_make_alt_classes(n,res)
18 OP n; /* Gewicht der Partitionen */
19 OP res; /* Vektor der Konjugiertenklassen der An */
20 {
21 OP par; /* Partition von n */
22 OP per; /* Permutation */
23 OP sgn; /* Signum der Permutation */
24 OP l; /* Anzahl der verschiedenen Konjugiertenklassen der An */
25 INT i=0L;
26 INT erg=OK;
27
28 INT alt_dimension(); /* Hilfsroutinen */
29 INT split();
30
31
32 CTO(INTEGER,"ak_make_alt_classes(1)",n);
33
34 FREESELF(res);
35
36 /*** Test auf Ganzzahligkeit von n ************************************/
37
38 SYMCHECK (S_I_I(n) <= 0, "ak_make_alt_classes : n <= 0");
39
40 /*** Speicherplatzreservierung fuer die Objekte ***********************/
41
42 par=callocobject();
43 per=callocobject();
44 sgn=callocobject();
45 l=callocobject();
46
47 /*** Berechnung des Partitionenvektors (eigentlich eine Matrix) *********/
48
49 erg += alt_dimension(n,l);
50 erg += m_il_v(S_I_I(l),res);
51 erg += first_partition(n,par);
52 do {
53 erg += m_part_perm(par,per);
54 erg += signum(per,sgn);
55 if(S_I_I(sgn) == 1L)
56 {
57 if(split(n,par)==1L)
58 {
59 m_il_v(2L,S_V_I(res,i));
60 erg += copy(par,S_V_I(S_V_I(res,i),0L));
61 erg += m_i_i(0L,S_V_I(S_V_I(res,i),1L));
62 i++;
63 m_il_v(2L,S_V_I(res,i));
64 erg += copy(par,S_V_I(S_V_I(res,i),0L));
65 erg += m_i_i(1L,S_V_I(S_V_I(res,i),1L));
66 }
67 else {
68 erg += copy(par,S_V_I(res,i));
69 }
70 i++;
71 }
72 }
73 while(next(par,par));
74
75 /*** Speicherplatzfreigabe *********************************************/
76
77 erg += freeall(par);
78 erg += freeall(per);
79 erg += freeall(sgn);
80 erg += freeall(l);
81
82 /*** Rueckkehr in die aufrufende Routine *******************************/
83
84 ENDR("ak_make_alt_classes");
85 } /* Ende von make_alt_classes */
86
ak_make_alt_partitions(n,res)87 INT ak_make_alt_partitions(n,res)
88 OP n; /* Gewicht der Partitionen */
89 OP res; /* Vektor der irred. Darst. der An */
90 {
91 OP par; /* Partition von n */
92 OP conpar; /* konjugierte Partition */
93 OP l; /* Anzahl der verschiedenen irred. Darst. der An */
94 INT i=0L,j;
95 INT erg=OK;
96
97 INT alt_dimension(); /* Hilfsroutinen */
98 INT part_comp();
99
100
101 /*** Test auf Ganzzahligkeit von n ************************************/
102
103 CTO(INTEGER,"ak_make_alt_partitions",n);
104 if (S_I_I(n) <= 0L)
105 {
106 error("ak_make_alt_partitions : n <= 0");
107 return ERROR;
108 }
109
110 /*** Speicherplatzreservierung fuer die Objekte **********************/
111
112 par=callocobject();
113 conpar=callocobject();
114 l=callocobject();
115
116 /*** Berechnung des Partitionenvektors (eigentlich eine Matrix) *******/
117
118 erg += alt_dimension(n,l);
119 erg += m_il_v(S_I_I(l),res);
120 erg += first_partition(n,par);
121 do {
122 erg += conjugate(par,conpar);
123 j=part_comp(par,conpar);
124 if(j==0L)
125 /* zerfaellt */
126 {
127 erg += m_il_v(2L,S_V_I(res,i));
128 erg += copy(par,S_V_I(S_V_I(res,i),0L));
129 erg += m_i_i(0L,S_V_I(S_V_I(res,i),1L));
130 i++;
131 erg += m_il_v(2L,S_V_I(res,i));
132 erg += copy(par,S_V_I(S_V_I(res,i),0L));
133 erg += m_i_i(1L,S_V_I(S_V_I(res,i),1L));
134 i++;
135 }
136 else if (j>0L) {
137 /* zerfaellt nicht */
138 erg += copy(par,S_V_I(res,i));
139 i++;
140 }
141 }
142 while(next_apply(par));
143
144 /*** Speicherplatzfreigabe *********************************************/
145 FREEALL3(par,conpar,l);
146 /*** Rueckkehr in die aufrufende Routine *******************************/
147
148 ENDR("ak_make_alt_partitions");
149 }
150
scan_gl_nc(a,b)151 INT scan_gl_nc(a,b) OP a,b;
152 /* AK 100692 */
153 {
154 OBJECTKIND k;
155 INT i,erg = OK;
156 OP c;
157 CTO(EMPTY,"scan_gl_nc(2)",b);
158
159 c = callocobject();
160 erg += printeingabe("input of a character");
161 erg += printeingabe("grouplabel = "); println(a);
162 erg += m_il_v(2L,b); copy(a,S_NC_GL(b));
163 erg += printeingabe("type of charactervalues");
164 k = scanobjectkind();
165 erg += m_gl_cl(a,c);
166 erg += m_il_v(S_V_LI(c),S_NC_C(b));
167 for (i=0L;i<S_V_LI(c);i++)
168 {
169 erg += println(S_V_I(c,i));
170 erg += scan(k,S_V_I(S_NC_C(b),i));
171 }
172 erg += freeall(c);
173 ENDR("scan_gl_nc");
174 }
175
176 #ifdef CHARTRUE
reduce_nc(a,b)177 INT reduce_nc(a,b) OP a,b;
178 {
179 OP c,d;
180 INT i, erg=OK;
181 CTO(VECTOR,"reduce_nc(1)",a);
182 c =callocobject();
183 d =callocobject();
184 erg += m_gl_il(S_NC_GL(a),c);
185 erg += copy(a,b);
186 for (i=0L;i<S_V_LI(c);i++)
187 {
188 erg += m_gl_nc(S_NC_GL(a),S_V_I(c,i),d);
189 erg += scalarproduct_nc(d,a,S_V_I(S_NC_C(b),i));
190 }
191 FREEALL2(c,d);
192 ENDR("reduce_nc");
193 }
194
195
196
scalarproduct_nc(a,b,c)197 INT scalarproduct_nc(a,b,c) OP a,b,c;
198 {
199 OP d,e;
200 INT erg = OK;
201
202 d = callocobject();
203 e = callocobject();
204 erg += mult(S_NC_C(a),S_NC_C(b),d);
205 erg += m_gl_co(S_NC_GL(a),e);
206 erg += mult_apply(e,d);
207 erg += SYM_sum(d,e);
208 erg += m_gl_go(S_NC_GL(a),d);
209 erg += div(e,d,c);
210 erg += freeall(e);
211 erg += freeall(d);
212 return erg;
213 }
214 #endif /* CHARTRUE */
m_gl_go(a,b)215 INT m_gl_go(a,b) OP a,b;
216 /* grouporder */
217 {
218 INT erg;
219 if (SYM_GL(a))
220 return fakul(S_GL_SYM_A(a),b);
221 if (ALT_GL(a))
222 {
223 erg = fakul(S_GL_ALT_A(a),b);
224 if (not einsp(b)) /* sonderfall a1 */
225 erg += ganzdiv(b,cons_zwei,b);
226 return erg;
227 }
228 if (CYCLIC_GL(a)) /* AK 291092 */
229 return copy(S_GL_CYCLIC_A(a),b);
230 #ifdef KRANZTRUE
231 if (KRANZ_GL(a))
232 {
233 return grouporder_kranz(a,b);
234 }
235 #endif /* KRANZTRUE */
236 return error("can not compute grouporder");
237 }
238
239 #ifdef CHARTRUE
m_gl_il(a,b)240 INT m_gl_il(a,b) OP a,b;
241 /* AK 090692 */
242 /* labeles of irreducible characters */
243 {
244 INT erg = OK;
245 INT i;
246 CE2(a,b,m_gl_il);
247
248
249 if (CYCLIC_GL(a)) /* AK 300695 */
250 {
251 erg += m_l_v(S_GL_CYCLIC_A(a), b);
252 for (i=0;i<S_V_LI(b);i++)
253 M_I_I(i,S_V_I(b,i));
254 goto ende;
255 }
256 else if (SYM_GL(a))
257 {
258 erg += makevectorofpart(S_GL_SYM_A(a),b);
259 goto ende;
260 }
261 else if (ALT_GL(a))
262 {
263 erg += ak_make_alt_partitions(S_GL_ALT_A(a),b);
264 goto ende;
265 }
266 #ifdef KRANZTRUE
267 else if (KRANZ_GL(a))
268 {
269 erg += m_vcl_kranz(a,b);
270 goto ende;
271 }
272 #endif /* KRANZTRUE */
273 else
274 erg += error("can not compute irr labeling");
275 ende:
276 ENDR("m_gl_il");
277 }
278
279
280
m_gl_nc(a,b,c)281 INT m_gl_nc(a,b,c) OP a,b,c;
282 /* AK 090692 */
283 {
284 OP d;
285 INT erg = OK,i;
286 if (SYM_GL(a))
287 {
288 if (S_O_K(b) == PARTITION)
289 return m_nc_sym(b,c);
290 if (S_O_K(b) == INTEGER)
291 {
292 d = callocobject();
293 erg += m_gl_il(a,d);
294 erg += m_nc_sym(S_V_I(d,S_I_I(b)),c);
295 erg += freeall(d);
296 return erg;
297 }
298 }
299 if (ALT_GL(a))
300 {
301 if ((S_O_K(b) == PARTITION) /* no splitting rep */
302 ||
303 (S_O_K(b) == VECTOR) /* splitting */ )
304 return m_nc_alt(a,b,c);
305 if (S_O_K(b) == INTEGER)
306 {
307 d = callocobject();
308 erg += m_gl_il(a,d);
309 erg += m_nc_alt(a,S_V_I(d,S_I_I(b)),c);
310 erg += freeall(d);
311 return erg;
312 }
313 }
314 #ifdef KRANZTRUE
315 if (KRANZ_GL(a))
316 {
317 if (S_O_K(b) == INTEGER)
318 return m_nc_kranz(a,b,c);
319 if ( (S_O_K(b) == MATRIX) ||
320 (S_O_K(b) == KRANZTYPUS))
321 {
322 d = callocobject();
323 erg += m_gl_il(a,d);
324 for(i=0L;i<S_V_LI(d);i++)
325 if (eq(b,S_V_I(d,i)))
326 {m_i_i(i,d);break;}
327 erg += m_nc_kranz(a,d,c);
328 erg += freeall(d);
329 return erg;
330 }
331 }
332 #endif /* KRANZTRUE */
333 println(a); println(b);
334 return error("can not compute irr char");
335 }
336 #endif /* CHARTRUE */
337
m_gl_cl(a,b)338 INT m_gl_cl(a,b) OP a,b;
339 /* make group label class label */
340 {
341 INT erg = OK,i;
342
343 CE2(a,b,m_gl_cl);
344
345 if (CYCLIC_GL(a)) /* AK 300695 */
346 {
347 erg += m_l_v(S_GL_CYCLIC_A(a), b);
348 for (i=0;i<S_V_LI(b);i++)
349 M_I_I(i,S_V_I(b,i));
350 return erg;
351 }
352 #ifdef PARTTRUE
353 else if (SYM_GL(a))
354 return makevectorofpart(S_GL_SYM_A(a),b);
355 else if (ALT_GL(a))
356 return ak_make_alt_classes(S_GL_ALT_A(a),b);
357 #endif /* PARTTRUE */
358 #ifdef KRANZTRUE
359 else if (KRANZ_GL(a))
360 return m_vcl_kranz(a,b);
361 #endif /* KRANZTRUE */
362 else
363 erg += error("can not compute class labeling");
364 ENDR("m_gl_cl");
365 }
366
m_gl_ge_cl(a,b,c)367 INT m_gl_ge_cl(a,b,c) OP a,b,c;
368 /* AK 190202 */
369 /* enter group label a and group element b, get class label */
370 {
371 INT erg = OK;
372 CTO(VECTOR,"m_gl_ge_cl(1)",a);
373 if (SYM_GL(a))
374 {
375 CTO(PERMUTATION,"m_gl_ge_cl(2)",b);
376 erg += zykeltyp(b,c);
377 goto ende;
378 }
379 else if (ALT_GL(a))
380 {
381 OP d;
382 CTO(PERMUTATION,"m_gl_ge_cl(2)",b);
383 d = CALLOCOBJECT();
384 erg += zykeltyp(b,d);
385 if (split(S_GL_ALT_A(a),d) ) {
386 m_il_v(2,c);
387 SWAP(d,S_V_I(c,0));
388 M_I_I(which_part(b),S_V_I(c,1));
389 }
390 else
391 SWAP(c,d);
392 FREEALL(d);
393 goto ende;
394 }
395 else {
396 NYI("m_gl_ge_cl");
397 }
398 ende:
399 ENDR("m_gl_ge_cl");
400 }
401
m_gl_co(a,b)402 INT m_gl_co(a,b) OP a,b;
403 /* class order */
404 {
405 OP c,d;
406 INT i,erg=OK;
407 CE2(a,b,m_gl_co);
408
409 if (CYCLIC_GL(a)) /* AK 300695 */
410 {
411 erg += m_l_v(S_GL_CYCLIC_A(a), b);
412 for (i=0;i<S_V_LI(b);i++)
413 M_I_I((INT)1,S_V_I(b,i));
414 return erg;
415 }
416 else if (SYM_GL(a))
417 {
418 c = callocobject();
419 erg += m_gl_cl(a,c);
420 erg += m_l_v(S_V_L(c),b);
421 for (i=0L;i<S_V_LI(b);i++)
422 {
423 erg += ordcon(S_V_I(c,i),S_V_I(b,i));
424 }
425 erg += freeall(c);
426 return erg;
427 }
428 else if (ALT_GL(a))
429 {
430 c = callocobject();
431 erg += m_gl_cl(a,c);
432 erg += m_l_v(S_V_L(c),b);
433 for (i=0L;i<S_V_LI(b);i++)
434 {
435 if (S_O_K(S_V_I(c,i)) == PARTITION)
436 erg += ordcon(S_V_I(c,i),S_V_I(b,i));
437 else /* is a splitting class */
438 {
439 erg += ordcon(S_V_I(S_V_I(c,i),0L),S_V_I(b,i));
440 erg += div(S_V_I(b,i),cons_zwei,S_V_I(b,i));
441 }
442 }
443 erg += freeall(c);
444 return erg;
445 }
446 #ifdef KRANZTRUE
447 else if (KRANZ_GL(a))
448 {
449 c = callocobject();
450 d = callocobject();
451 erg += m_gl_cl(a,c);
452 erg += m_gl_cl(S_GL_KRANZ_GLA(a),d); /* labeling of classes
453 for the first group */
454 erg += m_l_v(S_V_L(c),b);
455 for (i=0L;i<S_V_LI(b);i++)
456 {
457 erg += typusorder(S_V_I(c,i),
458 S_GL_KRANZ_A(a),S_GL_KRANZ_B(a),
459 S_V_I(b,i),d);
460 }
461 erg += freeall(d);
462 erg += freeall(c);
463 return erg;
464 }
465 #endif /* KRANZTRUE */
466 else
467 erg += error("can not compute class order");
468 ENDR("m_gl_co");
469 }
470
m_gl_cr(a,b)471 INT m_gl_cr(a,b) OP a,b;
472 /* class rep */
473 /* b will be a vector object of length = number of classes */
474 {
475 OP c;
476 INT i,j,erg=OK;
477 CE2 (a,b,m_gl_cr);
478
479 if (CYCLIC_GL(a))
480 {
481 erg += m_l_v(S_GL_CYCLIC_A(a),b);
482 for (i=0;i<S_V_LI(b);i++)
483 {
484 erg += m_il_p(S_V_LI(b),S_V_I(b,i));
485 for(j=0;j<S_P_LI(S_V_I(b,i));j++)
486 erg += m_i_i((1+j+i) % S_V_LI(b),
487 S_P_I(S_V_I(b,i),j));
488 }
489 goto endr_ende;
490 }
491 if (SYM_GL(a))
492 {
493 c = callocobject();
494 erg += m_gl_cl(a,c);
495 erg += m_l_v(S_V_L(c),b);
496 for (i=0L;i<S_V_LI(b);i++)
497 {
498 erg += m_part_perm(S_V_I(c,i),S_V_I(b,i));
499 }
500 erg += freeall(c);
501 goto endr_ende;
502 }
503 #ifdef MATRIXTRUE
504 if (ALT_GL(a))
505 {
506 c = callocobject();
507 erg += makealtclassreps(S_GL_ALT_A(a),c,b);
508 erg += freeall(c);
509 goto endr_ende;
510 }
511 #endif /* MATRIXTRUE */
512 if (GLNQ_GL(a))
513 {
514 erg += class_label_glnq(S_GL_GLNQ_N(a),S_GL_GLNQ_Q(a),b);
515 goto endr_ende;
516 }
517 error("can not compute class reps");
518 ENDR("m_gl_cr");
519 }
520
521 #ifdef CHARTRUE
m_gl_chartafel(a,b)522 INT m_gl_chartafel(a,b) OP a,b;
523 /* AK 080306 */
524 {
525 INT erg = OK;
526 if (SYM_GL(a))
527 erg += chartafel(S_GL_SYM_A(a),b);
528 else if (ALT_GL(a))
529 erg += an_tafel(S_GL_SYM_A(a),b);
530 else if (CYCLIC_GL(a))
531 erg += cyclic_tafel(S_GL_CYCLIC_A(a),b);
532 #ifdef KRANZTRUE
533 else if (KRANZ_GL(a))
534 {
535 OP c=callocobject();
536 OP d=callocobject();
537 erg += kranztafel(S_GL_KRANZ_B(a),S_GL_KRANZ_A(a),b,c,d);
538 erg += freeall(c);
539 erg += freeall(d);
540 }
541 #endif /* KRANZTRUE */
542 else
543 {
544 erg += error("can not compute character table");
545 }
546 ENDR("m_gl_chartafel");
547 }
548 #endif /* CHARTRUE */
549
cyclic_tafel(a,b)550 INT cyclic_tafel(a,b) OP a,b;
551 {
552 INT erg = OK,i,j;
553 OP c;
554 CTO(INTEGER,"cyclic_tafel",a);
555 CE2(a,b,cyclic_tafel);
556
557 c = callocobject();
558 erg += m_lh_m(a,a,b);
559 for (i=0;i<S_M_HI(b);i++)
560 for (j=0;j<S_M_LI(b);j++)
561 {
562 m_i_i(i * j,c);
563 make_index_coeff_power_cyclo(a,cons_eins,c,S_M_IJ(b,i,j));
564 }
565 freeall(c);
566 ENDR("cyclic_tafel");
567 }
568
569
570 #ifdef KRANZTRUE
m_vec_grad_nc_hyp(v,g,c)571 INT m_vec_grad_nc_hyp(v,g,c) OP v,g,c;
572 /* v is vector with char values
573 g is degree of hyperoktaeder group
574 c becomes character
575 */
576 {
577 OP d;
578 INT erg = OK;
579 CTO(VECTOR,"m_vec_grad_nc_hyp(1)",v);
580 d = callocobject();
581 erg += m_i_i(2L,d);
582 erg += m_il_v(2L,c);
583 erg += m_gl_symkranz(d,g,S_V_I(c,0L));
584 erg += copy(v,S_V_I(c,1L));
585 erg += freeall(d);
586 ENDR("m_vec_grad_nc_hyp");
587 }
588
589
590
class_rep_kranz(a,b)591 INT class_rep_kranz(a,b) OP a,b;
592 /* a is matrix labeling of Sm wr Sn class
593 b becomes representing element of the class */
594 {
595 return error("class_rep_kranz:not yet implemented");
596 }
597
598
599
reduce_nc_kranz(a,b)600 INT reduce_nc_kranz(a,b) OP a,b;
601 {
602 OP c ,d,e,f,g;
603 INT erg = OK;
604 CTO(VECTOR,"reduce_nc_kranz(1)",a);
605 c = callocobject();
606 d = callocobject();
607 e = callocobject();
608 f = callocobject();
609 g = callocobject();
610 erg += m_i_i(0L,d);
611 erg += m_vco_kranz(S_NC_GL(a),f);
612 erg += grouporder_kranz(S_NC_GL(a),g);
613 erg += copy(a,b);
614 for (;lt(d,S_V_L(S_V_I(b,1L)));inc(d))
615 {
616 erg += m_nc_kranz(S_NC_GL(a),d,c);
617 erg += mult_nc_kranz(c,a,e);
618 erg += mult(S_V_I(e,1L),f,c);
619 erg += div(c,g,c);
620 erg += SYM_sum(c,S_V_I(S_NC_C(b),S_I_I(d)));
621 }
622 erg += freeall(c);
623 erg += freeall(d);
624 erg += freeall(e);
625 erg += freeall(f);
626 erg += freeall(g);
627 ENDR("reduce_nc_kranz");
628 }
629
630
631
mult_nc_kranz(a,b,c)632 INT mult_nc_kranz(a,b,c) OP a,b,c;
633 {
634 INT erg = OK;
635 CTO(VECTOR,"mult_nc_kranz(1)",a);
636 CTO(VECTOR,"mult_nc_kranz(2)",b);
637 if (neq(S_NC_GL(a),S_NC_GL(b)))
638 error("mult_nc_kranz:different groups");
639 erg += copy(a,c);
640 erg += mult(S_NC_C(a),S_NC_C(b),S_NC_C(c));
641 ENDR("mult_nc_kranz");
642 }
643
644
645
grouporder_kranz(l,a)646 INT grouporder_kranz(l,a) OP l,a;
647 {
648 OP zz,z;
649 INT erg = OK;
650 CTO(VECTOR,"grouporder_kranz(1)",l);
651 z = callocobject();
652 zz = callocobject();
653 erg += fakul(S_GL_KRANZ_B(l),z);
654 erg += fakul(S_GL_KRANZ_A(l),zz);
655 erg += hoch(zz,S_GL_KRANZ_B(l),a);
656 erg += mult_apply(z,a);
657 erg += freeall(z);
658 erg += freeall(zz);
659 ENDR("grouporder_kranz");
660 }
661
662
663
scan_nc_kranz(a)664 INT scan_nc_kranz(a) OP a;
665 {
666 OP b,c,l,d;
667 OBJECTKIND k;
668 INT i;
669 INT erg = OK;
670 CTO(EMPTY,"scan_nc_kranz(1)",a);
671 b = callocobject();
672 c = callocobject();
673 l = callocobject();
674 d = callocobject();
675 erg += scan(INTEGER,b);
676 erg += scan(INTEGER,c);
677 erg += m_gl_symkranz(b,c,l);
678 erg += numberof_class_kranz(l,d);
679 erg += k=scanobjectkind();
680 erg += m_il_v(2L,a);
681 erg += copy(l,S_V_I(a,0L));
682 erg += m_l_v(d,S_V_I(a,1L));
683 for (i=0L;i<S_I_I(d);i++)
684 erg += scan(k,S_V_I(S_V_I(a,1L),i));
685 erg += freeall(b);
686 erg += freeall(c);
687 erg += freeall(l);
688 erg += freeall(d);
689 ENDR("scan_nc_kranz");
690 }
691
692
693
m_vcl_kranz(l,a)694 INT m_vcl_kranz(l,a) OP l,a;
695 /* AK 050692 */
696 /* computes the class labeling of a wreath product
697 of two symm groups. l is the corresponding group label */
698 /* a becomes vector of matrices */
699 {
700 OP za,zb;
701 OP f,c,h;
702 INT j;
703 za = S_V_I(S_V_I(S_V_I(l,1L),1L),1L);
704 zb = S_V_I(S_V_I(S_V_I(l,1L),0L),1L);
705 /* zb wr za */
706 f = callocobject();
707 c = callocobject();
708 h = callocobject();
709 makevectorofpart(zb,f);
710 makevectorof_kranztypus(za,S_V_L(f),c);
711 m_il_v(S_V_LI(c),a);
712 for(j = 0L; j<S_V_LI(c);j++) {
713 kranztypus_to_matrix(S_V_I(c,j),S_V_I(a,j));
714 }
715 SYM_sort(a);
716 freeall(f); freeall(h); freeall(c);
717 return OK;
718 }
719 #endif /* KRANZTRUE */
720
721 #ifdef KRANZTRUE
m_vco_kranz(l,a)722 INT m_vco_kranz(l,a) OP l,a;
723 /* vector of class orders of a wreath product of two symm
724 groups */
725 {
726 OP za,zb;
727 OP f,c,h;
728 INT j;
729 za = S_V_I(S_V_I(S_V_I(l,1L),1L),1L);
730 zb = S_V_I(S_V_I(S_V_I(l,1L),0L),1L);
731 /* zb wr za */
732 f = callocobject();
733 c = callocobject();
734 h = callocobject();
735 makevectorofpart(zb,f);
736 makevectorof_kranztypus(za,S_V_L(f),c);
737 m_il_v(S_V_LI(c),h);
738 for(j = 0L; j<S_V_LI(c);j++) {
739 kranztypus_to_matrix(S_V_I(c,j),S_V_I(h,j));
740 }
741
742 SYM_sort(h);
743 m_l_v(S_V_L(h),a);
744 for(j = 0L; j<S_V_LI(c);j++) {
745 typusorder(S_V_I(h,j), zb, za, S_V_I(a,j), f);
746 }
747 freeall(f); freeall(c); freeall(h);
748 return OK;
749 }
750
751
752
numberof_class_kranz(l,a)753 INT numberof_class_kranz(l,a) OP l,a;
754 {
755 INT erg = OK;
756 OP za,zb;
757 OP f,c;
758 za = S_V_I(S_V_I(S_V_I(l,1L),1L),1L);
759 zb = S_V_I(S_V_I(S_V_I(l,1L),0L),1L);
760 /* zb wr za */
761 f = callocobject();
762 c = callocobject();
763 erg += makevectorofpart(zb,f);
764 erg += makevectorof_kranztypus(za,S_V_L(f),c);
765 erg += copy(S_V_L(c),a);
766 erg += freeall(f);
767 erg += freeall(c);
768 return erg;
769 }
770
771
772
order_class_kranz(l,i,a)773 INT order_class_kranz(l,i,a) OP l,i,a;
774 {
775 OP za,zb;
776 OP f,c,h;
777 INT j;
778 INT erg = OK;
779 za = S_V_I(S_V_I(S_V_I(l,1L),1L),1L);
780 zb = S_V_I(S_V_I(S_V_I(l,1L),0L),1L);
781 /* zb wr za */
782 f = callocobject();
783 c = callocobject();
784 h = callocobject();
785 erg += makevectorofpart(zb,f);
786 erg += makevectorof_kranztypus(za,S_V_L(f),c);
787 erg += m_il_v(S_V_LI(c),h);
788 for(j = 0L; j<S_V_LI(c);j++) {
789 erg += kranztypus_to_matrix(S_V_I(c,j),S_V_I(h,j));
790 }
791
792 erg += SYM_sort(h);
793 erg += typusorder(S_V_I(h,S_I_I(i)), zb, za, a, f);
794 erg += freeall(f);
795 erg += freeall(c);
796 erg += freeall(h);
797 return erg;
798 }
799
800
801
m_nc_kranz(l,i,b)802 INT m_nc_kranz(l,i,b) OP l,i,b;
803 /* l is group label
804 i is integer which selects the i-th ireducible character
805 b becomes character
806 */
807 {
808 OP c , ll ;
809 OP d,e;
810 OP za,zb;
811 INT erg = OK;
812 c = callocobject();
813 ll = callocobject();
814
815 erg += m_il_v(2L,b);
816 erg += copy(l,S_V_I(b,0L));
817
818 d = callocobject();
819 e = callocobject();
820 za = S_V_I(S_V_I(S_V_I(l,1L),1L),1L);
821 zb = S_V_I(S_V_I(S_V_I(l,1L),0L),1L);
822 /* zb wr za */
823 erg += kranztafel(za,zb,c,d,e);
824 erg += copy(l,ll);
825
826 if (ge(i,S_M_H(c))) error("m_nc_kranz: wrong index");
827 erg += select_row(c,S_I_I(i),S_V_I(b,1L));
828
829 erg += freeall(d);
830 erg += freeall(e);
831 erg += freeall(ll);
832 erg += freeall(c);
833
834 return erg;
835 }
836
837
838
m_gl_symkranz(a,b,c)839 INT m_gl_symkranz(a,b,c) OP a,b,c;
840 /* make group label for kranzprodukt of two sym groups
841 c = s_a wr s_b */
842 /* AK 050692 */
843 {
844 m_il_v(2L,c);
845 m_i_i(3L,S_V_I(c,0L)); /* 3 == Kranzprodukt */
846 m_il_v(2L,S_V_I(c,1L));
847 m_gl_sym(a,S_V_I(S_V_I(c,1L),0L));
848 m_gl_sym(b,S_V_I(S_V_I(c,1L),1L));
849 return OK;
850 }
851
m_gl_glnq(n,q,c)852 INT m_gl_glnq(n,q,c) OP n,q,c;
853 /* AK 300304 */
854 {
855 m_il_v(2L,c);
856 m_i_i(5L,S_V_I(c,0L)); /* 5 == GL(n,q) */
857 m_il_v(2L,S_V_I(c,1L));
858 m_i_i(n,S_V_I(S_V_I(c,1L),0L));
859 m_i_i(q,S_V_I(S_V_I(c,1L),1L));
860 return OK;
861 }
862
863
864
m_gl_hyp(a,b)865 INT m_gl_hyp(a,b) OP a,b;
866 /* make group-label for hyperoctaeder */ /* AK 050692 */
867 {
868 return m_gl_symkranz(cons_zwei,a,b);
869 }
870 #endif /* KRANZTRUE */
871
m_gl_cyclic(a,b)872 INT m_gl_cyclic(a,b) OP a,b;
873 /* make group-label for cyclic */ /* AK 291092 */
874 {
875 INT erg = OK;
876 CTO(INTEGER,"m_gl_cyclic(1)",a);
877 erg += m_il_v(2L,b);
878 erg += m_i_i(4L,S_V_I(b,0L)); /* 4 == cyclic group */
879 erg += copy(a,S_V_I(b,1L));
880 ENDR("m_gl_cyclic");
881 }
882
m_gl_alt(a,b)883 INT m_gl_alt(a,b) OP a,b;
884 /* make group-label for alt */ /* AK 050692 */
885 /* a and b may be equal */
886 {
887 INT erg = OK,i;
888 CTO(INTEGER,"m_gl_alt(1)",a);
889 i = S_I_I(a);
890 erg += m_il_v(2L,b);
891 M_I_I(2L,S_V_I(b,0L)); /* 2 == alternating group */
892 M_I_I(i,S_V_I(b,1L));
893 ENDR("m_gl_alt");
894 }
895
m_gl_sym(a,b)896 INT m_gl_sym(a,b) OP a,b;
897 /* make group-label for sym */ /* AK 050692 */
898 {
899 INT erg = OK;
900 erg += m_il_v(2L,b);
901 erg += m_i_i(1L,S_V_I(b,0L)); /* 1 == symmetric group */
902 erg += copy(a,S_V_I(b,1L));
903 return erg;
904 }
905
906 #ifdef CHARTRUE
m_nc_alt(c,b,a)907 static INT m_nc_alt(c,b,a) OP c,b,a;
908 /* b is part or vec in case of splitting rep */
909 /* c is group label of thew alternating group */
910 /* the result is an irreducible character */
911 {
912 OP d = callocobject();
913 OP e = callocobject();
914 INT erg = OK;
915 INT i;
916 erg += m_gl_cr(c,d); /* class reps */
917 erg += m_gl_cl(c,e); /* class labels */
918 erg += m_il_v(2L,a);
919 erg += copy(c , S_V_I(a,0L));
920 erg += m_il_v(S_V_LI(d), S_V_I(a,1L)); /* structure of new charater */
921 for (i=0L;i < S_V_LI(d); i++)
922 {
923 if (S_O_K(b) == PARTITION) /* not splitting rep */
924 a_charvalue(b,S_V_I(d,i),S_V_I(S_V_I(a,1L),i));
925 else if (S_O_K(b) == VECTOR) /* splitting rep */
926 {
927 if (S_O_K(S_V_I(e,i)) == VECTOR) /* splitting class */
928 {
929 if (nullp(S_V_I(b,1L))) /* irrep part+ */
930 a_charvalue(S_V_I(b,0L),S_V_I(d,i),S_V_I(S_V_I(a,1L),i));
931 else /* compute values for part+ on exchanged classes */
932 {
933 if (nullp(S_V_I(S_V_I(e,i),1L))) /* class+ */
934 a_charvalue(S_V_I(b,0L),S_V_I(d,i+1L),S_V_I(S_V_I(a,1L),i));
935 else /* class- */
936 a_charvalue(S_V_I(b,0L),S_V_I(d,i-1L),S_V_I(S_V_I(a,1L),i));
937 }
938 }
939 else
940 a_charvalue(S_V_I(b,0L),S_V_I(d,i),S_V_I(S_V_I(a,1L),i));
941 }
942 }
943 freeall(d);
944 freeall(e);
945 return erg;
946 }
947
948
949
m_nc_sym(b,a)950 static INT m_nc_sym(b,a) OP b,a;
951 /* b is partition
952 a becomes irred char */
953 {
954 OP c = callocobject();
955 INT erg = OK;
956
957 erg += m_il_v(2L,a);
958 erg += m_il_v(2L,S_V_I(a,0L));
959 erg += weight(b,c);
960 erg += m_gl_sym(c,S_V_I(a,0L));
961 erg += m_part_sc(b,c);
962 erg += copy(S_SC_W(c),S_V_I(a,1L));
963 erg += freeall(c);
964 return erg;
965 }
966 #endif /* CHARTRUE */
967
968 /* Ab hier bis ende PF */
969 /* PF 050292 */ /* PF 040692 */
970 /***********************************************************************/
971 /* */
972 /* Diese Routine berechnet zwei Vektoren. */
973 /* 1.Vektor: Partition der Konjugiertenklassen der An (class) */
974 /* 2.Vektor: Standardrepraesentanten dieser Klassen (reps) */
975 /* Rueckgabewert: OK oder error */
976 /* */
977 /***********************************************************************/
978
979 #ifdef MATRIXTRUE
makealtclassreps(n,class,reps)980 INT makealtclassreps(n,class,reps)
981 OP n,class,reps;
982 {
983 OP matrix; /* Partitionen der Klassen */
984 OP trans; /* (12) */
985 INT i,j;
986 INT erg=OK;
987
988 FREESELF2(class,reps);
989
990
991 /*** Test auf Ganzzahligkeit von n ************************************/
992
993 if (S_O_K(n) != INTEGER)
994 {
995 error("makealtclassreps : n is no INTEGER.");
996 return ERROR;
997 }
998 if (S_I_I(n) <= 0L)
999 {
1000 error("makealtclassreps : n is negativ.");
1001 return ERROR;
1002 }
1003
1004 /*** Speicherplatzreservierung ****************************************/
1005
1006 matrix=callocobject();
1007 trans=callocobject();
1008
1009 /*** Berechnung der beiden Vektoren *************************************/
1010
1011 erg += make_alt_classes(n,matrix);
1012 erg += m_il_nv(S_M_LI(matrix),class);
1013 erg += m_il_nv(S_M_LI(matrix),reps);
1014 for(i=0L;i<s_v_li(class);i++)
1015 {
1016 erg += copy(S_M_IJ(matrix,0L,i),S_V_I(class,i));
1017 erg += std_perm(S_V_I(class,i),S_V_I(reps,i));
1018 if(S_M_IJI(matrix,1L,i)==1L)
1019 {
1020 erg += m_il_p(S_I_I(n),trans);
1021 erg += m_i_i(2L,S_P_I(trans,0L));
1022 erg += m_i_i(1L,S_P_I(trans,1L));
1023 for(j=2L;j<S_I_I(n);j++)
1024 erg += m_i_i(j+1L,S_P_I(trans,j));
1025 erg += mult(trans,S_V_I(reps,i),S_V_I(reps,i));
1026 erg += mult(S_V_I(reps,i),trans,S_V_I(reps,i));
1027 }
1028 }
1029
1030 FREEALL2(matrix,trans);
1031 ENDR("makealtclassreps");
1032 }
1033 #endif /* MATRIXTRUE */
1034
1035 /* PF 040692 */
1036 /***********************************************************************/
1037 /* */
1038 /* Diese Routine vergleicht zwei Partitionen a und b bezueglich */
1039 /* der lexikographischen Ordnung. */
1040 /* Rueckgabewert: 0L, falls a=b */
1041 /* <0L, falls a<b */
1042 /* >0L, falls a>b */
1043 /* */
1044 /***********************************************************************/
1045
part_comp(a,b)1046 INT part_comp(a,b)
1047 OP a,b;
1048 {
1049 OP l;
1050 INT i;
1051
1052 l=callocobject();
1053
1054 if (S_PA_LI(a) > S_PA_LI(b))
1055 m_i_i(S_PA_LI(b),l);
1056 else
1057 m_i_i(S_PA_LI(a),l);
1058 i=0L;
1059 do i++;
1060 while(i<S_I_I(l) && S_PA_II(a,S_PA_LI(a)-i)==S_PA_II(b,S_PA_LI(b)-i));
1061 if(S_PA_II(a,S_PA_LI(a)-i)<S_PA_II(b,S_PA_LI(b)-i))
1062 {
1063 freeall(l);
1064 return -1L;
1065 }
1066 if(S_PA_II(a,S_PA_LI(a)-i)>S_PA_II(b,S_PA_LI(b)-i))
1067 {
1068 freeall(l);
1069 return 1L;
1070 }
1071 freeall(l);
1072 return 0L;
1073 }
1074
1075 /**************************************************************************/
1076 /* Diese Routine berechnet zu einer Partition die Standardpermutation */
1077 /* in umgekehrter Reihenfolge wie m_part_perm(). */
1078 /* Rueckgabewert: OK oder error. */
1079 /**************************************************************************/
1080
1081 #ifdef PERMTRUE
std_perm(a,b)1082 INT std_perm(a,b) OP a,b;
1083 /* erzeugt aus zykeltyp standardpermutation */
1084 {
1085 INT i,j,k; /* die adresse in der perm. b */
1086 OP l;
1087
1088 l=callocobject();
1089
1090 weight(a,l);
1091 if (not EMPTYP(b))
1092 freeself(b);
1093 b_ks_p(VECTOR,callocobject(),b);
1094 b_l_v(l,S_P_S(b));
1095 C_O_K(S_P_S(b),INTEGERVECTOR);
1096 k=0L;
1097 for (i=S_PA_LI(a)-1L;i>=0L;i--)
1098 {
1099 /* k ist naechste frei stelle */
1100 M_I_I(k+1L,S_P_I(b,k+S_PA_II(a,i)-1L));
1101 for (j=1L;j<S_PA_II(a,i);j++)
1102 M_I_I(j+k+1L,S_P_I(b,k+j-1L));
1103 k=k+S_PA_II(a,i);
1104 };
1105 return(OK);
1106 }
1107 #endif /* PERMTRUE */
1108
1109 /* PF 250292 */
1110 /***************************************************************************/
1111 /* */
1112 /* Diese Routine berechnet den Charakterwert einer irreduziblen */
1113 /* Darstellung (rep) auf der Konjugiertenklasse (part) der An. */
1114 /* Rueckgabewert: OK oder error */
1115 /* */
1116 /***************************************************************************/
1117
1118 #ifdef MATRIXTRUE
a_charvalue_co(rep,part,res,index)1119 INT a_charvalue_co(rep,part,res,index)
1120 OP rep; /* Partition der irreduziblen Darstellung der An */
1121 OP part; /* Partition der Konjugiertenklasse oder Permutation */
1122 OP res; /* Beginn: leer; Ende: Charakterwert */
1123 INT index; /* 0 or 1 to switch between to different irreducibles */
1124 {
1125 OP conrep; /* konjugierte Partition zu rep */
1126 OP newpart; /* Zykelpartition,falls part Permutation ist */
1127 OP h_part; /* Hakenpartition zu rep */
1128 OP sgn; /* Signum zu part */
1129
1130 INT erg=OK; /* Rueckgabewert */
1131
1132 CTO(PARTITION,"a_charvalue(1)",rep);
1133 CTTO(PERMUTATION,PARTITION,"a_charvalue(2)",part);
1134
1135 FREESELF(res);
1136
1137 /*** newpart wird Partition der Konjugiertenklasse, ***/
1138 /*** part wird Permutation daraus. ***/
1139
1140 newpart = CALLOCOBJECT();
1141 if (S_O_K(part) == PERMUTATION)
1142 erg += zykeltyp_permutation(part,newpart);
1143 else
1144 {
1145 erg += copy(part,newpart);
1146 erg += m_part_perm(newpart,part);
1147 }
1148
1149 /*** Test, ob part tatsaechlich in der An liegt ***/
1150
1151
1152 sgn = CALLOCOBJECT();
1153 erg += signum_permutation(part,sgn);
1154 if (S_I_I(sgn) == -1L)
1155 {
1156 erg += error("a_charvalue: odd permutation ");
1157 goto acv_ende3;
1158 }
1159
1160 /*** Test, ob rep und newpart Partitionen der gleichen Zahl n sind ***/
1161 { INT wi,wj;
1162 PARTITION_WEIGHT(rep,wi);
1163 PARTITION_WEIGHT(newpart,wj);
1164 if (wi != wj) {
1165 error("a_charvalue: disagree in partition weights");
1166 goto acv_ende2;
1167 }
1168 }
1169
1170 /*** Falls rep nicht selbstassoziiert ist, kann der Charakterwert ***/
1171 /*** wie bei der Sn (Murnaghan-Nakayama) berechnet werden. ***/
1172
1173 conrep = CALLOCOBJECT();
1174 erg += conjugate_partition(rep,conrep);
1175 if(NEQ(rep,conrep))
1176 {
1177 erg += charvalue(rep,newpart,res,NULL);
1178 goto acv_ende1;
1179 }
1180
1181 /*** Falls rep selbstassoziiert ist ***/
1182
1183 h_part = CALLOCOBJECT();
1184 erg += hook_part(rep,h_part);
1185
1186 /*** und falls part nicht die Hakenpartition von rep ist, bzw eine ***/
1187 /*** Permutation aus der entsprechenden Konjugiertenklasse, wird ***/
1188 /*** der Charakterwert der Sn halbiert. ***/
1189
1190 if(NEQ(h_part,newpart))
1191 {
1192 erg += charvalue(rep,newpart,res,NULL);
1193 erg += half_apply(res);
1194 goto acv_ende;
1195 }
1196
1197 /* und falls part doch die Hakenpartition ist, bzw. Permutation */
1198 /* daraus, wird der Charakterwert der zerfallenden Darstellung */
1199 /* auf der zerfallenden Konjugiertenklasse berechnet. */
1200
1201 erg += wert((which_part(part) + index)%2,newpart,res);
1202
1203 acv_ende:
1204 FREEALL(h_part);
1205 acv_ende1:
1206 FREEALL(conrep);
1207 acv_ende2:
1208 acv_ende3:
1209 FREEALL2(newpart,sgn);
1210 ENDR("a_charvalue");
1211 }
1212 #endif /* MATRIXTRUE */
1213
a_charvalue(rep,part,res)1214 INT a_charvalue(rep,part,res) OP rep,part,res;
1215 {
1216 return a_charvalue_co(rep,part,res,0);
1217 }
1218
1219 /* PF 120292 */
1220 /***********************************************************************/
1221 /* */
1222 /* Diese Routine entscheidet, ob die Permutation per einer ueber */
1223 /* der An zerfallenden Konjugiertenklasse im ersten oder zweiten */
1224 /* Teil dieser Klasse liegt. */
1225 /* Rueckgabewert: 0L, falls per im ersten Teil liegt */
1226 /* 1L, sonst */
1227 /* */
1228 /***********************************************************************/
1229
1230 #ifdef MATRIXTRUE
which_part(per)1231 INT which_part(per)
1232 OP per; /* Permutation einer zerfallenden Klasse */
1233 {
1234 OP typ; /* Zykelpartition von per */
1235 OP std; /* Konjugator zu per */
1236 OP sgn; /* Signum von std */
1237 OP check; /* Hilfsvektor der Laenge n */
1238 OP std_first; /* Hilfsmatrix zur Konstruktion von std */
1239 INT alt,neu,i,j,k,l;
1240 INT erg = OK;
1241
1242 CTO(PERMUTATION,"which_part(1)",per);
1243 CALLOCOBJECT5(std,typ,std_first,check,sgn);
1244
1245 zykeltyp_permutation(per,typ);
1246 m_ilih_nm(S_PA_LI(typ),2L,std_first);
1247 for(i=0L;i<S_PA_LI(typ);i++)
1248 M_I_I(S_PA_II(typ,i),S_M_IJ(std_first,0L,i));
1249 m_il_nv(S_P_LI(per),check);
1250 m_il_p(S_P_LI(per),std);
1251
1252 k= -1L;
1253 for(i=0L;i<S_PA_LI(typ);i++)
1254 {
1255 do k++;
1256 while(S_V_II(check,k)==1L);
1257 alt=k;
1258 M_I_I(1L,S_V_I(check,k));
1259 j=0L;
1260 do {
1261 j++;
1262 neu=S_P_II(per,alt);
1263 alt=neu-1L;
1264 M_I_I(1L,S_V_I(check,alt));
1265 }
1266 while(neu!=k+1L);
1267 l= -1L;
1268 do l++;
1269 while(S_M_IJI(std_first,0L,l)!=j);
1270
1271 M_I_I(k,S_M_IJ(std_first,1L,l));
1272 }
1273
1274 /* Belegung des Konjugators */
1275
1276 k=0L;
1277 for(i=S_PA_LI(typ)-1L;i>=0L;i--)
1278 {
1279 M_I_I(S_M_IJI(std_first,1L,i)+1,S_P_I(std,k));
1280 k++;
1281 l=S_M_IJI(std_first,1L,i);
1282 for(j=0L;j<S_M_IJI(std_first,0L,i)-1L;j++)
1283 {
1284 M_I_I(S_P_II(per,l),S_P_I(std,k));
1285 l=S_P_II(per,l)-1L;
1286 k++;
1287 }
1288 }
1289
1290 signum(std,sgn);
1291 i = S_I_I(sgn);
1292 FREEALL5(std,typ,std_first,check,sgn);
1293 if(i==1) return 0;
1294 else if(i==-1) return 1;
1295
1296 SYMCHECK(1,"which_part:should never be here");
1297 ENDR("which_part");
1298 }
1299
1300
1301 /* PF 060292 */ /* PF 040692 */ /* PF 100692 */
1302 /***********************************************************************/
1303 /* */
1304 /* Diese Routine berechnet den Vektor der irreduziblen Dar- */
1305 /* stellungen der An. */
1306 /* Rueckgabewert: OK oder error */
1307 /* */
1308 /***********************************************************************/
1309
make_alt_partitions(n,res)1310 INT make_alt_partitions(n,res)
1311 OP n; /* Gewicht der Partitionen */
1312 OP res; /* Vektor der irred. Darst. der An */
1313 {
1314 OP par; /* Partition von n */
1315 OP conpar; /* konjugierte Partition */
1316 OP l; /* Anzahl der verschiedenen irred. Darst. der An */
1317 INT i=0L;
1318 INT erg=OK;
1319
1320 INT alt_dimension(); /* Hilfsroutinen */
1321 INT part_comp();
1322
1323 if (not EMPTYP(res))
1324 erg += freeself(res);
1325
1326 /*** Test auf Ganzzahligkeit von n ************************************/
1327
1328 if (S_O_K(n) != INTEGER)
1329 {
1330 error("make_alt_partitions : n is no INTEGER.");
1331 return ERROR;
1332 }
1333 if (S_I_I(n) <= 0L)
1334 {
1335 error("make_alt_partitions : n is negativ.");
1336 return ERROR;
1337 }
1338
1339 /*** Speicherplatzreservierung fuer die Objekte **********************/
1340
1341 conpar=callocobject();
1342 l=callocobject();
1343 par=callocobject();
1344
1345 /*** Berechnung des Partitionenvektors (eigentlich eine Matrix) *******/
1346
1347 erg += alt_dimension(n,l);
1348 erg += m_ilih_nm(S_I_I(l),2L,res);
1349 erg += first_partition(n,par);
1350 do {
1351 erg += conjugate(par,conpar);
1352 if(part_comp(par,conpar)>=0L)
1353 {
1354 erg += copy(par,S_M_IJ(res,0L,i));
1355 if(part_comp(par,conpar)==0L && S_I_I(n)!=1L)
1356 {
1357 i++;
1358 erg += copy(par,S_M_IJ(res,0L,i));
1359 erg += m_i_i(1L,S_M_IJ(res,1L,i));
1360 }
1361 i++;
1362 }
1363 }
1364 while(next(par,par));
1365
1366 /*** Speicherplatzfreigabe *********************************************/
1367
1368 erg += freeall(par);
1369 erg += freeall(conpar);
1370 erg += freeall(l);
1371
1372 /*** Rueckkehr in die aufrufende Routine *******************************/
1373
1374 if (erg != OK)
1375 {
1376 error("make_alt_partitions : error during computation.");
1377 return ERROR;
1378 }
1379 return OK;
1380 }/* Ende von make_alt_partitions */
1381 #endif /* MATRIXTRUE */
1382
1383 /* PF 060292 */ /* PF 040692 */
1384 /***********************************************************************/
1385 /* */
1386 /* Diese Routine berechnet den Vektor der Konjugiertenklassen */
1387 /* der An. */
1388 /* Rueckgabewert: OK oder error */
1389 /* */
1390 /***********************************************************************/
1391
1392 #ifdef MATRIXTRUE
make_alt_classes(n,res)1393 INT make_alt_classes(n,res)
1394 OP n; /* Gewicht der Partitionen */
1395 OP res; /* Vektor der Konjugiertenklassen der An */
1396 {
1397 OP par; /* Partition von n */
1398 OP per; /* Permutation */
1399 OP sgn; /* Signum der Permutation */
1400 OP l; /* Anzahl der verschiedenen Konjugiertenklassen der An */
1401 INT i=0L;
1402 INT erg=OK;
1403
1404 INT alt_dimension(); /* Hilfsroutinen */
1405 INT split();
1406
1407 CTO(INTEGER,"make_alt_classes(1)",n);
1408
1409 FREESELF(res);
1410
1411 /*** Test auf Ganzzahligkeit von n ************************************/
1412
1413 SYMCHECK (S_I_I(n) <= 0,"make_alt_classes : n <=0");
1414 /*** Speicherplatzreservierung fuer die Objekte ***********************/
1415
1416 par=callocobject();
1417 per=callocobject();
1418 sgn=callocobject();
1419 l=callocobject();
1420
1421 /*** Berechnung des Partitionenvektors (eigentlich eine Matrix) *********/
1422
1423 erg += alt_dimension(n,l);
1424 erg += m_ilih_nm(S_I_I(l),2L,res);
1425 erg += first_partition(n,par);
1426 do {
1427 erg += m_part_perm(par,per);
1428 erg += signum(per,sgn);
1429 if(S_I_I(sgn) == 1L)
1430 {
1431 erg += copy(par,S_M_IJ(res,0L,i));
1432 if(split(n,par)==1L)
1433 {
1434 i++;
1435 erg += copy(par,S_M_IJ(res,0L,i));
1436 erg += m_i_i(1L,S_M_IJ(res,1L,i));
1437 }
1438 i++;
1439 }
1440 }
1441 while(next(par,par));
1442
1443 /*** Speicherplatzfreigabe *********************************************/
1444
1445 erg += freeall(par);
1446 erg += freeall(per);
1447 erg += freeall(sgn);
1448 erg += freeall(l);
1449
1450 /*** Rueckkehr in die aufrufende Routine *******************************/
1451
1452 ENDR("make_alt_classes");
1453 } /* Ende von make_alt_classes */
1454 #endif /* MATRIXTRUE */
1455
1456 /* PF 040692 */ /* PF 100692 */
1457 /**********************************************************************/
1458 /* */
1459 /* Diese Routine berechnet die Dimension der Charaktertafel der */
1460 /* An, d.h. die Anzahl der gewoehnlichen irreduziblen Darstel- */
1461 /* lungen der An. */
1462 /* Rueckgabewert: OK oder error */
1463 /* */
1464 /**********************************************************************/
1465
alt_dimension(n,res)1466 INT alt_dimension(n,res)
1467 OP n,res;
1468 {
1469 OP par; /* Partition von n */
1470 OP conpar; /* konjugierte Partition */
1471 INT erg=OK;
1472 INT part_comp(); /* Hilfsroutine */
1473
1474 CTO(INTEGER,"alt_dimension(1)",n);
1475
1476
1477 FREESELF(res);
1478
1479 /*** Test auf Ganzzahligkeit von n ************************************/
1480
1481 SYMCHECK(S_I_I(n) <= 0,"alt_dimension : n <= 0");
1482
1483 /*** Speicherplatzreservierung ****************************************/
1484
1485 par=callocobject();
1486 conpar=callocobject();
1487
1488 /*** Berechnung der Anzahl irreduzibler Darstellungen der An ***********/
1489
1490 erg += m_i_i(0L,res);
1491 erg += first_partition(n,par);
1492 do {
1493 erg += conjugate(par,conpar);
1494 if(part_comp(par,conpar)>=0L)
1495 {
1496 erg += inc(res);
1497 if(part_comp(par,conpar)==0L && S_I_I(n)!=1L)
1498 erg += inc(res);
1499 }
1500 }
1501 while(next(par,par));
1502
1503 /*** Speicherplatzfreigabe ********************************************/
1504
1505 erg += freeall(par);
1506 erg += freeall(conpar);
1507
1508 /*** Rueckkehr in die aufrufende Routine *******************************/
1509
1510 ENDR("alt_dimension");
1511 } /* Ende von alt_dimension */
1512
1513
1514
1515 /* PF 040692 */ /* PF 100692 */
1516 /*****************************************************************************/
1517 /* DIESE ROUTINE UEBERPRUEFT, OB DIE KONJUGIERTENKLASSE PAR UEBER */
1518 /* DER An ZERFAELLT. */
1519 /* RUECKGABEWERT: 1 FALLS DIE KLASSE ZERFAELLT, */
1520 /* 0 SONST. */
1521 /*****************************************************************************/
1522
split(n,par)1523 INT split(n,par) OP n,par;
1524 {
1525 INT i;
1526
1527 OP v;
1528 OP w;
1529
1530 /*** Spezialfall n=1 ***/
1531
1532 if (S_I_I(n) == 1L)
1533 return 0L;
1534
1535 w=callocobject();
1536 v=callocobject();
1537
1538 m_l_nv(n,v);
1539 for(i=0L;i<S_PA_LI(par);i++)
1540 {
1541 if (S_PA_II(par,i)%2 == 0L)
1542 {
1543 freeall(w);
1544 freeall(v);
1545 return 0L;
1546 }
1547 m_i_i(1L,w);
1548 add(S_V_I(v,S_PA_II(par,i)-1L),w,S_V_I(v,S_PA_II(par,i)-1L));
1549 }
1550 for(i=0L;i<S_I_I(n);i++)
1551 if (S_I_I(S_V_I(v,i)) > 1L)
1552 {
1553 freeall(w);
1554 freeall(v);
1555 return 0L;
1556 }
1557 freeall(w);
1558 freeall(v);
1559 return 1L;
1560 }
1561 /* PF 070592 *//* PF 010692 */ /* AK 020692 */
1562 /****************************************************************************/
1563 /* */
1564 /* Diese Routine berechnet die Charaktertafel der alternierenden Gruppe */
1565 /* An fuer eine beliebige natuerliche Zahl n. */
1566 /* VERSION 1.2 PF040592 */
1567 /****************************************************************************/
1568
1569 #ifdef MATRIXTRUE
an_tafel(n,tafel)1570 INT an_tafel(n,tafel) OP n,tafel;
1571 {
1572 OP v_part; /* Vektor der Partitionen von n */
1573 OP par; /* Partition von n */
1574 OP conpar; /* assoziierte Partition zu par */
1575 OP per; /* Permutation aus der Konjugiertenklasse (par) */
1576 OP sgn; /* Signum der Permutation per */
1577 OP split_class; /* Hakenpartition h(par),
1578 falls par selbstassoziiert */
1579 OP info_pa;/* Infovektor fuer die irreduziblen Darstellungen */
1580 OP info_cc; /* Infovektor fuer die Konjugiertenklassen */
1581 OP hilf; /* Hilfsobjekt zum Umspeichern */
1582
1583 INT i,j; /* Zaehlvariable zum Durchlauf der Infovektoren */
1584 INT l=0L; /* Groesse der Charaktertafel der An */
1585 INT zeile,spalte; /* Indexvariable bei der Belegung der Charaktertafel */
1586 INT erg=OK; /* Rueckgabewert */
1587
1588
1589
1590 /*** Test auf Ganzzahligkeit von n ************************************/
1591 CTO(INTEGER,"an_tafel",n);
1592 CE2(n,tafel,an_tafel);
1593
1594 if (S_I_I(n) <= 0L)
1595 {
1596 erg += error("an_tafel : n is negativ.");
1597 goto endr_ende;
1598 }
1599
1600 /*** Die Charaktertafel der A1, und die der A2 ist [1] ****************/
1601
1602 if ((S_I_I(n) == 2L) || (S_I_I(n) == 1L))
1603 {
1604 erg += m_ilih_m(1L,1L,tafel); /* AK 120692 */
1605 erg += m_i_i(1L,S_M_IJ(tafel,0L,0L));
1606 goto endr_ende;
1607 }
1608
1609 C1R(n,"an_tafel",tafel);
1610
1611 /*** Speicherplatzreservierung der Objekte ****************************/
1612
1613 v_part = callocobject();
1614 conpar = callocobject();
1615 par = callocobject();
1616 per = callocobject();
1617 sgn = callocobject();
1618 hilf = callocobject();
1619 split_class = callocobject();
1620 info_cc = callocobject();
1621 info_pa = callocobject();
1622
1623 /*** Initialisierung der Zahl 2 und des Partitionsvektors *************/
1624
1625 erg += makevectorofpart(n,v_part);
1626
1627 /*** Initialisierung der Infovektoren als Nullvektoren ****************/
1628
1629 erg += m_il_nv(S_V_LI(v_part),info_pa);
1630 erg += copy(info_pa,info_cc);
1631
1632 /*** Belegung der Infovektoren ****************************************/
1633 /*** Durchlaufe die Partitionen von n mit par. ***/
1634
1635 i = 0L;
1636 erg += first_partition(n,par);
1637 do
1638 {
1639 /*** Falls die Konjugiertenklasse (par) in der An liegt, wird in ***/
1640 /*** info_cc an der entsprechenden Stelle eine 1 eingetragen. ***/
1641
1642 erg += m_part_perm(par,per);
1643 erg += signum(per,sgn);
1644 if (S_I_I(sgn) == 1L)
1645 {
1646 erg += m_i_i(1L,S_V_I(info_cc,i));
1647 l++;
1648 }
1649
1650 /*** Falls par selbstassoziiert ist, wird in info_pa fuer diese ***/
1651 /*** Partition und in info_cc fuer die zugehoerige Hakenpartition ***/
1652 /*** eine 2 eingetragen. ***/
1653
1654 erg += conjugate(par,conpar);
1655 if (comp(par,conpar) == 0L)
1656 {
1657 erg += m_i_i(2L,S_V_I(info_pa,i));
1658 erg += hook_part(par,split_class);
1659 erg += m_i_i(2L,S_V_I(info_cc,indexofpart(split_class)));
1660 l++;
1661 }
1662
1663 /*** Falls par lexikographisch groesser als die dazu assoziierte ***/
1664 /*** Partition ist, erhaelt info_pa den Eintrag 1. ***/
1665
1666 else
1667 if (S_V_II(info_pa,indexofpart(conpar)) == 0L)
1668 erg += m_i_i(1L,S_V_I(info_pa,i));
1669
1670 i++;
1671 }
1672 while(next_apply(par));
1673
1674 /***********************************************************************/
1675 /*** Initialisierung der Charaktertafel als Nullmatrix *****************/
1676
1677 erg += m_ilih_m(l,l,tafel);
1678
1679 /*** Belegung der Charaktertafel ***************************************/
1680
1681 zeile = 0L;
1682 spalte = 0L;
1683
1684 /*** Durchlaufe den Infovektor der irreduziblen Darstellungen mit i ***/
1685
1686 for(i=0L;i<S_V_LI(info_pa);i++)
1687 {
1688 /*** Im Falle einer nicht zerfallenden irreduziblen Darstellung ***/
1689 /*** erstelle die dazugehoerige Zeile der Charaktertafel. ***/
1690
1691 if(S_V_II(info_pa,i)==1L)
1692 {
1693 /*** Durchlaufe den Infovektor der Konjugiertenklassen mit j. ***/
1694
1695 for(j=0L;j<S_V_LI(info_cc);j++)
1696 {
1697 /*** Liegt die Konjugiertenklasse in der An, berechne ***/
1698 /*** den entsprechenden Charakterwert der Sn. ***/
1699
1700 if(S_V_II(info_cc,j)>0L)
1701 {
1702 erg += charvalue(S_V_I(v_part,i),
1703 S_V_I(v_part,j),
1704 S_M_IJ(tafel,zeile,spalte),
1705 NULL);
1706 spalte++;
1707
1708 if(S_V_II(info_cc,j)==2L)
1709 {
1710 erg += copy(S_M_IJ(tafel,zeile,spalte-1L),
1711 S_M_IJ(tafel,zeile,spalte));
1712 spalte++;
1713 }
1714 }
1715 }
1716 zeile++;
1717 spalte = 0L;
1718 }
1719
1720 /*** Im Falle einer zerfallenden irreduziblen Darstellung ***/
1721 /*** muessen zwei Zeilen in der Charaktertafel berechnet ***/
1722 /*** werden. ***/
1723
1724 if(S_V_II(info_pa,i)==2L)
1725 {
1726 erg += hook_part(S_V_I(v_part,i),split_class);
1727
1728 /*** Durchlaufe den Infovektor der Konjugiertenklassen mit j. ***/
1729
1730 for(j=0L;j<S_V_LI(info_cc);j++)
1731 {
1732 /*** Zerfaellt die Konjugiertenklasse nicht, berechne ***/
1733 /*** den entsprechenden Charakterwert der Sn, teile ***/
1734 /*** ihn durch zwei und trage ihn in beiden Zeilen ein.***/
1735
1736 if(S_V_II(info_cc,j)==1L)
1737 {
1738 erg += charvalue(S_V_I(v_part,i), S_V_I(v_part,j), hilf, NULL);
1739 erg += div(hilf,cons_zwei,S_M_IJ(tafel,zeile,spalte));
1740 erg += copy(S_M_IJ(tafel,zeile,spalte),
1741 S_M_IJ(tafel,zeile+1L,spalte));
1742 spalte++;
1743 }
1744 /*** Falls die Konjugiertenklasse jedoch zerfaellt, ***/
1745
1746 if(S_V_II(info_cc,j)==2L)
1747 {
1748 /*** und es sich um die zugehoerige Hakenpartition ***/
1749 /*** handelt, so berechne die entsprechenden zwei ***/
1750 /*** Charakterwerte und trage sie ueber Kreuz in ***/
1751 /*** die Charaktertafel ein. ***/
1752
1753 if(eq(split_class,S_V_I(v_part,j)))
1754 {
1755 erg += wert(0L,S_V_I(v_part,j),
1756 S_M_IJ(tafel,zeile,spalte));
1757 erg += copy(S_M_IJ(tafel,zeile,spalte),
1758 S_M_IJ(tafel,zeile+1L,spalte+1L));
1759 erg += wert(1L,S_V_I(v_part,j),
1760 S_M_IJ(tafel,zeile,spalte+1L));
1761 erg += copy(S_M_IJ(tafel,zeile,spalte+1L),
1762 S_M_IJ(tafel,zeile+1L,spalte));
1763 }
1764 /*** Handelt es sich nicht um die zugehoerige Haken- ***/
1765 /*** partition, so berechne wieder den halben Wert ***/
1766 /*** des Charakters der Sn und trage diesen viermal ***/
1767 /*** in die Charaktertafel ein. ***/
1768
1769 else
1770 {
1771 erg += charvalue(S_V_I(v_part,i),
1772 S_V_I(v_part,j), hilf, NULL);
1773 erg += div(hilf,cons_zwei,S_M_IJ(tafel,zeile,spalte));
1774 COPY(S_M_IJ(tafel,zeile,spalte), S_M_IJ(tafel,zeile+1L,spalte));
1775 COPY(S_M_IJ(tafel,zeile,spalte), S_M_IJ(tafel,zeile+1L,spalte+1L));
1776 COPY(S_M_IJ(tafel,zeile,spalte), S_M_IJ(tafel,zeile,spalte+1L));
1777 }
1778
1779 spalte = spalte+2L;
1780 }
1781 }
1782 zeile = zeile+2L;
1783 spalte = 0L;
1784 }
1785 }
1786 /************************************************************************/
1787
1788 /*** Speicherplatzfreigabe ***/
1789
1790 erg += freeall(v_part);
1791 erg += freeall(conpar);
1792 erg += freeall(par);
1793 erg += freeall(per);
1794 erg += freeall(sgn);
1795 erg += freeall(hilf);
1796 erg += freeall(split_class);
1797 erg += freeall(info_cc);
1798 erg += freeall(info_pa);
1799
1800 /*** Rueckkehr in die aufrufende Routine *******************************/
1801
1802 S1R(n,"an_tafel",tafel);
1803 ENDR("an_tafel");
1804 }/*** Ende von an_tafel ***/
1805 #endif /* MATRIXTRUE */
1806
1807 /*****************************************************************************/
1808 /* Routine zur Berechnung des Charakterwertes auf der zerfallenden */
1809 /* Konjugiertenklasse (split_class) , den die zugehoerige irreduzible */
1810 /* Darstellung liefert. Der Wert wird in res zurueckgegeben. */
1811 /* Der Index gibt an, welcher der beiden konjugierten Werte berechnet */
1812 /* Rueckgabewert: OK oder error */
1813 /*****************************************************************************/
1814 /* PF 200891 V1.3 */ /* PF 070592 */ /* PF 110992 */
1815
1816 #ifdef CHARTRUE
wert(index,split_class,res)1817 INT wert(index,split_class,res) OP split_class,res; INT index;
1818 {
1819 INT i;
1820 OP expo, term_eins, term_zwei;
1821 OP n;
1822 INT erg=OK;
1823 CTO(PARTITION,"wert(2)",split_class);
1824
1825 expo = callocobject();
1826 term_eins = callocobject();
1827 term_zwei = callocobject();
1828 n = callocobject();
1829
1830 erg += weight(split_class,n);
1831 erg += copy(n,expo);
1832 erg += sub(expo,S_PA_L(split_class),term_eins);
1833 C_I_I(expo,S_I_I(term_eins)/2L);
1834 C_I_I(term_eins,-1L);
1835 erg += hoch(term_eins,expo,term_eins);
1836
1837
1838 C_I_I(expo,1L);
1839 for(i=0L;i<S_PA_LI(split_class);i++)
1840 erg += mult_apply(S_PA_I(split_class,i),expo);
1841 erg += mult_apply(term_eins,expo);
1842 erg += squareroot(expo,term_zwei);
1843
1844 if (index == 0L)
1845 erg += add(term_eins,term_zwei,res);
1846 else
1847 erg += sub(term_eins,term_zwei,res);
1848 erg += div(res,cons_zwei,res);
1849
1850
1851 erg += freeall(expo);
1852 erg += freeall(term_eins);
1853 erg += freeall(term_zwei);
1854 erg += freeall(n);
1855
1856 ENDR("wert");
1857 }
1858 #endif /* CHARTRUE */
1859
1860 /*****************************************************************************/
1861 /* DIESE ROUTINE BERECHNET ZU EINER SELBSTASSOZIIERTEN PARTITION PAR DIE */
1862 /* PARTITION, DIE AUS DEN HAKENLAENGEN VON PAR BESTEHT. */
1863 /*****************************************************************************/
1864
1865 #ifdef PARTTRUE
hook_part(par,res)1866 INT hook_part(par,res) OP par,res;
1867 /* PF 070592 */
1868 {
1869 INT i,j;
1870 INT elementwert;
1871 OP element;
1872 OP v,hilfsvector;
1873 INT erg = OK;
1874 CTO(PARTITION,"hook_part(1)",par);
1875
1876 if (not EMPTYP(res))
1877 freeself(res);
1878
1879 element=callocobject();
1880 v=callocobject();
1881 hilfsvector=callocobject();
1882
1883
1884 elementwert = S_PA_II(par,S_PA_LI(par)-1L);
1885 elementwert = 2L *elementwert - 1L;
1886 erg += m_i_i(elementwert,element);
1887 erg += m_o_v(element,v);
1888 j = 2L;
1889 for (i=S_PA_LI(par)-2L; i>=0L; i--)
1890 {
1891 elementwert = S_PA_II(par,i);
1892 elementwert = 2L *(elementwert-j) + 1L;
1893 if (elementwert > 0L)
1894 {
1895 erg += c_i_i(element,elementwert);
1896 erg += append(v,element,hilfsvector);
1897 erg += copy(hilfsvector,v);
1898 }
1899 j++;
1900 }
1901
1902 erg += m_v_pa(v,res);
1903
1904 erg += freeall(v);
1905 erg += freeall(element);
1906 erg += freeall(hilfsvector);
1907
1908 ENDR("hook_part");
1909 }
1910 #endif /* PARTTRUE */
1911
1912 #ifdef PERMTRUE
m_gl_first(a,b)1913 INT m_gl_first(a,b) OP a,b;
1914 /* AK 291092 */
1915 {
1916 if (CYCLIC_GL(a))
1917 return first_permutation(S_GL_CYCLIC_A(a),b);
1918 if (SYM_GL(a))
1919 return first_permutation(S_GL_SYM_A(a),b);
1920 if (ALT_GL(a))
1921 return first_permutation(S_GL_ALT_A(a),b);
1922 return error("m_gl_first: can not handle group label");
1923 }
1924
m_gl_next(a,b,c)1925 INT m_gl_next(a,b,c) OP a,b,c;
1926 /* AK 291092 */
1927 /* loop over all group elements */
1928 {
1929 OP d;
1930 INT erg,i,j;
1931 if (b == c)
1932 {
1933 d = callocobject();
1934 *d = *c;
1935 C_O_K(c,EMPTY);
1936 erg = m_gl_next(a,d,c);
1937 freeall(d);
1938 return erg;
1939 }
1940 if (SYM_GL(a))
1941 {
1942 return next(b,c);
1943 }
1944 if (ALT_GL(a))
1945 {
1946 erg = next(b,c);
1947 if (erg == FALSE)
1948 return erg; /* d.h. b war letzte permutation */
1949 while (oddp(c))
1950 {
1951 erg = next_apply(c);
1952 if (erg == FALSE) /* es gibt kein permutation aus an
1953 nach der permutation b */
1954 {
1955 copy(b,c);
1956 return FALSE;
1957 }
1958 }
1959 return TRUE;
1960 }
1961 if (CYCLIC_GL(a))
1962 {
1963 if (S_P_II(b,0L) == S_P_LI(b))
1964 return FALSE; /* war die letzte */
1965 copy(b,c);
1966 for (i=1L,j=0L;i<S_P_LI(c); i++,j++)
1967 M_I_I(S_P_II(b,i),S_P_I(c,j));
1968 M_I_I(S_P_II(b,0L),S_P_I(c,j));
1969 return TRUE;
1970 }
1971 return error("m_gl_next: can not handle group label");
1972 }
1973 #endif /* PERMTRUE */
1974
1975
companion_matrix(p,m)1976 static INT companion_matrix(p,m) OP p,m;
1977 /* the characteristic polynom of the companion matrix
1978 is the polynom p */
1979 {
1980 INT erg = OK,i;
1981 OP d,z,nu;
1982 d = CALLOCOBJECT();
1983 nu = CALLOCOBJECT();
1984 degree_polynom(p,d);
1985 m_lh_m(d,d,m);
1986 null(S_PO_K(p),nu);
1987
1988 FORALL(z,m,{ copy(nu,z); });
1989 for (i=1;i<S_M_HI(m);i++) eins(S_PO_K(p),S_M_IJ(m,i,i-1));
1990 FORALL(z,p,{
1991 i = S_MO_SII(z,0);
1992 if (i < S_M_LI(m))
1993 addinvers(S_MO_K(z),S_M_IJ(m,i,S_M_LI(m)-1));
1994 });
1995 FREEALL2(nu,d);
1996 ENDR("companion_matrix");
1997 }
1998
all_irred_companion(n,q,v)1999 static INT all_irred_companion(n,q,v) OP n,q,v;
2000 {
2001 INT erg = OK;
2002 CTO(INTEGER,"all_irred_companion(1)",n);
2003 SYMCHECK(S_I_I(n)<1,"all_irred_companion:degree < 1");
2004 CTO(INTEGER,"all_irred_companion(2)",q);
2005 SYMCHECK(prime_power_p(q)==FALSE,"all_irred_companion(2): no prime power");
2006 {
2007 #ifdef FFTRUE
2008 if (einsp(n) )
2009 {
2010 OP ff=callocobject();INT i;
2011 first_ff_given_q(q,ff);/* Nul*/
2012 m_il_v(S_I_I(q)-1,v);
2013 for (i=0;i<S_V_LI(v);i++) {
2014 next(ff,ff);
2015 m_lh_m(n,n,S_V_I(v,i));
2016 copy(ff,S_M_IJ(S_V_I(v,i),0,0));
2017 }
2018 FREEALL(ff);
2019 }
2020 else {
2021 OP p;INT i;
2022 p = CALLOCOBJECT();
2023 all_irred_polynomials(n,q,p);
2024 m_il_v(S_V_LI(p),v);
2025 for (i=0;i<S_V_LI(v);i++)
2026 companion_matrix(S_V_I(p,i),S_V_I(v,i));
2027 FREEALL(p);
2028 }
2029 #endif
2030 }
2031 ENDR("all_irred_companion");
2032 }
2033
J_matrix(n,q,m)2034 static INT J_matrix(n,q,m) OP n,q,m;
2035 {
2036 INT j; OP y;
2037 m_lh_m(n,n,m);
2038 FORALL(y,m,{ null_ff_given_q(q,y); });
2039 for (j=0;j<S_M_HI(m);j++) eins_ff_given_q(q,S_M_IJ(m,j,j));
2040 for (j=1;j<S_M_HI(m);j++) eins_ff_given_q(q,S_M_IJ(m,j,j-1));
2041 }
2042
all_blocks(n,q,v)2043 static INT all_blocks(n,q,v) OP n,q,v;
2044 /* alle f�llungen eines blocks der gr�sse n */
2045 {
2046 OP d,z,y;INT i,j;
2047 INT erg = OK;
2048 d = CALLOCOBJECT();
2049 m_il_v(0,v);
2050 alle_teiler(n,d);
2051
2052 for (i=0;i<S_V_LI(d);i++) {
2053 /* if (EINSP(S_V_I(d,i))) {
2054 inc(v); z = S_V_I(v,S_V_LI(v)-1);
2055 J_matrix(n,q,z);
2056 }
2057 else
2058 if (EQ(n,S_V_I(d,i))) {
2059 OP yy;
2060 yy=CALLOCOBJECT();
2061 all_irred_companion(n,q,yy);
2062 append(yy,v,v);
2063 FREEALL(yy);
2064 }
2065 else */ {
2066 OP teil= callocobject();
2067 OP v2= callocobject();
2068 OP j2= callocobject();
2069 ganzdiv(n,S_V_I(d,i),teil);
2070 all_irred_companion(teil,q,v2);
2071 J_matrix(S_V_I(d,i),q,j2);
2072
2073
2074
2075 FORALL(z,v2, {kronecker_product(j2,z,z); });
2076
2077
2078 append(v2,v,v);
2079 FREEALL3(j2,teil,v2);
2080 }
2081
2082 }
2083 FREEALL(d);
2084 ENDR("all_blocks");
2085 }
2086
class_label_glnq(n,q,v)2087 INT class_label_glnq(n,q,v) OP n,q,v;
2088 {
2089 INT erg = OK;
2090 C2R(n,q,"class_label_glnq",v);
2091 erg += class_label_glnq_co(n,q,v,NULL);
2092 S2R(n,q,"class_label_glnq",v);
2093 ENDR("class_label_glnq");
2094 }
2095
class_label_glnq_co(n,q,v,pav)2096 INT class_label_glnq_co(n,q,v,pav) OP n,q,v;OP pav;
2097 {
2098 OP pa,cm;INT i,erg=OK,j,k;
2099 CALLOCOBJECT2(pa,cm);
2100 m_l_v(n,cm);
2101 for (i=0;i<S_V_LI(cm);i++)
2102 {
2103 m_i_i(1+i,pa); all_blocks(pa,q,S_V_I(cm,i));
2104 }
2105
2106 m_il_v(0,v);
2107 if (pav != NULL) m_il_v(0,pav);
2108 first_partition(n,pa);
2109 do {
2110 OP vc= callocobject();
2111 OP uc= callocobject();
2112 OP f= callocobject();
2113 m_l_v(S_PA_L(pa),vc);
2114 m_l_nv(S_PA_L(pa),uc);
2115 for (i=0;i<S_V_LI(vc);i++) M_I_I(S_V_LI(S_V_I(cm,S_PA_II(pa,i)-1)), S_V_I(vc,i));
2116 /* vc entha�lt die anzahl der m�glichen block eintr�ge */
2117
2118 again:
2119 m_lh_m(n,n,f);
2120 for (i=0;i<S_M_HI(f);i++)
2121 for (j=0;j<S_M_LI(f);j++) null_ff_given_q(q,S_M_IJ(f,i,j));
2122 for (i=0,j=0;i<S_PA_LI(pa);i++)
2123 {
2124 INT ii,jj;
2125 OP z = S_V_I(cm,S_PA_II(pa,i)-1); /* von hier wird der block geholt*/
2126 for (ii=0;ii<S_PA_II(pa,i);ii++)
2127 for (jj=0;jj<S_PA_II(pa,i);jj++) copy(S_M_IJ(S_V_I(z,S_V_II(uc,i)),ii,jj),
2128 S_M_IJ(f,j+ii,j+jj));
2129 j+=S_PA_II(pa,i);
2130 }
2131 inc(v); SWAP(f,S_V_I(v,S_V_LI(v)-1));
2132 if (pav != NULL) { inc(pav); copy(pa,S_V_I(pav,S_V_LI(pav)-1));}
2133
2134 /* compute next label */
2135 for (i=S_V_LI(uc)-1;i>=0;i--)
2136 if ( S_V_II(uc,i) < S_V_II(vc,i)-1) {
2137 if (i==0) { incr: inc(S_V_I(uc,i));
2138 for (j=i+1;j<S_V_LI(uc); j++) m_i_i(0,S_V_I(uc,j));
2139 goto again; }
2140 else if (S_PA_II(pa,i) > S_PA_II(pa,i-1)) goto incr;
2141 else if (S_V_II(uc,i) < S_V_II(uc,i-1) ) goto incr;
2142 else continue;
2143 }
2144
2145 /* keine weitere klasse */
2146 FREEALL3(f,uc,vc);
2147 } while(next_apply(pa));
2148 FREEALL2(pa,cm);
2149 ENDR("class_label_glnq");
2150 }
2151
2152
2153 /* for the computation of c_ijk with group labels */
2154 /* AK 080306 */
2155
2156 /* berechnung c_ijk mit gl */
2157
class_rep(OP gl,OP cl,OP res)2158 INT class_rep(OP gl, OP cl, OP res)
2159 /* AK 080306 */
2160 /* input group label gl
2161 class label cl
2162 output representing element */
2163 {
2164 INT erg = OK;
2165 if (SYM_GL(gl))
2166 erg += m_part_perm(cl,res);
2167 else if (ALT_GL(gl)) {
2168 if (S_O_K(cl) == PARTITION)
2169 erg += m_part_perm(cl,res);
2170 else if (S_O_K(cl)==VECTOR)
2171 {
2172 erg += std_perm(S_V_I(cl,0),res);
2173 if (S_V_II(cl,1)==1) {
2174 OP trans=callocobject();
2175 make_n_kelmtrans(S_P_L(res),cons_eins,trans);
2176 mult(res,trans,res);
2177 mult(trans,res,res);
2178 freeall(trans);
2179 }
2180 }
2181 else
2182 error("class_rep(1): wrong cl for alternating group");
2183 }
2184 else
2185 NYI("class_rep");
2186 ENDR("class_rep");
2187 }
2188
class_label(OP gl,OP ge,OP res)2189 INT class_label(OP gl, OP ge, OP res)
2190 /* AK 080306 */
2191 /* gl is grouplabel
2192 ge is a group element
2193 res becomes the corresponding class label */
2194 {
2195 return m_gl_ge_cl(gl,ge,res);
2196 }
2197
compute_gl_charvalue(OP gl,OP il,OP cl,OP res)2198 INT compute_gl_charvalue(OP gl, OP il, OP cl, OP res)
2199 /* computes value of the irreducible character il
2200 on the class cl */
2201 {
2202 INT erg = OK;
2203 if (SYM_GL(gl))
2204 erg += charvalue(il,cl,res,NULL);
2205 else if (ALT_GL(gl)) {
2206 OP h=callocobject();
2207 class_rep(gl,cl,h);
2208 if (S_O_K(il) == VECTOR)
2209 erg += a_charvalue_co(S_V_I(il,0),h,res,S_V_II(il,1));
2210 else
2211 erg += a_charvalue_co(il,h,res,0);
2212 freeall(h);
2213 }
2214 else
2215 NYI("compute_gl_charvalue");
2216 ENDR("compute_gl_charvalue");
2217 }
2218
compute_gl_il_dimension(OP gl,OP il,OP res)2219 INT compute_gl_il_dimension(OP gl, OP il, OP res)
2220 {
2221 INT erg = OK;
2222 if (SYM_GL(gl))
2223 erg += dimension(il,res);
2224 else if (ALT_GL(gl)) {
2225 if (S_O_K(il) == VECTOR)
2226 {
2227 erg += dimension(S_V_S(il),res);
2228 erg += half_apply(res);
2229 }
2230 else
2231 erg += dimension(il,res);
2232 }
2233 else
2234 NYI("compute_gl_il_dimension");
2235 ENDR("compute_gl_il_dimension");
2236 }
2237
compute_gl_cl_classorder(OP gl,OP cl,OP res)2238 INT compute_gl_cl_classorder(OP gl, OP cl, OP res)
2239 {
2240 INT erg = OK;
2241 if (SYM_GL(gl))
2242 erg += ordcon(cl,res);
2243 else if (ALT_GL(gl)) {
2244 if (S_O_K(cl) == VECTOR)
2245 {
2246 erg += ordcon(S_V_S(cl),res);
2247 erg += half_apply(res);
2248 }
2249 else
2250 erg += ordcon(cl,res);
2251 }
2252 else
2253 NYI("compute_gl_cl_classorder");
2254 ENDR("compute_gl_cl_classorder");
2255 }
2256
2257
compute_gl_c_ijk(OP gl,OP i,OP j,OP k,OP res)2258 INT compute_gl_c_ijk(OP gl, OP i, OP j, OP k, OP res)
2259 /* AK 080306 */
2260 /* gl is grouplabel
2261 i,j,k are class labels of this group label
2262 res will be the result */
2263 {
2264 INT erg = OK;
2265 if (SYM_GL(gl))
2266 c_ijk_sn(i,j,k,res);
2267 else {
2268 /* we use the formula of curtis reiner */
2269 OP il,h,ki,h1,h2,h3;
2270 INT l;
2271 CALLOCOBJECT3(il,h,ki);
2272 CALLOCOBJECT3(h1,h2,h3);
2273
2274 m_i_i(0,res);
2275 /* ki is the class containing the inverse element */
2276 class_rep(gl,k,h1); invers(h1,h1); class_label(gl,h1,ki);
2277
2278 m_gl_il(gl,il);
2279 for (l=0;l<S_V_LI(il);l++) /* over all irreducible characters */
2280 {
2281 compute_gl_charvalue(gl,S_V_I(il,l),i,h1);
2282 compute_gl_charvalue(gl,S_V_I(il,l),j,h2);
2283 compute_gl_charvalue(gl,S_V_I(il,l),ki,h3);
2284 mult(h1,h2,h);mult_apply(h3,h);
2285 compute_gl_il_dimension(gl,S_V_I(il,l),h1);
2286 div(h,h1,h);
2287 add_apply(h,res);
2288 }
2289
2290 /* class orders */
2291 compute_gl_cl_classorder(gl,i,h1); mult_apply(h1,res);
2292 compute_gl_cl_classorder(gl,j,h1); mult_apply(h1,res);
2293 /* divide by group order */
2294 m_gl_go(gl,h1); div(res,h1,res);
2295 FREEALL3(il,h,ki);
2296 FREEALL3(h1,h2,h3);
2297
2298 }
2299 ENDR("compute_gl_c_ijk");
2300 }
2301
2302
2303