1
2 /*****************************************************************************/
3 /* BERECHNUNG DER PROJEKTIVEN MATRIXDARSTELLUNG DER S_n */
4 /* NACH NAZAROV */
5 /*****************************************************************************/
6 /* Christine Barop Jan.93 */
7 /*****************************************************************************/
8
9 #include "def.h"
10 #include "macro.h"
11 #define PR_RH_MAX (INT)100
12
13 static OP S_lambda; /* Vektor mit allen standard shifted */
14 /* Tableaux mit Umriss lambda */
15 static OP phi, rho; /* Nazarov's phi- und rho-Funktion */
16 static OP zwei, vier, m_eins, compl, m_compl; /* Konstanten */
17 static OP e; /* Starteitrag von S_lambda */
18 static OP M; /* Vektor mit den Basismatr. der Cliff.alg */
19 static OP E, I, J, K; /* Pauli- Basis */
20 static OP A, B; /* Operation von t_k auf S_lambda */
21 static OP G; /* Indices der M-Matr. im Tensorprod.*/
22
23
24 static INT rh_ccsert();
25 static INT rh_ccstka();
26 static INT rh_cnsert();
27 static INT rh_celete();
28 static INT rh_cusgabemat();
29 static INT ccstka_tab_partition();
30 static INT phi_funkt();
31 static INT rho_funkt();
32 static INT ini_kons();
33 static INT ini_slam();
34 static INT pauli();
35 static INT m_matr();
36 static INT ab_matr();
37 static INT hoehe();
38
prsym(lambda,T_v)39 INT prsym(lambda, T_v) OP lambda, T_v;
40
41 /*****************************************************************************/
42 /* BERECHNUNG DER PROJEKTIVEN MATRIXDARSTELLUNG DER TRANSPOSITION t_k */
43 /* NACH NAZAROV */
44 /*****************************************************************************/
45 /* Christine Barop Jan.93 */
46 /*****************************************************************************/
47
48
49
50 {
51 INT i,j,l,ll, nr; /* Zaehlvariablen */
52 INT len; /* #(S_lambda) */
53 INT k; /* Index der Transposition */
54 INT m; /* 2*m +1 = Rang der Clifford--Alg. */
55 INT g; /* Nazarov's g--Funktion */
56 INT m_lambda, n_lambda; /* Laenge und max. Teil der Part.*/
57 INT dim, hi, lf; /* Hilfsvariablen */
58 OP eps; /* epsilon-Parameter */
59 OP n; /* Gewicht der Partition */
60 OP T_k; /* Darstellende Matrix von t_k */
61 OP M_eins, M_zwei; /* M_g und M_(g-1) */
62 OP kk; /* Nummer der Transposition */
63 OP p, q; /* Hoehe von k, k+1 im Tableau */
64 OP x, y/* , z*/; /* Hilfsvariablen fuer versch. Zwecke*/
65 OP gg; /* Nazarov's g-Funktion als INT */
66 OP D; /* Darstellende Matrix */
67
68
69 n=callocobject();
70 p=callocobject();
71 q=callocobject();
72 x=callocobject();
73 y=callocobject();
74 phi=callocobject();
75 rho=callocobject();
76 S_lambda=callocobject();
77 e=callocobject();
78 eps=callocobject();
79 zwei=callocobject();
80 vier=callocobject();
81 m_eins=callocobject();
82 compl=callocobject();
83 m_compl=callocobject();
84 A=callocobject();
85 M=callocobject();
86 E=callocobject();
87 I=callocobject();
88 J=callocobject();
89 K=callocobject();
90 B=callocobject();
91 T_k=callocobject();
92 G=callocobject();
93 D=callocobject();
94 M_eins=callocobject();
95 M_zwei=callocobject();
96 kk=callocobject();
97 gg=callocobject();
98
99
100 ini_kons();
101 pauli();
102 ini_slam();
103
104
105
106 weight(lambda,n);
107
108 /* Berechnung von S_lambda */
109 ccstka_tab_partition(lambda,n);
110
111 /* Dimensionen und Hilfsgroessen */
112 m_lambda = S_PA_LI(lambda);
113 n_lambda = S_PA_II(lambda,m_lambda-1L);
114
115 m_i_i(m_lambda,x);
116 sub(n,x,y);
117 ganzdiv(y,zwei,y);
118 m=S_I_I(y);
119
120 m_ilih_m(1L,1L,eps);
121 copy(cons_eins,S_M_IJ(eps,0L,0L));
122
123 m_matr(m,eps);
124
125
126 /* Anzahl der Tableaux */
127 len=0L;
128 while(S_M_LI(S_V_I(S_lambda,len++))!=1L);
129 len--;
130
131 /* Berechnung der T_k */
132 add(n,cons_eins,x);
133 m_l_v(x,T_v);
134 for(i=0L;i<S_I_I(x);i++)
135 copy(e,S_V_I(T_v,i));
136 for(k=1L;k<S_I_I(n);k++)
137 {
138 ab_matr(m_lambda,n_lambda,len,k);
139
140 /* Berechnung von T_k */
141 m_i_i(m,x);
142 hoch(zwei,x,y);
143 dim = S_I_I(y);
144 hi = dim*len;
145 m_ilih_nm(hi,hi,T_k);
146 m_ilih_nm(dim,dim,M_eins);
147 m_ilih_nm(dim,dim,M_zwei);
148
149 for(i=0;i<len;i++)
150 for(j=0;j<len;j++)
151 {
152 copy(S_M_IJ(G,i,j),gg);
153 g=S_I_I(gg);
154 if(g>0L)
155 {
156 copy(S_V_I(M,g),M_eins);
157 copy(S_V_I(M,g-1L),M_zwei);
158 for(l=0;l<dim;l++)
159 for(ll=0;ll<dim;ll++)
160 {
161
162 mult(S_M_IJ(A,i,j),S_M_IJ(M_eins,l,ll),x);
163 if(g>1L)
164 mult(S_M_IJ(B,i,j),S_M_IJ(M_zwei,l,ll),y);
165 else
166 m_i_i(0L,y);
167
168 hi = i*dim +l;
169 lf=j*dim +ll;
170 add(x,y,S_M_IJ(T_k,hi,lf));
171 }
172 }
173 }
174 copy(T_k,S_V_I(T_v,k));
175 }
176 hi = S_M_LI(S_V_I(T_v,1));
177 m_ilih_nm(hi,hi,T_k);
178 for(l=0;l<hi;l++)
179 copy(m_eins,S_M_IJ(T_k,l,l));
180 copy(T_k,S_V_I(T_v,0));
181
182
183
184 freeall(D);
185 freeall(T_k);
186 freeall(M_eins);
187 freeall(M_zwei);
188 freeall(E);
189 freeall(I);
190 freeall(J);
191 freeall(K);
192 freeall(eps);
193 freeall(vier);
194 freeall(m_eins);
195 freeall(compl);
196 freeall(m_compl);
197 freeall(M);
198 freeall(n);
199 freeall(p);
200 freeall(q);
201 freeall(x);
202 freeall(y);
203 freeall(rho);
204 freeall(phi);
205 freeall(zwei);
206 freeall(S_lambda);
207 freeall(e);
208 freeall(A);
209 freeall(B);
210 freeall(G);
211 freeall(kk);
212 freeall(gg);
213 }
214
215 typedef INT PR_INTARRAY[PR_RH_MAX];
216
ini_kons()217 static INT ini_kons()
218 {
219 /* Setzen der Konstanten */
220 m_ilih_nm((INT)1,(INT)1,e);
221 m_i_i(2L,zwei);
222 m_i_i(4L,vier);
223 m_i_i(-1L,m_eins);
224 squareroot(m_eins,compl);
225 mult(m_eins,compl,m_compl);
226 return(OK);
227 }
228
pauli()229 static INT pauli()
230 {
231 /* Pauli-Basis */
232 m_ilih_nm(2L,2L,E);
233 m_ilih_nm(2L,2L,I);
234 m_ilih_nm(2L,2L,J);
235 m_ilih_nm(2L,2L,K);
236
237 copy(cons_eins,S_M_IJ(E,0L,0L));
238 copy(cons_eins,S_M_IJ(E,1L,1L));
239 copy(compl,S_M_IJ(I,1L,0L));
240 copy(m_compl,S_M_IJ(I,0L,1L));
241 copy(cons_eins,S_M_IJ(J,0L,0L));
242 copy(m_eins,S_M_IJ(J,1L,1L));
243 copy(cons_eins,S_M_IJ(K,0L,1L));
244 copy(cons_eins,S_M_IJ(K,1L,0L));
245 return(OK);
246 }
247
ini_slam()248 static INT ini_slam()
249 {
250 INT i;
251 /* Vorbesetzen von S_lambda */
252 m_il_v(PR_RH_MAX,S_lambda);
253 for(i=0L;i<PR_RH_MAX;i++)
254 copy(e,S_V_I(S_lambda,i));
255 return(OK);
256 }
257
258
ccstka_tab_partition(a,nn)259 static INT ccstka_tab_partition(a,nn) OP a,nn;
260 {
261 INT i,j;
262 INT *um,*pa, m_a, n;
263 INT (* tab)[PR_RH_MAX];
264
265 tab = (PR_INTARRAY *) SYM_calloc(PR_RH_MAX*PR_RH_MAX,sizeof(INT));
266 um = (INT *) SYM_malloc(PR_RH_MAX * sizeof(INT));
267 pa = (INT *) SYM_malloc(PR_RH_MAX * sizeof(INT));
268
269
270
271 n = S_I_I(nn);
272 m_a = S_PA_LI(a);
273 for(i=1L;i<=m_a;i++)
274 um[i] = pa[i] = S_PA_II(a,m_a-i);
275
276
277 for(i=1L;i<=m_a; i++)
278 for(j=1L;j<i; j++)
279 tab[i][j]= -7L;
280
281
282 rh_ccstka(tab,1L,1L,um,m_a,pa,n);
283 SYM_free(um);
284 SYM_free(pa);
285 SYM_free(tab);
286 return(OK);
287 }
288
289
rh_ccstka(tab,st,k,um,m,pa,n)290 static INT rh_ccstka(tab,st,k,um,m,pa,n)
291 INT tab[PR_RH_MAX][PR_RH_MAX];
292 INT um[PR_RH_MAX];
293 INT pa[PR_RH_MAX];
294 INT st,n,k,m;
295 {
296 INT l,p,q;
297
298
299 if(st==n+1L)
300 rh_cusgabemat(tab,m,pa[1]);
301 if(st!=n+1L)
302 {
303 for(l=k;l<=m;l++)
304 {
305 if(um[l]>0L)
306 {
307 p=pa[l]-um[l]+l-1;
308 if((l==1L)||(tab[l-1][p+1]!=0L))
309 {
310 um[l]--;
311 rh_ccsert(tab,st,l,p+1L);
312 rh_ccstka(tab,st+1L,1L,um,m,pa,n);
313 rh_celete(tab,st,l,p+1L);
314 um[l]++;
315 }
316 }
317 }
318 }
319 }
320
321
322
323
rh_cusgabemat(tab,z,s)324 static INT rh_cusgabemat(tab,z,s)
325 INT tab[PR_RH_MAX][PR_RH_MAX],z,s;
326 /* c ist liste, d ist umriss */
327 /* Ralf Hager 1989 */ /* AK 281289 V1.1 */ /* AK 210891 V1.3 */
328 {
329 INT i;
330 INT j;
331 OP e = callocobject();
332 OP f = callocobject();
333
334 m_ilih_nm(s+1L,z+1L,f);
335 for (i=0L;i <=z; i++)
336 for (j=0L;j <=s; j++)
337 if(tab[i][j] > 0L)
338 m_i_i(tab[i][j],S_M_IJ(f,i,j));
339
340
341 for(i=0L;i<=PR_RH_MAX;i++)
342 if(S_M_LI(S_V_I(S_lambda,i))==1L)
343 {
344 copy(f,S_V_I(S_lambda,i));
345 break;
346 }
347
348 freeall(e); /* AK 130392 */
349 freeall(f); /* AK 071093 */
350 return OK;
351 }
352
353
rh_ccsert(v,zz,i,j)354 static INT rh_ccsert(v,zz,i,j) INT v[PR_RH_MAX][PR_RH_MAX];
355 INT zz,i,j;
356 {
357 v[i][j]=zz;
358 return(OK);
359 }
360
rh_celete(v,z,i,j)361 static INT rh_celete(v,z,i,j) INT v[PR_RH_MAX][PR_RH_MAX];
362 INT z,i,j;
363 {
364
365 v[i][j]=0L;
366 return(OK);
367 }
368
m_matr(m,eps)369 static INT m_matr(m,eps) OP eps; INT m;
370 /* CB */
371 {
372 OP EM = callocobject();
373 OP JM = callocobject();
374 OP x = callocobject();
375 OP y = callocobject();
376
377 INT i,i_eins;
378 /* Berechnung der M-Matrizen */
379 i_eins = m;
380 i_eins++;
381 m_il_v(i_eins,EM);
382 m_il_v(i_eins,JM);
383 i_eins--;
384 i_eins = 2L*i_eins+2L;
385 m_il_v(i_eins,M);
386
387 m_ilih_m(1L,1L,x);
388 copy(cons_eins,S_M_IJ(x,0L,0L));
389 copy(x,S_V_I(EM,0L));
390 copy(x,S_V_I(JM,0L));
391
392 for(i=1; i<= m; i++)
393 {
394 kronecker_product(E,S_V_I(EM,i-1L),x);
395 kronecker_product(J,S_V_I(JM,i-1L),y);
396 copy(x,S_V_I(EM,i));
397 copy(y,S_V_I(JM,i));
398 }
399 copy(S_V_I(JM,m),S_V_I(M,1L));
400
401 for(i=1;i<=m;i++)
402 {
403 kronecker_product(K,S_V_I(JM,m-i),x);
404 kronecker_product(S_V_I(EM,i-1L),x,x);
405 kronecker_product(eps,x,S_V_I(M,2*i),x);
406 kronecker_product(I,S_V_I(JM,m-i),x);
407 kronecker_product(S_V_I(EM,i-1L),x,x);
408 kronecker_product(eps,x,S_V_I(M,2*i+1L));
409 }
410
411 freeall(EM);
412 freeall(JM);
413 freeall(x);
414 freeall(y);
415
416 return(OK);
417 }
418
ab_matr(m_lambda,n_lambda,len,k)419 static INT ab_matr(m_lambda,n_lambda,len,k) INT len,k; INT m_lambda, n_lambda;
420 {
421 /* Berechnung der A- und ggf. B-Matrizen */
422 OP T =callocobject();
423 OP gg = callocobject();
424 OP p = callocobject();
425 OP q = callocobject();
426 OP Th = callocobject();
427 OP x = callocobject();
428 OP kk = callocobject();
429 INT j,l,g;
430 INT pp, qq; /* Hoehe von k, k+1 im Tableau */
431 INT *ppp, *qqq; /* Hoehe von k, k+1 im Tableau */
432 INT *ip, *jp, *iq, *jq; /* Koordinaten von k, k+1 im Tableau */
433 INT *hilf; /* Schon betrachtete Tableaux */
434
435 hilf = (INT *) SYM_malloc(PR_RH_MAX * sizeof(INT));
436 ppp = (INT *) SYM_malloc(sizeof(INT));
437 qqq = (INT *) SYM_malloc(sizeof(INT));
438 jp = (INT *) SYM_malloc(sizeof(INT));
439 ip = (INT *) SYM_malloc(sizeof(INT));
440 iq = (INT *) SYM_malloc(sizeof(INT));
441 jq = (INT *) SYM_malloc(sizeof(INT));
442
443 m_ilih_nm(len,len,A);
444 m_ilih_nm(len,len,B);
445 m_ilih_nm(len,len,G);
446 for(j=0L;j<len;j++)
447 hilf[j]=0;
448
449 for(j=0L;j<len;j++)
450 {
451 if(hilf[j]==0L)
452 {
453 copy(S_V_I(S_lambda,j),T);
454
455 hoehe(k,T,m_lambda,n_lambda,ppp,ip,jp);
456 pp = *ppp;
457 m_i_i(pp,p);
458
459 hoehe(k+1L,T,m_lambda,n_lambda,qqq,iq,jq);
460 qq = *qqq;
461 m_i_i(qq,q);
462
463 /* Nazarov's g-Funktion */
464 g=k+1;
465 for(l=1L;l<=m_lambda;l++)
466 {
467 if(S_M_IJI(T,l,l)<=k+1L)
468 g--;
469 }
470
471 m_i_i(g,gg);
472 copy(gg,S_M_IJ(G,j,j)); /* Tensorprodukt mit M_g! */
473
474 /* Besetzen der A- und ggf. B-Matrizen */
475 if(qq!=0L)
476 phi_funkt(p,q,cons_eins,zwei);
477 if(qq==0L)
478 {
479 phi_funkt(q,p,cons_eins,zwei);
480 mult(phi,m_eins,phi);
481 }
482
483 copy(phi,S_M_IJ(A,j,j));
484
485 if(pp*qq !=0L) /* weder k noch k+1 auf der Hauptdiagonalen */
486 {
487 phi_funkt(q,p,cons_eins,zwei);
488 mult(phi,m_eins,phi);
489 copy(phi,S_M_IJ(B,j,j));
490 }
491 hilf[j]=1;
492
493 if((pp-qq)*(pp-qq)!=1L) /* k und k+1 vertauschbar */
494 {
495 rho_funkt(p,q,pp,qq,cons_eins,zwei);
496
497 copy(T,Th);
498 m_i_i(k,kk);
499 m_i_i(k+1L,x);
500 copy(kk,S_M_IJ(Th,*iq,*jq));
501 copy(x,S_M_IJ(Th,*ip,*jp));
502
503 l=0;
504 while(comp(Th,S_V_I(S_lambda,l++))!=0L);
505 l--;
506
507 if(pp!=0L)
508 phi_funkt(q,p,cons_eins,zwei);
509 if(pp==0L)
510 {
511 phi_funkt(p,q,cons_eins,zwei);
512 mult(phi,m_eins,phi);
513 }
514
515 copy(phi,S_M_IJ(A,l,l));
516 copy(rho,S_M_IJ(A,j,l));
517 copy(rho,S_M_IJ(A,l,j));
518
519 if(pp*qq !=0L)
520 {
521 phi_funkt(p,q,cons_eins,zwei);
522 mult(phi,m_eins,phi);
523
524 copy(phi,S_M_IJ(B,l,l));
525 copy(rho,S_M_IJ(B,j,l));
526 copy(rho,S_M_IJ(B,l,j));
527 }
528
529 copy(gg,S_M_IJ(G,l,l));
530 copy(gg,S_M_IJ(G,j,l));
531 copy(gg,S_M_IJ(G,l,j));
532
533 hilf[l]=1;
534 }
535
536 }
537 }
538 SYM_free(hilf);
539 SYM_free(ppp);
540 SYM_free(qqq);
541 SYM_free(ip);
542 SYM_free(iq);
543 SYM_free(jp);
544 SYM_free(jq);
545 freeall(T);
546 freeall(gg);
547 freeall(p);
548 freeall(q);
549 freeall(Th);
550 freeall(x);
551 freeall(kk);
552
553 return(OK);
554 }
555
hoehe(u,T,m_lambda,n_lambda,diff,ikor,jkor)556 static INT hoehe(u,T,m_lambda,n_lambda,diff,ikor,jkor)
557 OP T;
558 INT u, m_lambda, n_lambda;
559 INT *diff, *ikor, *jkor;
560 {
561 INT l,ll;
562 for(l=1L;l<=m_lambda;l++)
563 for(ll=l;ll<=n_lambda;ll++)
564 if(S_M_IJI(T,l,ll)==u)
565 {
566 *diff=ll-l;
567 *ikor = l;
568 *jkor = ll;
569 break;
570 }
571 return(OK);
572 }
573
phi_funkt(p,q,para_eins,para_zwei)574 static INT phi_funkt(p,q,para_eins,para_zwei) OP p,q,para_eins,para_zwei;
575 /* CB 0193 */
576 {
577 OP x = callocobject();
578 OP y = callocobject();
579 OP z = callocobject();
580
581 add(q,para_eins,y);
582 mult(q,y,x);
583 mult_apply(para_zwei,x);
584 squareroot(x,x);
585 add_apply(p,y);
586 sub(p,q,z);
587 mult(y,z,y);
588 div(x,y,phi);
589
590 freeall(x);
591 freeall(y);
592 freeall(z);
593
594 return(OK);
595 }
596
rho_funkt(p,q,pp,qq,para_eins,zwei)597 static INT rho_funkt(p,q,pp,qq,para_eins,zwei) OP p,q,para_eins,zwei; INT pp,qq;
598 {
599 OP x = callocobject();
600 OP y = callocobject();
601 OP z = callocobject();
602
603 sub(p,q,x);
604 add(p,q,y);
605 add(y,para_eins,y);
606 mult(x,x,x);
607 mult(y,y,y);
608 div(para_eins,x,x);
609 div(para_eins,y,y);
610 sub(para_eins,x,x);
611 sub(para_eins,y,y);
612 mult(x,y,z);
613 div(z,zwei,z);
614 if(pp==0 || qq==0L) /* k oder k+1 auf der Hauptdiag. */
615 mult(z,zwei,z);
616 squareroot(z,rho);
617 freeall(x);
618 freeall(y);
619 freeall(z);
620 return(OK);
621 }
622