C++ Interface to Tauola
demo-factory/back/attic/tauola_photos_ini.F
1 C this file is created by hand from taumain.F
2 C actions: Remove routines: TAUDEM DECTES TAUFIL FILHEP
3 C add: INIETC will not necesarily work fine ...
4 C replace TRALO4
5 C rename INIPHY to INIPHX
6  SUBROUTINE inietc(jakk1,jakk2,itd,ifpho)
7  COMMON / idfc / idff
8  COMMON / taurad / xk0dec,itdkrc
9  DOUBLE PRECISION XK0DEC
10  COMMON / jaki / jak1,jak2,jakp,jakm,ktom
11  COMMON /phoact/ ifphot
12  SAVE
13 C KTO=1 will denote tau+, thus :: IDFF=-15
14  idff=-15
15 C XK0 for tau decays.
16  xk0dec=0.01
17 C radiative correction switch in tau --> e (mu) decays !
18  itdkrc=itd
19 C switches of tau+ tau- decay modes !!
20  jak1=jakk1
21  jak2=jakk2
22 C photos activation switch
23  ifphot=ifpho
24  end
25 
26  SUBROUTINE tralo4(KTOS,PHOI,PHOF,AM)
27 !! Corrected 11.10.96 (ZW) tralor for KORALW.
28 !! better treatment is to cascade from tau rest-frame through W
29 !! restframe down to LAB.
30  COMMON / momdec / q1,q2,p1,p2,p3,p4
31  COMMON /tralid/ idtra
32  double precision Q1(4),Q2(4),P1(4),P2(4),P3(4),P4(4)
33  double precision PIN(4),POUT(4),PBST(4),PBS1(4),QQ(4),PI
34  double precision THET,PHI
35  real*4 phoi(4),phof(4)
36  SAVE
37  DATA pi /3.141592653589793238462643d0/
38  am=sqrt(abs
39  $ (phoi(4)**2-phoi(3)**2-phoi(2)**2-phoi(1)**2))
40  idtra=ktos
41  DO k=1,4
42  pin(k)=phoi(k)
43  phof(k)=phoi(k)
44  ENDDO
45 ! write(*,*) idtra
46  IF (idtra.EQ.1) THEN
47  DO k=1,4
48  pbst(k)=p1(k)
49  qq(k)=q1(k)
50  ENDDO
51  ELSEIF(idtra.EQ.2) THEN
52  DO k=1,4
53  pbst(k)=p2(k)
54  qq(k)=q1(k)
55  ENDDO
56  ELSEIF(idtra.EQ.3) THEN
57  DO k=1,4
58  pbst(k)=p3(k)
59  qq(k)=q2(k)
60  ENDDO
61  ELSE
62  DO k=1,4
63  pbst(k)=p4(k)
64  qq(k)=q2(k)
65  ENDDO
66  ENDIF
67 C for tau- spin-axis is antiparallel to 4-momentum.
68  IF(ktos.EQ.1) CALL rotod2(pi,pin,pin)
69 
70  CALL bostdq(1,qq,pbst,pbst)
71  pbs1(4)=pbst(4)
72  pbs1(3)=sqrt(pbst(3)**2+pbst(2)**2+pbst(1)**2)
73  pbs1(2)=0d0
74  pbs1(1)=0d0
75  CALL bostdq(-1,pbs1,pin,pout)
76  thet=acos(pbst(3)/sqrt(pbst(3)**2+pbst(2)**2+pbst(1)**2))
77  phi=0d0
78  phi=acos(pbst(1)/sqrt(pbst(2)**2+pbst(1)**2))
79  IF(pbst(2).LT.0d0) phi=2*pi-phi
80  CALL rotpox(thet,phi,pout)
81  CALL bostdq(-1,qq,pout,pout)
82  DO k=1,4
83  phof(k)=pout(k)
84  ENDDO
85  END
86 
87 
88  SUBROUTINE choice(MNUM,RR,ICHAN,PROB1,PROB2,PROB3,
89  $ AMRX,GAMRX,AMRA,GAMRA,AMRB,GAMRB)
90  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
91  * ,ampiz,ampi,amro,gamro,ama1,gama1
92  * ,amk,amkz,amkst,gamkst
93 C
94  real*4 amtau,amnuta,amel,amnue,ammu,amnumu
95  * ,ampiz,ampi,amro,gamro,ama1,gama1
96  * ,amk,amkz,amkst,gamkst
97 C
98  amrop=1.1
99  gamrop=0.36
100  amom=.782
101  gamom=0.0084
102 C XXXXA CORRESPOND TO S2 CHANNEL !
103  IF(mnum.EQ.0) THEN
104  prob1=0.5
105  prob2=0.5
106  amrx =ama1
107  gamrx=gama1
108  amra =amro
109  gamra=gamro
110  amrb =amro
111  gamrb=gamro
112  ELSEIF(mnum.EQ.1) THEN
113  prob1=0.5
114  prob2=0.5
115  amrx =1.57
116  gamrx=0.9
117  amrb =amkst
118  gamrb=gamkst
119  amra =amro
120  gamra=gamro
121  ELSEIF(mnum.EQ.2) THEN
122  prob1=0.5
123  prob2=0.5
124  amrx =1.57
125  gamrx=0.9
126  amrb =amkst
127  gamrb=gamkst
128  amra =amro
129  gamra=gamro
130  ELSEIF(mnum.EQ.3) THEN
131  prob1=0.5
132  prob2=0.5
133  amrx =1.27
134  gamrx=0.3
135  amra =amkst
136  gamra=gamkst
137  amrb =amkst
138  gamrb=gamkst
139  ELSEIF(mnum.EQ.4) THEN
140  prob1=0.5
141  prob2=0.5
142  amrx =1.27
143  gamrx=0.3
144  amra =amkst
145  gamra=gamkst
146  amrb =amkst
147  gamrb=gamkst
148  ELSEIF(mnum.EQ.5) THEN
149  prob1=0.5
150  prob2=0.5
151  amrx =1.27
152  gamrx=0.3
153  amra =amkst
154  gamra=gamkst
155  amrb =amro
156  gamrb=gamro
157  ELSEIF(mnum.EQ.6) THEN
158  prob1=0.4
159  prob2=0.4
160  amrx =1.27
161  gamrx=0.3
162  amra =amro
163  gamra=gamro
164  amrb =amkst
165  gamrb=gamkst
166  ELSEIF(mnum.EQ.7) THEN
167  prob1=0.0
168  prob2=1.0
169  amrx =1.27
170  gamrx=0.9
171  amra =amro
172  gamra=gamro
173  amrb =amro
174  gamrb=gamro
175  ELSEIF(mnum.EQ.8) THEN
176  prob1=0.0
177  prob2=1.0
178  amrx =amrop
179  gamrx=gamrop
180  amrb =amom
181  gamrb=gamom
182  amra =amro
183  gamra=gamro
184  ELSEIF(mnum.EQ.101) THEN
185  prob1=.35
186  prob2=.35
187  amrx =1.2
188  gamrx=.46
189  amrb =amom
190  gamrb=gamom
191  amra =amom
192  gamra=gamom
193  ELSEIF(mnum.EQ.102) THEN
194  prob1=0.0
195  prob2=0.0
196  amrx =1.4
197  gamrx=.6
198  amrb =amom
199  gamrb=gamom
200  amra =amom
201  gamra=gamom
202  ELSE
203  prob1=0.0
204  prob2=0.0
205  amrx =ama1
206  gamrx=gama1
207  amra =amro
208  gamra=gamro
209  amrb =amro
210  gamrb=gamro
211  ENDIF
212 C
213  IF (rr.LE.prob1) THEN
214  ichan=1
215  ELSEIF(rr.LE.(prob1+prob2)) THEN
216  ichan=2
217  ax =amra
218  gx =gamra
219  amra =amrb
220  gamra=gamrb
221  amrb =ax
222  gamrb=gx
223  px =prob1
224  prob1=prob2
225  prob2=px
226  ELSE
227  ichan=3
228  ENDIF
229 C
230  prob3=1.0-prob1-prob2
231  END
232 
233  SUBROUTINE initdk
234 C ----------------------------------------------------------------------
235 C INITIALISATION OF TAU DECAY PARAMETERS and routines
236 C
237 C called by : KORALZ
238 C ----------------------------------------------------------------------
239  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
240  real*4 gfermi,gv,ga,ccabib,scabib,gamel
241  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
242  * ,ampiz,ampi,amro,gamro,ama1,gama1
243  * ,amk,amkz,amkst,gamkst
244 C
245  real*4 amtau,amnuta,amel,amnue,ammu,amnumu
246  * ,ampiz,ampi,amro,gamro,ama1,gama1
247  * ,amk,amkz,amkst,gamkst
248  COMMON / taubra / gamprt(30),jlist(30),nchan
249  COMMON / taukle / bra1,brk0,brk0b,brks
250  real*4 bra1,brk0,brk0b,brks
251 #if defined (ALEPH)
252  parameter(nmode=15,nm1=0,nm2=1,nm3=8,nm4=2,nm5=1,nm6=3)
253  COMMON / taudcd /idffin(9,nmode),mulpik(nmode)
254  & ,names
255  CHARACTER NAMES(NMODE)*31
256 #else
257  parameter(nmode=15,nm1=0,nm2=1,nm3=8,nm4=2,nm5=1,nm6=3)
258  COMMON / decomp /idffin(9,nmode),mulpik(nmode)
259  & ,names
260  CHARACTER NAMES(NMODE)*31
261 #endif
262  real*4 pi,pol(4)
263 C
264 C LIST OF BRANCHING RATIOS
265 CAM normalised to e nu nutau channel
266 CAM enu munu pinu rhonu A1nu Knu K*nu pi
267 CAM DATA JLIST / 1, 2, 3, 4, 5, 6, 7,
268 #if defined (ALEPH)
269 CAM /0.1779,0.1731,0.1106,0.2530,0.1811,0.0072,0.0139
270 CAM DATA GAMPRT / 1.000,0.9732,0.6217,1.4221,1.0180,0.0405,0.0781
271 CAM DATA GAMPRT /1.000,0.9676,0.6154,1.3503,1.0225,0.0368,O.O758
272 CAM
273 C
274 C conventions of particles names
275 c
276 cam mode (JAK) 8 9
277 CAM channel pi- pi- pi0 pi+ 3pi0 pi-
278 cam particle code -1,-1, 2, 1, 0, 0, 2, 2, 2,-1, 0, 0,
279 CAM BR relative to electron .2414, .0601,
280 c
281 * 10 11
282 * 1 3pi+- 2pi0 5pi+-
283 * 1 -1,-1, 1, 2, 2, 0, -1,-1,-1, 1, 1, 0,
284 * 1 .0281, .0045,
285 
286 * 12 13
287 * 2 5pi+- pi0 3pi+- 3pi0
288 * 2 -1,-1,-1, 1, 1, 2, -1,-1, 1, 2, 2, 2,
289 * 2 .0010, .0062,
290 
291 * 14 15
292 * 3 K- pi- K+ K0 pi- KB
293 * 3 -3,-1, 3, 0, 0, 0, 4,-1,-4, 0, 0, 0,
294 * 3 .0096, .0169,
295 
296 * 16 17
297 * 4 K- pi0 K0 2pi0 K-
298 * 4 -3, 2, 4, 0, 0, 0, 2, 2,-3, 0, 0, 0,
299 * 4 .0056, .0045,
300 
301 * 18 19
302 * 5 K- pi- pi+ pi- KB pi0
303 * 5 -3,-1, 1, 0, 0, 0, -1,-4, 2, 0, 0, 0,
304 * 5 .0219, .0180,
305 
306 * 20 21
307 * 6 eta pi- pi0 pi- pi0 gamma
308 * 6 9,-1, 2, 0, 0, 0, -1, 2, 8, 0, 0, 0,
309 * 6 .0096, .0088,
310 
311 * 22 /
312 * 7 K- K0 /
313 * 7 -3, 4 /
314 * 7 .0146 /
315 #else
316 *AM DATA GAMPRT /1.000,0.9730,0.6054,1.2432,0.8432,0.0432,O.O811,0.616
317 *AM
318 *AM multipion decays
319 *
320 * conventions of particles names
321 * K-,P-,K+, K0,P-,KB, K-,P0,K0
322 * 3, 1,-3 , 4, 1,-4 , 3, 2, 4 ,
323 * P0,P0,K-, K-,P-,P+, P-,KB,P0
324 * 2, 2, 3 , 3, 1,-1 , 1,-4, 2 ,
325 * ET,P-,P0 P-,P0,GM
326 * 9, 1, 2 , 1, 2, 8
327 *
328 #endif
329 C
330  dimension nopik(6,nmode),npik(nmode)
331 CAM outgoing multiplicity and flavors of multi-pion /multi-K modes
332  DATA npik / 4, 4,
333  1 5, 5,
334  2 6, 6,
335  3 3, 3,
336  4 3, 3,
337  5 3, 3,
338  6 3, 3,
339  7 2 /
340 #if defined (ALEPH)
341  DATA nopik / -1,-1, 2, 1, 0, 0, 2, 2, 2,-1, 0, 0,
342  1 -1,-1, 1, 2, 2, 0, -1,-1,-1, 1, 1, 0,
343  2 -1,-1,-1, 1, 1, 2, -1,-1, 1, 2, 2, 2,
344  3 -3,-1, 3, 0, 0, 0, 4,-1,-4, 0, 0, 0,
345  4 -3, 2, 4, 0, 0, 0, 2, 2,-3, 0, 0, 0,
346  5 -3,-1, 1, 0, 0, 0, -1,-4, 2, 0, 0, 0,
347  6 9,-1, 2, 0, 0, 0, -1, 2, 8, 0, 0, 0,
348 #else
349  DATA nopik / -1,-1, 1, 2, 0, 0, 2, 2, 2,-1, 0, 0,
350  1 -1,-1, 1, 2, 2, 0, -1,-1,-1, 1, 1, 0,
351  2 -1,-1,-1, 1, 1, 2, -1,-1, 1, 2, 2, 2,
352  3 -3,-1, 3, 0, 0, 0, -4,-1, 4, 0, 0, 0,
353  4 -3, 2,-4, 0, 0, 0, 2, 2,-3, 0, 0, 0,
354  5 -3,-1, 1, 0, 0, 0, -1, 4, 2, 0, 0, 0,
355  6 9,-1, 2, 0, 0, 0, -1, 2, 8, 0, 0, 0,
356 #endif
357 #if defined (CLEO)
358 C AJWMOD fix sign bug, 2/22/99
359  7 -3,-4, 0, 0, 0, 0 /
360 #else
361  7 -3, 4, 0, 0, 0, 0 /
362 #endif
363 C LIST OF BRANCHING RATIOS
364  nchan = nmode + 7
365  DO 1 i = 1,30
366  IF (i.LE.nchan) THEN
367  jlist(i) = i
368  IF(i.EQ. 1) gamprt(i) = 1.0000
369  IF(i.EQ. 2) gamprt(i) = 1.0000
370  IF(i.EQ. 3) gamprt(i) = 1.0000
371  IF(i.EQ. 4) gamprt(i) = 1.0000
372  IF(i.EQ. 5) gamprt(i) = 1.0000
373  IF(i.EQ. 6) gamprt(i) = 1.0000
374  IF(i.EQ. 7) gamprt(i) = 1.0000
375  IF(i.EQ. 8) gamprt(i) = 1.0000
376  IF(i.EQ. 9) gamprt(i) = 1.0000
377  IF(i.EQ.10) gamprt(i) = 1.0000
378  IF(i.EQ.11) gamprt(i) = 1.0000
379  IF(i.EQ.12) gamprt(i) = 1.0000
380  IF(i.EQ.13) gamprt(i) = 1.0000
381  IF(i.EQ.14) gamprt(i) = 1.0000
382  IF(i.EQ.15) gamprt(i) = 1.0000
383  IF(i.EQ.16) gamprt(i) = 1.0000
384  IF(i.EQ.17) gamprt(i) = 1.0000
385  IF(i.EQ.18) gamprt(i) = 1.0000
386  IF(i.EQ.19) gamprt(i) = 1.0000
387  IF(i.EQ.20) gamprt(i) = 1.0000
388  IF(i.EQ.21) gamprt(i) = 1.0000
389  IF(i.EQ.22) gamprt(i) = 1.0000
390 #if defined (CePeCe)
391  IF(i.EQ. 1) gamprt(i) = 1.0000
392  IF(i.EQ. 2) gamprt(i) = 1.0000
393  IF(i.EQ. 3) gamprt(i) = 1.0000
394  IF(i.EQ. 4) gamprt(i) = 1.0000
395  IF(i.EQ. 5) gamprt(i) = 1.0000
396  IF(i.EQ. 6) gamprt(i) = 1.0000
397  IF(i.EQ. 7) gamprt(i) = 1.0000
398  IF(i.EQ. 8) gamprt(i) = 1.0000
399  IF(i.EQ. 9) gamprt(i) = 1.0000
400  IF(i.EQ.10) gamprt(i) = 1.0000
401  IF(i.EQ.11) gamprt(i) = 1.0000
402  IF(i.EQ.12) gamprt(i) = 1.0000
403  IF(i.EQ.13) gamprt(i) = 1.0000
404  IF(i.EQ.14) gamprt(i) = 1.0000
405  IF(i.EQ.15) gamprt(i) = 1.0000
406  IF(i.EQ.16) gamprt(i) = 1.0000
407  IF(i.EQ.17) gamprt(i) = 1.0000
408  IF(i.EQ.18) gamprt(i) = 1.0000
409  IF(i.EQ.19) gamprt(i) = 1.0000
410  IF(i.EQ.20) gamprt(i) = 1.0000
411  IF(i.EQ.21) gamprt(i) = 1.0000
412  IF(i.EQ.22) gamprt(i) = 1.0000
413 #elif defined (CLEO)
414  IF(i.EQ. 1) gamprt(i) =0.1800
415  IF(i.EQ. 2) gamprt(i) =0.1751
416  IF(i.EQ. 3) gamprt(i) =0.1110
417  IF(i.EQ. 4) gamprt(i) =0.2515
418  IF(i.EQ. 5) gamprt(i) =0.1790
419  IF(i.EQ. 6) gamprt(i) =0.0071
420  IF(i.EQ. 7) gamprt(i) =0.0134
421  IF(i.EQ. 8) gamprt(i) =0.0450
422  IF(i.EQ. 9) gamprt(i) =0.0100
423  IF(i.EQ.10) gamprt(i) =0.0009
424  IF(i.EQ.11) gamprt(i) =0.0004
425  IF(i.EQ.12) gamprt(i) =0.0003
426  IF(i.EQ.13) gamprt(i) =0.0005
427  IF(i.EQ.14) gamprt(i) =0.0015
428  IF(i.EQ.15) gamprt(i) =0.0015
429  IF(i.EQ.16) gamprt(i) =0.0015
430  IF(i.EQ.17) gamprt(i) =0.0005
431  IF(i.EQ.18) gamprt(i) =0.0050
432  IF(i.EQ.19) gamprt(i) =0.0055
433  IF(i.EQ.20) gamprt(i) =0.0017
434  IF(i.EQ.21) gamprt(i) =0.0013
435  IF(i.EQ.22) gamprt(i) =0.0010
436 #elif defined (ALEPH)
437  IF(i.EQ. 1) gamprt(i) = 1.0000
438  IF(i.EQ. 2) gamprt(i) = .9732
439  IF(i.EQ. 3) gamprt(i) = .6217
440  IF(i.EQ. 4) gamprt(i) = 1.4221
441  IF(i.EQ. 5) gamprt(i) = 1.0180
442  IF(i.EQ. 6) gamprt(i) = .0405
443  IF(i.EQ. 7) gamprt(i) = .0781
444  IF(i.EQ. 8) gamprt(i) = .2414
445  IF(i.EQ. 9) gamprt(i) = .0601
446  IF(i.EQ.10) gamprt(i) = .0281
447  IF(i.EQ.11) gamprt(i) = .0045
448  IF(i.EQ.12) gamprt(i) = .0010
449  IF(i.EQ.13) gamprt(i) = .0062
450  IF(i.EQ.14) gamprt(i) = .0096
451  IF(i.EQ.15) gamprt(i) = .0169
452  IF(i.EQ.16) gamprt(i) = .0056
453  IF(i.EQ.17) gamprt(i) = .0045
454  IF(i.EQ.18) gamprt(i) = .0219
455  IF(i.EQ.19) gamprt(i) = .0180
456  IF(i.EQ.20) gamprt(i) = .0096
457  IF(i.EQ.21) gamprt(i) = .0088
458  IF(i.EQ.22) gamprt(i) = .0146
459 #else
460 #endif
461  IF(i.EQ. 8) names(i-7)=' TAU- --> 2PI-, PI0, PI+ '
462  IF(i.EQ. 9) names(i-7)=' TAU- --> 3PI0, PI- '
463  IF(i.EQ.10) names(i-7)=' TAU- --> 2PI-, PI+, 2PI0 '
464  IF(i.EQ.11) names(i-7)=' TAU- --> 3PI-, 2PI+, '
465  IF(i.EQ.12) names(i-7)=' TAU- --> 3PI-, 2PI+, PI0 '
466  IF(i.EQ.13) names(i-7)=' TAU- --> 2PI-, PI+, 3PI0 '
467  IF(i.EQ.14) names(i-7)=' TAU- --> K-, PI-, K+ '
468  IF(i.EQ.15) names(i-7)=' TAU- --> K0, PI-, K0B '
469 #if defined (ALEPH)
470  IF(i.EQ.16) names(i-7)=' TAU- --> K- PI0 K0 '
471 #else
472  IF(i.EQ.16) names(i-7)=' TAU- --> K-, K0, PI0 '
473 #endif
474  IF(i.EQ.17) names(i-7)=' TAU- --> PI0, PI0, K- '
475  IF(i.EQ.18) names(i-7)=' TAU- --> K-, PI-, PI+ '
476  IF(i.EQ.19) names(i-7)=' TAU- --> PI-, K0B, PI0 '
477  IF(i.EQ.20) names(i-7)=' TAU- --> ETA, PI-, PI0 '
478  IF(i.EQ.21) names(i-7)=' TAU- --> PI-, PI0, GAM '
479  IF(i.EQ.22) names(i-7)=' TAU- --> K-, K0 '
480  ELSE
481  jlist(i) = 0
482  gamprt(i) = 0.
483  ENDIF
484  1 CONTINUE
485  DO i=1,nmode
486  mulpik(i)=npik(i)
487  DO j=1,mulpik(i)
488  idffin(j,i)=nopik(j,i)
489  ENDDO
490  ENDDO
491 C
492 C
493 C --- COEFFICIENTS TO FIX RATIO OF:
494 C --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
495 C --- PROBABILITY OF K0 TO BE KS
496 C --- PROBABILITY OF K0B TO BE KS
497 C --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
498 C --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
499 C --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
500 C --- NEGLECTS MASS-PHASE SPACE EFFECTS
501  bra1=0.5
502  brk0=0.5
503  brk0b=0.5
504  brks=0.6667
505 C
506 C --- remaining constants
507  pi =4.*atan(1.)
508  gfermi = 1.16637e-5
509  ccabib = 0.975
510  gv = 1.0
511  ga =-1.0
512 C ZW 13.04.89 HERE WAS AN ERROR
513  scabib = sqrt(1.-ccabib**2)
514  gamel = gfermi**2*amtau**5/(192*pi**3)
515 C
516  CALL dexay(-1,pol)
517 C
518  RETURN
519  END
520  FUNCTION dcdmas(IDENT)
521  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
522  * ,ampiz,ampi,amro,gamro,ama1,gama1
523  * ,amk,amkz,amkst,gamkst
524 C
525  real*4 amtau,amnuta,amel,amnue,ammu,amnumu
526  * ,ampiz,ampi,amro,gamro,ama1,gama1
527  * ,amk,amkz,amkst,gamkst
528  IF (ident.EQ. 1) THEN
529  apkmas=ampi
530  ELSEIF (ident.EQ.-1) THEN
531  apkmas=ampi
532  ELSEIF (ident.EQ. 2) THEN
533  apkmas=ampiz
534  ELSEIF (ident.EQ.-2) THEN
535  apkmas=ampiz
536  ELSEIF (ident.EQ. 3) THEN
537  apkmas=amk
538  ELSEIF (ident.EQ.-3) THEN
539  apkmas=amk
540  ELSEIF (ident.EQ. 4) THEN
541  apkmas=amkz
542  ELSEIF (ident.EQ.-4) THEN
543  apkmas=amkz
544  ELSEIF (ident.EQ. 8) THEN
545  apkmas=0.0001
546  ELSEIF (ident.EQ.-8) THEN
547  apkmas=0.0001
548  ELSEIF (ident.EQ. 9) THEN
549  apkmas=0.5488
550  ELSEIF (ident.EQ.-9) THEN
551  apkmas=0.5488
552  ELSE
553  print *, 'STOP IN APKMAS, WRONG IDENT=',ident
554  stop
555  ENDIF
556  dcdmas=apkmas
557  END
558 
559  FUNCTION lunpik(ID,ISGN)
560  COMMON / taukle / bra1,brk0,brk0b,brks
561  real*4 bra1,brk0,brk0b,brks
562  real*4 xio
563  dimension xio(1)
564  ident=id*isgn
565 #if defined (ALEPH)
566  IF (ident.EQ. 1) THEN
567  ipkdef= 211
568  ELSEIF (ident.EQ.-1) THEN
569  ipkdef=-211
570  ELSEIF (ident.EQ. 2) THEN
571  ipkdef= 111
572  ELSEIF (ident.EQ.-2) THEN
573  ipkdef= 111
574  ELSEIF (ident.EQ. 3) THEN
575  ipkdef= 321
576  ELSEIF (ident.EQ.-3) THEN
577  ipkdef=-321
578 #else
579  IF (ident.EQ. 1) THEN
580  ipkdef=-211
581  ELSEIF (ident.EQ.-1) THEN
582  ipkdef= 211
583  ELSEIF (ident.EQ. 2) THEN
584  ipkdef=111
585  ELSEIF (ident.EQ.-2) THEN
586  ipkdef=111
587  ELSEIF (ident.EQ. 3) THEN
588  ipkdef=-321
589  ELSEIF (ident.EQ.-3) THEN
590  ipkdef= 321
591 #endif
592  ELSEIF (ident.EQ. 4) THEN
593 C
594 C K0 --> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
595  CALL ranmar(xio,1)
596  IF (xio(1).GT.brk0) THEN
597  ipkdef= 130
598  ELSE
599  ipkdef= 310
600  ENDIF
601  ELSEIF (ident.EQ.-4) THEN
602 C
603 C K0B--> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
604  CALL ranmar(xio,1)
605  IF (xio(1).GT.brk0b) THEN
606  ipkdef= 130
607  ELSE
608  ipkdef= 310
609  ENDIF
610  ELSEIF (ident.EQ. 8) THEN
611  ipkdef= 22
612  ELSEIF (ident.EQ.-8) THEN
613  ipkdef= 22
614  ELSEIF (ident.EQ. 9) THEN
615  ipkdef= 221
616  ELSEIF (ident.EQ.-9) THEN
617  ipkdef= 221
618  ELSE
619  print *, 'STOP IN IPKDEF, WRONG IDENT=',ident
620  stop
621  ENDIF
622  lunpik=ipkdef
623  END
624 #if defined (CLEO)
625 
626  SUBROUTINE taurdf(KTO)
627 C THIS ROUTINE CAN BE CALLED BEFORE ANY TAU+ OR TAU- EVENT IS GENERATED
628 C IT CAN BE USED TO GENERATE TAU+ AND TAU- SAMPLES OF DIFFERENT
629 C CONTENTS
630  COMMON / taukle / bra1,brk0,brk0b,brks
631  real*4 bra1,brk0,brk0b,brks
632  COMMON / taubra / gamprt(30),jlist(30),nchan
633  IF (kto.EQ.1) THEN
634 C ==================
635 C AJWMOD: Set the BRs for (A1+ -> rho+ pi0) and (K*+ -> K0 pi+)
636  bra1 = pkorb(4,1)
637  brks = pkorb(4,3)
638  brk0 = pkorb(4,5)
639  brk0b = pkorb(4,6)
640  ELSE
641 C ====
642 C AJWMOD: Set the BRs for (A1+ -> rho+ pi0) and (K*+ -> K0 pi+)
643  bra1 = pkorb(4,2)
644  brks = pkorb(4,4)
645  brk0 = pkorb(4,5)
646  brk0b = pkorb(4,6)
647  ENDIF
648 C =====
649  END
650 #else
651 
652  SUBROUTINE taurdf(KTO)
653 * THIS ROUTINE CAN BE CALLED BEFORE ANY TAU+ OR TAU- EVENT IS GENERATED
654 * IT CAN BE USED TO GENERATE TAU+ AND TAU- SAMPLES OF DIFFERENT
655 * CONTENTS
656  COMMON / taukle / bra1,brk0,brk0b,brks
657  real*4 bra1,brk0,brk0b,brks
658  COMMON / taubra / gamprt(30),jlist(30),nchan
659  IF (kto.EQ.1) THEN
660 * ==================
661 * LIST OF BRANCHING RATIOS
662  nchan = 19
663  DO 1 i = 1,30
664  IF (i.LE.nchan) THEN
665  jlist(i) = i
666  IF(i.EQ. 1) gamprt(i) = .0000
667  IF(i.EQ. 2) gamprt(i) = .0000
668  IF(i.EQ. 3) gamprt(i) = .0000
669  IF(i.EQ. 4) gamprt(i) = .0000
670  IF(i.EQ. 5) gamprt(i) = .0000
671  IF(i.EQ. 6) gamprt(i) = .0000
672  IF(i.EQ. 7) gamprt(i) = .0000
673  IF(i.EQ. 8) gamprt(i) = 1.0000
674  IF(i.EQ. 9) gamprt(i) = 1.0000
675  IF(i.EQ.10) gamprt(i) = 1.0000
676  IF(i.EQ.11) gamprt(i) = 1.0000
677  IF(i.EQ.12) gamprt(i) = 1.0000
678  IF(i.EQ.13) gamprt(i) = 1.0000
679  IF(i.EQ.14) gamprt(i) = 1.0000
680  IF(i.EQ.15) gamprt(i) = 1.0000
681  IF(i.EQ.16) gamprt(i) = 1.0000
682  IF(i.EQ.17) gamprt(i) = 1.0000
683  IF(i.EQ.18) gamprt(i) = 1.0000
684  IF(i.EQ.19) gamprt(i) = 1.0000
685  ELSE
686  jlist(i) = 0
687  gamprt(i) = 0.
688  ENDIF
689  1 CONTINUE
690 * --- COEFFICIENTS TO FIX RATIO OF:
691 * --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
692 * --- PROBABILITY OF K0 TO BE KS
693 * --- PROBABILITY OF K0B TO BE KS
694 * --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
695 * --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
696 * --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
697 * --- NEGLECTS MASS-PHASE SPACE EFFECTS
698  bra1=0.5
699  brk0=0.5
700  brk0b=0.5
701  brks=0.6667
702  ELSE
703 * ====
704 * LIST OF BRANCHING RATIOS
705  nchan = 19
706  DO 2 i = 1,30
707  IF (i.LE.nchan) THEN
708  jlist(i) = i
709  IF(i.EQ. 1) gamprt(i) = .0000
710  IF(i.EQ. 2) gamprt(i) = .0000
711  IF(i.EQ. 3) gamprt(i) = .0000
712  IF(i.EQ. 4) gamprt(i) = .0000
713  IF(i.EQ. 5) gamprt(i) = .0000
714  IF(i.EQ. 6) gamprt(i) = .0000
715  IF(i.EQ. 7) gamprt(i) = .0000
716  IF(i.EQ. 8) gamprt(i) = 1.0000
717  IF(i.EQ. 9) gamprt(i) = 1.0000
718  IF(i.EQ.10) gamprt(i) = 1.0000
719  IF(i.EQ.11) gamprt(i) = 1.0000
720  IF(i.EQ.12) gamprt(i) = 1.0000
721  IF(i.EQ.13) gamprt(i) = 1.0000
722  IF(i.EQ.14) gamprt(i) = 1.0000
723  IF(i.EQ.15) gamprt(i) = 1.0000
724  IF(i.EQ.16) gamprt(i) = 1.0000
725  IF(i.EQ.17) gamprt(i) = 1.0000
726  IF(i.EQ.18) gamprt(i) = 1.0000
727  IF(i.EQ.19) gamprt(i) = 1.0000
728  ELSE
729  jlist(i) = 0
730  gamprt(i) = 0.
731  ENDIF
732  2 CONTINUE
733 * --- COEFFICIENTS TO FIX RATIO OF:
734 * --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
735 * --- PROBABILITY OF K0 TO BE KS
736 * --- PROBABILITY OF K0B TO BE KS
737 * --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
738 * --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
739 * --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
740 * --- NEGLECTS MASS-PHASE SPACE EFFECTS
741  bra1=0.5
742  brk0=0.5
743  brk0b=0.5
744  brks=0.6667
745  ENDIF
746 * =====
747  END
748 #endif
749  SUBROUTINE iniphx(XK00)
750 C ----------------------------------------------------------------------
751 C INITIALISATION OF PARAMETERS
752 C USED IN QED and/or GSW ROUTINES
753 C ----------------------------------------------------------------------
754  COMMON / qedprm /alfinv,alfpi,xk0
755  real*8 alfinv,alfpi,xk0
756  real*8 pi8,xk00
757 C
758  pi8 = 4.d0*datan(1.d0)
759  alfinv = 137.03604d0
760  alfpi = 1d0/(alfinv*pi8)
761  xk0=xk00
762  END
763  SUBROUTINE inimas
764 C ----------------------------------------------------------------------
765 C INITIALISATION OF MASSES
766 C
767 C called by : KORALZ
768 C ----------------------------------------------------------------------
769  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
770  * ,ampiz,ampi,amro,gamro,ama1,gama1
771  * ,amk,amkz,amkst,gamkst
772 C
773  real*4 amtau,amnuta,amel,amnue,ammu,amnumu
774  * ,ampiz,ampi,amro,gamro,ama1,gama1
775  * ,amk,amkz,amkst,gamkst
776 C
777 C IN-COMING / OUT-GOING FERMION MASSES
778  amtau = 1.7842
779  amtau = 1.777
780  amnuta = 0.010
781  amel = 0.0005111
782  amnue = 0.0
783  ammu = 0.105659
784  amnumu = 0.0
785 C
786 C MASSES USED IN TAU DECAYS
787  ampiz = 0.134964
788  ampi = 0.139568
789  amro = 0.773
790  gamro = 0.145
791 CC GAMRO = 0.666
792  ama1 = 1.251
793  gama1 = 0.599
794  amk = 0.493667
795  amkz = 0.49772
796  amkst = 0.8921
797  gamkst = 0.0513
798 C
799 #if defined (CePeCe)
800  ampiz = 0.134964
801  ampi = 0.139568
802  amro = 0.773
803  gamro = 0.145
804 *C GAMRO = 0.666
805  ama1 = 1.251
806  gama1 = 0.599
807  amk = 0.493667
808  amkz = 0.49772
809  amkst = 0.8921
810  gamkst = 0.0513
811 #elif defined (CLEO)
812  ampiz = 0.134964
813  ampi = 0.139568
814  amro = 0.773
815  gamro = 0.145
816 *C GAMRO = 0.666
817  ama1 = 1.251
818  gama1 = 0.599
819  amk = 0.493667
820  amkz = 0.49772
821  amkst = 0.8921
822  gamkst = 0.0513
823 C
824 C
825 C IN-COMING / OUT-GOING FERMION MASSES
826 !! AMNUTA = PKORB(1,2)
827 !! AMNUE = PKORB(1,4)
828 !! AMNUMU = PKORB(1,6)
829 C
830 C MASSES USED IN TAU DECAYS Cleo settings
831 !! AMPIZ = PKORB(1,7)
832 !! AMPI = PKORB(1,8)
833 !! AMRO = PKORB(1,9)
834 !! GAMRO = PKORB(2,9)
835  ama1 = 1.275 !! PKORB(1,10)
836  gama1 = 0.615 !! PKORB(2,10)
837 !! AMK = PKORB(1,11)
838 !! AMKZ = PKORB(1,12)
839 !! AMKST = PKORB(1,13)
840 !! GAMKST = PKORB(2,13)
841 C
842 #elif defined (ALEPH)
843  ampiz = 0.134964
844  ampi = 0.139568
845  amro = 0.7714
846  gamro = 0.153
847 cam AMRO = 0.773
848 cam GAMRO = 0.145
849  ama1 = 1.251! PMAS(LUCOMP(ia1),1) ! AMA1 = 1.251
850  gama1 = 0.599! PMAS(LUCOMP(ia1),2) ! GAMA1 = 0.599
851  print *,'INIMAS a1 mass= ',ama1,gama1
852  amk = 0.493667
853  amkz = 0.49772
854  amkst = 0.8921
855  gamkst = 0.0513
856 #else
857 #endif
858 
859  RETURN
860  END
861  subroutine bostdq(idir,vv,pp,q)
862 * *******************************
863 c Boost along arbitrary vector v (see eg. J.D. Jacson, Classical
864 c Electrodynamics).
865 c Four-vector pp is boosted from an actual frame to the rest frame
866 c of the four-vector v (for idir=1) or back (for idir=-1).
867 c q is a resulting four-vector.
868 c Note: v must be time-like, pp may be arbitrary.
869 c
870 c Written by: Wieslaw Placzek date: 22.07.1994
871 c Last update: 3/29/95 by: M.S.
872 c
873  implicit DOUBLE PRECISION (a-h,o-z)
874  parameter(nout=6)
875  DOUBLE PRECISION v(4),p(4),q(4),pp(4),vv(4)
876  save
877 !
878  do 1 i=1,4
879  v(i)=vv(i)
880  1 p(i)=pp(i)
881  amv=(v(4)**2-v(1)**2-v(2)**2-v(3)**2)
882  if (amv.le.0d0) then
883  write(6,*) 'bosstv: warning amv**2=',amv
884  endif
885  amv=sqrt(abs(amv))
886  if (idir.eq.-1) then
887  q(4)=( p(1)*v(1)+p(2)*v(2)+p(3)*v(3)+p(4)*v(4))/amv
888  wsp =(q(4)+p(4))/(v(4)+amv)
889  elseif (idir.eq.1) then
890  q(4)=(-p(1)*v(1)-p(2)*v(2)-p(3)*v(3)+p(4)*v(4))/amv
891  wsp =-(q(4)+p(4))/(v(4)+amv)
892  else
893  write(nout,*)' >>> boostv: wrong value of idir = ',idir
894  endif
895  q(1)=p(1)+wsp*v(1)
896  q(2)=p(2)+wsp*v(2)
897  q(3)=p(3)+wsp*v(3)
898  end
899 
900 
901 #if defined (ALEPH)
902  FUNCTION dilogy(X)
903 C *****************
904  IMPLICIT REAL*8(a-h,o-z)
905 CERN C304 VERSION 29/07/71 DILOG 59 C
906  z=-1.64493406684822
907  IF(x .LT.-1.0) GO TO 1
908  IF(x .LE. 0.5) GO TO 2
909  IF(x .EQ. 1.0) GO TO 3
910  IF(x .LE. 2.0) GO TO 4
911  z=3.2898681336964
912  1 t=1.0/x
913  s=-0.5
914  z=z-0.5* log(abs(x))**2
915  GO TO 5
916  2 t=x
917  s=0.5
918  z=0.
919  GO TO 5
920  3 dilogy=1.64493406684822
921  RETURN
922  4 t=1.0-x
923  s=-0.5
924  z=1.64493406684822 - log(x)* log(abs(t))
925  5 y=2.66666666666666 *t+0.66666666666666
926  b= 0.00000 00000 00001
927  a=y*b +0.00000 00000 00004
928  b=y*a-b+0.00000 00000 00011
929  a=y*b-a+0.00000 00000 00037
930  b=y*a-b+0.00000 00000 00121
931  a=y*b-a+0.00000 00000 00398
932  b=y*a-b+0.00000 00000 01312
933  a=y*b-a+0.00000 00000 04342
934  b=y*a-b+0.00000 00000 14437
935  a=y*b-a+0.00000 00000 48274
936  b=y*a-b+0.00000 00001 62421
937  a=y*b-a+0.00000 00005 50291
938  b=y*a-b+0.00000 00018 79117
939  a=y*b-a+0.00000 00064 74338
940  b=y*a-b+0.00000 00225 36705
941  a=y*b-a+0.00000 00793 87055
942  b=y*a-b+0.00000 02835 75385
943  a=y*b-a+0.00000 10299 04264
944  b=y*a-b+0.00000 38163 29463
945  a=y*b-a+0.00001 44963 00557
946  b=y*a-b+0.00005 68178 22718
947  a=y*b-a+0.00023 20021 96094
948  b=y*a-b+0.00100 16274 96164
949  a=y*b-a+0.00468 63619 59447
950  b=y*a-b+0.02487 93229 24228
951  a=y*b-a+0.16607 30329 27855
952  a=y*a-b+1.93506 43008 6996
953  dilogy=s*t*(a-b)+z
954  RETURN
955 C=======================================================================
956 C===================END OF CPC PART ====================================
957 C=======================================================================
958  END
959 #endif
960 
961 
962 
963 
964 
965 
966