C++InterfacetoTauola
tauola-BBB/jetset-F/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 
7  SUBROUTINE inietc(jakk1,jakk2,itd,ifpho)
8  COMMON / idfc / idff
9  COMMON / taurad / xk0dec,itdkrc
10  DOUBLE PRECISION XK0DEC
11  COMMON / jaki / jak1,jak2,jakp,jakm,ktom
12  COMMON /phoact/ ifphot
13  SAVE
14 C KTO=1 will denote tau+, thus :: IDFF=-15
15  idff=-15
16 C XK0 for tau decays.
17  xk0dec=0.01
18 C radiative correction switch in tau --> e (mu) decays !
19  itdkrc=itd
20 C switches of tau+ tau- decay modes !!
21  jak1=jakk1
22  jak2=jakk2
23 C photos activation switch
24  ifphot=ifpho
25  end
26 
27  SUBROUTINE tralo4(KTOS,PHOI,PHOF,AM)
28 !! Corrected 11.10.96 (ZW) tralor for KORALW.
29 !! better treatment is to cascade from tau rest-frame through W
30 !! restframe down to LAB.
31  COMMON / momdec / q1,q2,p1,p2,p3,p4
32  COMMON /tralid/ idtra
33  double precision Q1(4),Q2(4),P1(4),P2(4),P3(4),P4(4),P1QQ(4),P2QQ(4)
34  double precision PIN(4),POUT(4),PBST(4),PBS1(4),QQ(4),PI
35  double precision THET,PHI,EXE
36  REAL*4 PHOI(4),PHOF(4)
37  SAVE
38  DATA pi /3.141592653589793238462643d0/
39  am=sqrt(abs
40  $ (phoi(4)**2-phoi(3)**2-phoi(2)**2-phoi(1)**2))
41  idtra=ktos
42  DO k=1,4
43  pin(k)=phoi(k)
44  phof(k)=phoi(k)
45  ENDDO
46 ! write(*,*) idtra
47  IF (idtra.EQ.1) THEN
48  DO k=1,4
49  pbst(k)=p1(k)
50  qq(k)=q1(k)
51  ENDDO
52  ELSEIF(idtra.EQ.2) THEN
53  DO k=1,4
54  pbst(k)=p2(k)
55  qq(k)=q1(k)
56  ENDDO
57  ELSEIF(idtra.EQ.3) THEN
58  DO k=1,4
59  pbst(k)=p3(k)
60  qq(k)=q2(k)
61  ENDDO
62  ELSE
63  DO k=1,4
64  pbst(k)=p4(k)
65  qq(k)=q2(k)
66  ENDDO
67  ENDIF
68 
69 
70 
71  CALL bostdq(1,qq,pbst,pbst)
72  CALL bostdq(1,qq,p1,p1qq)
73  CALL bostdq(1,qq,p2,p2qq)
74  pbs1(4)=pbst(4)
75  pbs1(3)=sqrt(pbst(3)**2+pbst(2)**2+pbst(1)**2)
76  pbs1(2)=0d0
77  pbs1(1)=0d0
78  exe=(pbs1(4)+pbs1(3))/dsqrt(pbs1(4)**2-pbs1(3)**2)
79 C for KTOS=1 boost is antiparallel to 4-momentum of P2.
80 C restframes of tau+ tau- and 'first' frame of 'higgs' are all connected
81 C by boosts along z axis
82  IF(ktos.EQ.1) exe=(pbs1(4)-pbs1(3))/dsqrt(pbs1(4)**2-pbs1(3)**2)
83  CALL bostd3(exe,pin,pout)
84 
85 C once in Z/gamma/Higgs rest frame we control further kinematics by P2QQ for KTOS=1,2
86  thet=acos(p2qq(3)/sqrt(p2qq(3)**2+p2qq(2)**2+p2qq(1)**2))
87  phi=0d0
88  phi=acos(p2qq(1)/sqrt(p2qq(2)**2+p2qq(1)**2))
89  IF(p2qq(2).LT.0d0) phi=2*pi-phi
90 
91  CALL rotpox(thet,phi,pout)
92  CALL bostdq(-1,qq,pout,pout)
93  DO k=1,4
94  phof(k)=pout(k)
95  ENDDO
96  END
97  SUBROUTINE choice(MNUM,RR,ICHAN,PROB1,PROB2,PROB3,
98  $ AMRX,GAMRX,AMRA,GAMRA,AMRB,GAMRB)
99  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
100  * ,ampiz,ampi,amro,gamro,ama1,gama1
101  * ,amk,amkz,amkst,gamkst
102 C
103  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
104  * ,ampiz,ampi,amro,gamro,ama1,gama1
105  * ,amk,amkz,amkst,gamkst
106 C
107  amrop=1.1
108  gamrop=0.36
109  amom=.782
110  gamom=0.0084
111 C XXXXA CORRESPOND TO S2 CHANNEL !
112  IF(mnum.EQ.0) THEN
113  prob1=0.5
114  prob2=0.5
115  amrx =ama1
116  gamrx=gama1
117  amra =amro
118  gamra=gamro
119  amrb =amro
120  gamrb=gamro
121  ELSEIF(mnum.EQ.1) 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.2) THEN
131  prob1=0.5
132  prob2=0.5
133  amrx =1.57
134  gamrx=0.9
135  amrb =amkst
136  gamrb=gamkst
137  amra =amro
138  gamra=gamro
139  ELSEIF(mnum.EQ.3) 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.4) 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 =amkst
156  gamrb=gamkst
157  ELSEIF(mnum.EQ.5) THEN
158  prob1=0.5
159  prob2=0.5
160  amrx =1.27
161  gamrx=0.3
162  amra =amkst
163  gamra=gamkst
164  amrb =amro
165  gamrb=gamro
166  ELSEIF(mnum.EQ.6) THEN
167  prob1=0.4
168  prob2=0.4
169  amrx =1.27
170  gamrx=0.3
171  amra =amro
172  gamra=gamro
173  amrb =amkst
174  gamrb=gamkst
175  ELSEIF(mnum.EQ.7) THEN
176  prob1=0.0
177  prob2=1.0
178  amrx =1.27
179  gamrx=0.9
180  amra =amro
181  gamra=gamro
182  amrb =amro
183  gamrb=gamro
184  ELSEIF(mnum.EQ.8) THEN
185  prob1=0.0
186  prob2=1.0
187  amrx =amrop
188  gamrx=gamrop
189  amrb =amom
190  gamrb=gamom
191  amra =amro
192  gamra=gamro
193  ELSEIF(mnum.EQ.9) THEN
194  prob1=0.5
195  prob2=0.5
196  amrx =ama1
197  gamrx=gama1
198  amra =amro
199  gamra=gamro
200  amrb =amro
201  gamrb=gamro
202  ELSEIF(mnum.EQ.101) THEN
203  prob1=.35
204  prob2=.35
205  amrx =1.2
206  gamrx=.46
207  amrb =amom
208  gamrb=gamom
209  amra =amom
210  gamra=gamom
211  ELSEIF(mnum.EQ.102) THEN
212  prob1=0.0
213  prob2=0.0
214  amrx =1.4
215  gamrx=.6
216  amrb =amom
217  gamrb=gamom
218  amra =amom
219  gamra=gamom
220  ELSEIF(mnum.GE.103.AND.mnum.LE.112) THEN
221  prob1=0.0
222  prob2=0.0
223  amrx =1.4
224  gamrx=.6
225  amrb =amom
226  gamrb=gamom
227  amra =amom
228  gamra=gamom
229 
230 
231  ELSE
232  prob1=0.0
233  prob2=0.0
234  amrx =ama1
235  gamrx=gama1
236  amra =amro
237  gamra=gamro
238  amrb =amro
239  gamrb=gamro
240  ENDIF
241 C
242  IF (rr.LE.prob1) THEN
243  ichan=1
244  ELSEIF(rr.LE.(prob1+prob2)) THEN
245  ichan=2
246  ax =amra
247  gx =gamra
248  amra =amrb
249  gamra=gamrb
250  amrb =ax
251  gamrb=gx
252  px =prob1
253  prob1=prob2
254  prob2=px
255  ELSE
256  ichan=3
257  ENDIF
258 C
259  prob3=1.0-prob1-prob2
260  END
261  SUBROUTINE initdk
262 * ----------------------------------------------------------------------
263 * INITIALISATION OF TAU DECAY PARAMETERS and routines
264 *
265 * called by : KORALZ
266 * ----------------------------------------------------------------------
267 
268  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
269  REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
270  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
271  * ,ampiz,ampi,amro,gamro,ama1,gama1
272  * ,amk,amkz,amkst,gamkst
273 *
274  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
275  * ,ampiz,ampi,amro,gamro,ama1,gama1
276  * ,amk,amkz,amkst,gamkst
277  COMMON / taubra / gamprt(500),jlist(500),nchan
278  COMMON / taukle / bra1,brk0,brk0b,brks
279  REAL*4 BRA1,BRK0,BRK0B,BRKS
280 
281  parameter(nmode=86,nm1=0,nm2=11,nm3=19,nm4=22,nm5=21,nm6=13)
282  COMMON / taudcd /idffin(9,nmode),mulpik(nmode)
283  & ,names
284  CHARACTER NAMES(NMODE)*31
285 
286  CHARACTER OLDNAMES(7)*31
287  CHARACTER*80 bxINIT
288  parameter(
289  $ bxinit ='(1x,1h*,g17.8, 16x, a31,a4,a4, 1x,1h*)'
290  $ )
291  REAL*4 PI,POL1(4)
292 *
293 *
294 * LIST OF BRANCHING RATIOS
295 CAM normalised to e nu nutau channel
296 CAM enu munu pinu rhonu A1nu Knu K*nu pi
297 CAM DATA JLIST / 1, 2, 3, 4, 5, 6, 7,
298 
299 *AM DATA GAMPRT /1.000,0.9730,0.6054,1.2432,0.8432,0.0432,O.O811,0.616
300 *AM
301 *AM multipion decays
302 *
303 * conventions of particles names
304 * K-,P-,K+, K0,P-,KB, K-,P0,K0
305 * 3, 1,-3 , 4, 1,-4 , 3, 2, 4 ,
306 * P0,P0,K-, K-,P-,P+, P-,KB,P0
307 * 2, 2, 3 , 3, 1,-1 , 1,-4, 2 ,
308 * ET,P-,P0 , P-,P0,GM , P-,P0,P0
309 * 9, 1, 2 , 1, 2, 8 , 1, 2, 2
310 *
311 
312 C
313  dimension nopik(9,nmode),npik(nmode)
314 *AM outgoing multiplicity and flavors of multi-pion /multi-K modes
315  DATA npik / 4, 4, ! old 4scalar
316  a 4, 4, ! new (may 2004)
317  b 4, 4,
318  c 4, 4,
319  d 4, 4,
320  e 4, 4, ! new (may 2004)
321  e 4, 4, ! new (sep 2004)
322  e 4, 4,
323  e 4, 4,
324  e 4, 4,
325  e 4, 4, ! new (sep 2004)
326  1 5,
327  a 5, 5, ! new (may 2004)
328  b 5, 5,
329  c 5, 5,
330  d 5, 5,
331  e 5, 5, ! new (may 2004)
332  a 5, 5, ! new (sep 2004)
333  b 5, 5,
334  c 5, 5,
335  d 5, 5,
336  e 5, 5, ! new (sep 2004)
337  x 5, ! old npi starts here
338  2 6, 6,
339  a 6, 6, ! new (may 2004)
340  b 6, 6, ! new (may 2004)
341  c 6, 6, ! new (may 2004)
342  d 6, 6, ! new (may 2004)
343  e 6, 6, ! new (may 2004)
344  3 3, 3,
345  4 3, 3,
346  5 3, 3,
347  6 3, 3,
348  7 3, ! new (may 2004) and useful
349  a 3, 3, ! new (may 2004)
350  a 3, 3, ! new (may 2004)
351  a 3, 3, ! new (may 2004)
352  a 3, 3, ! new (may 2004)
353  a 3, 3, ! new (may 2004)
354  8 2,
355  9 2, 2, ! new (may 2004)
356  9 2, 2, ! new (may 2004)
357  9 2, 2, ! new (may 2004)
358  9 2, 2, ! new (may 2004)
359  9 2, 2/ ! new (may 2004)
360 
361  DATA nopik / -1,-1, 1, 2, 0, 0,3*0, 2, 2, 2,-1, 0, 0,3*0,
362  a 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (may 2004)
363  b 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (may 2004)
364  c 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (may 2004)
365  d 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (may 2004)
366  e 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (may 2004)
367  a 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (sep 2004)
368  b 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (sep 2004)
369  c 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (sep 2004)
370  d 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (sep 2004)
371  e 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (sep 2004)
372  1 -1,-1, 1, 2, 2, 0,3*0,
373  a -1,-1, 1, 2, 2, 0,3*0, 2, 2, 2, 2, 2, 0,3*0, ! new (may 2004)
374  a 1,-1,-1, 2, 2, 0,3*0, -1, 2, 2, 2, 2, 0,3*0, ! new (may 2004)
375  a -1, 1, 1,-1,-1, 0,3*0, -1,-1, 1, 2, 4, 0,3*0, ! new (may 2004)
376  a -1,-1, 1, 2, 4, 0,3*0, -1,-1, 1, 2, 4, 0,3*0, ! new (may 2004)
377  a -1,-1, 1, 2, 4, 0,3*0, -1,-1, 1, 2, 4, 0,3*0, ! new (may 2004)
378  a -1,-1, 1, 2, 4, 0,3*0, -1,-1, 1, 2, 4, 0,3*0, ! new (sep 2004)
379  a -1,-1, 1, 2, 4, 0,3*0, -1,-1, 1, 2, 4, 0,3*0, ! new (sep 2004)
380  a -1,-1, 1, 2, 4, 0,3*0, -1,-1, 1, 2, 4, 0,3*0, ! new (sep 2004)
381  a -1,-1, 1, 2, 4, 0,3*0, -1,-1, 1, 2, 4, 0,3*0, ! new (sep 2004)
382  a -1,-1, 1, 2, 4, 0,3*0, -1,-1, 1, 2, 4, 0,3*0, ! new (sep 2004)
383  x -1,-1,-1, 1, 1, 0,3*0, ! old npi starts here
384  2 -1,-1,-1, 1, 1, 2,3*0, -1,-1, 1, 2, 2, 2,3*0,
385  a -1,-1,-1, 1, 1, 1,3*0, -1,-1, 1, 2, 2, 1,3*0, ! new (may 2004)
386  b -1,-1,-1, 1, 1, 1,3*0, -1,-1, 1, 2, 2, 1,3*0, ! new (may 2004)
387  c -1,-1,-1, 1, 1, 1,3*0, -1,-1, 1, 2, 2, 1,3*0, ! new (may 2004)
388  d -1,-1,-1, 1, 1, 1,3*0, -1,-1, 1, 2, 2, 1,3*0, ! new (may 2004)
389  e -1,-1,-1, 1, 1, 1,3*0, -1,-1, 1, 2, 2, 1,3*0, ! new (may 2004)
390  3 -3,-1, 3, 0, 0, 0,3*0, -4,-1, 4, 0, 0, 0,3*0,
391  4 -3, 2,-4, 0, 0, 0,3*0, 2, 2,-3, 0, 0, 0,3*0,
392  5 -3,-1, 1, 0, 0, 0,3*0, -1, 4, 2, 0, 0, 0,3*0,
393  6 9,-1, 2, 0, 0, 0,3*0, -1, 2, 8, 0, 0, 0,3*0,
394 
395 
396 C AJWMOD fix sign bug, 2/22/99
397  7 2, 2,-1, 0, 0, 0,3*0, ! new (may 2004) but useful
398  7 2, 2, 2, 0, 0, 0,3*0, 2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
399  7 2, 2, 2, 0, 0, 0,3*0, 2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
400  7 2, 2, 2, 0, 0, 0,3*0, 2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
401  7 2, 2, 2, 0, 0, 0,3*0, 2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
402  7 2, 2, 2, 0, 0, 0,3*0, 2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
403 
404  8 -3,-4, 0, 0, 0, 0,3*0,
405  8 -3,-3, 0, 0, 0, 0,3*0, -3,-3, 0, 0, 0, 0,3*0, ! new (may 2004)
406  8 -3,-3, 0, 0, 0, 0,3*0, -3,-3, 0, 0, 0, 0,3*0, ! new (may 2004)
407  8 -3,-3, 0, 0, 0, 0,3*0, -3,-3, 0, 0, 0, 0,3*0, ! new (may 2004)
408  8 -3,-3, 0, 0, 0, 0,3*0, -3,-3, 0, 0, 0, 0,3*0, ! new (may 2004)
409  8 -3,-3, 0, 0, 0, 0,3*0, -3,-3, 0, 0, 0, 0,3*0 /! new (may 2004)
410 
411 
412 * LIST OF BRANCHING RATIOS
413  nchan = nmode + 7
414  DO 1 i = 1,500
415  IF (i.LE.nchan) THEN
416  jlist(i) = i
417 
418  IF(i.EQ. 1) gamprt(i) =0.1800
419  IF(i.EQ. 2) gamprt(i) =0.1751
420  IF(i.EQ. 3) gamprt(i) =0.1110
421  IF(i.EQ. 4) gamprt(i) =0.2515
422  IF(i.EQ. 5) gamprt(i) =0.1790 /2
423  IF(i.EQ. 6) gamprt(i) =0.0071
424  IF(i.EQ. 7) gamprt(i) =0.0134
425  IF(i.EQ. 8) gamprt(i) =0.0450
426  IF(i.EQ. 9) gamprt(i) =0.0100
427 
428  IF(i.EQ.30) gamprt(i) =0.0009
429  IF(i.EQ.33) gamprt(i) =0.004
430  IF(i.EQ.34) gamprt(i) =0.002
431  IF(i.EQ.35) gamprt(i) =0.001
432 
433  IF(i.EQ.51) gamprt(i) =0.0004
434  IF(i.EQ.52) gamprt(i) =0.0003
435  IF(i.EQ.53) gamprt(i) =0.0005
436 
437  IF(i.EQ.64) gamprt(i) =0.0015
438  IF(i.EQ.65) gamprt(i) =0.0015
439  IF(i.EQ.66) gamprt(i) =0.0015
440  IF(i.EQ.67) gamprt(i) =0.0005
441  IF(i.EQ.68) gamprt(i) =0.0050
442  IF(i.EQ.69) gamprt(i) =0.0055
443  IF(i.EQ.70) gamprt(i) =0.0017
444  IF(i.EQ.71) gamprt(i) =0.0013
445  IF(i.EQ.72) gamprt(i) =0.1790 /2
446 
447  IF(i.EQ.83) gamprt(i) =0.0010
448 
449  IF(i.EQ. 1) oldnames(i)=' TAU- --> E- '
450  IF(i.EQ. 2) oldnames(i)=' TAU- --> MU- '
451  IF(i.EQ. 3) oldnames(i)=' TAU- --> PI- '
452  IF(i.EQ. 4) oldnames(i)=' TAU- --> PI-, PI0 '
453  IF(i.EQ. 5) oldnames(i)=' TAU- --> PI-, PI-, PI+ '
454  IF(i.EQ. 6) oldnames(i)=' TAU- --> K- '
455  IF(i.EQ. 7) oldnames(i)=' TAU- --> K*- (two subch) '
456  IF(i.EQ. 8) names(i-7)=' TAU- --> 2PI-, PI0, PI+ '
457  IF(i.EQ. 9) names(i-7)=' TAU- --> 3PI0, PI- '
458 
459  IF(i.EQ.10) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
460  IF(i.EQ.11) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
461  IF(i.EQ.12) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
462  IF(i.EQ.13) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
463  IF(i.EQ.14) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
464  IF(i.EQ.15) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
465  IF(i.EQ.16) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
466  IF(i.EQ.17) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
467  IF(i.EQ.18) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
468  IF(i.EQ.19) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
469  IF(i.EQ.20) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
470  IF(i.EQ.21) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
471  IF(i.EQ.22) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
472  IF(i.EQ.23) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
473  IF(i.EQ.24) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
474  IF(i.EQ.25) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
475  IF(i.EQ.26) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
476  IF(i.EQ.27) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
477  IF(i.EQ.28) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
478  IF(i.EQ.29) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
479 
480 
481  IF(i.EQ.30) names(i-7)=' TAU- --> 2PI-, PI+, 2PI0 old'
482  IF(i.EQ.31) names(i-7)=' TAU- --> a1 --> rho omega ' ! (may 2004)
483  IF(i.EQ.32) names(i-7)=' TAU- --> benchmark curr ' ! (may 2004)
484  IF(i.EQ.33) names(i-7)=' TAU- --> 2PI0, 2PI-, PI+ ' ! (may 2004)
485  IF(i.EQ.34) names(i-7)=' TAU- --> PI- 4PI0 ' ! (may 2004)
486  IF(i.EQ.35) names(i-7)=' TAU- --> 3PI- 2PI+ ' ! (may 2004)
487  IF(i.EQ.36) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (may 2004)
488  IF(i.EQ.37) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (may 2004)
489  IF(i.EQ.38) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (may 2004)
490  IF(i.EQ.39) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (may 2004)
491  IF(i.EQ.40) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (may 2004)
492 
493  IF(i.EQ.41) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
494  IF(i.EQ.42) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
495  IF(i.EQ.43) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
496  IF(i.EQ.44) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
497  IF(i.EQ.45) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
498  IF(i.EQ.46) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
499  IF(i.EQ.47) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
500  IF(i.EQ.48) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
501  IF(i.EQ.49) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
502  IF(i.EQ.50) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
503 
504  IF(i.EQ.51) names(i-7)=' TAU- --> 3PI-, 2PI+, '
505  IF(i.EQ.52) names(i-7)=' TAU- --> 3PI-, 2PI+, PI0 '
506  IF(i.EQ.53) names(i-7)=' TAU- --> 2PI-, PI+, 3PI0 '
507  IF(i.EQ.54) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
508  IF(i.EQ.55) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
509  IF(i.EQ.56) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
510  IF(i.EQ.57) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
511  IF(i.EQ.58) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
512  IF(i.EQ.59) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
513  IF(i.EQ.60) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
514  IF(i.EQ.61) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
515  IF(i.EQ.62) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
516  IF(i.EQ.63) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
517 
518  IF(i.EQ.64) names(i-7)=' TAU- --> K-, PI-, K+ '
519  IF(i.EQ.65) names(i-7)=' TAU- --> K0, PI-, K0B '
520 
521  IF(i.EQ.66) names(i-7)=' TAU- --> K-, K0, PI0 '
522 
523  IF(i.EQ.67) names(i-7)=' TAU- --> PI0 PI0 K- '
524  IF(i.EQ.68) names(i-7)=' TAU- --> K- PI- PI+ '
525  IF(i.EQ.69) names(i-7)=' TAU- --> PI- K0B PI0 '
526  IF(i.EQ.70) names(i-7)=' TAU- --> ETA PI- PI0 '
527  IF(i.EQ.71) names(i-7)=' TAU- --> PI- PI0 GAM '
528  IF(i.EQ.72) names(i-7)=' TAU- --> PI- PI0 PI0 '
529  IF(i.EQ.73) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
530  IF(i.EQ.74) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
531  IF(i.EQ.75) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
532  IF(i.EQ.76) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
533  IF(i.EQ.77) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
534  IF(i.EQ.78) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
535  IF(i.EQ.79) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
536  IF(i.EQ.80) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
537  IF(i.EQ.81) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
538  IF(i.EQ.82) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
539 
540 
541  IF(i.EQ.83) names(i-7)=' TAU- --> K- K0 '
542  IF(i.EQ.84) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
543  IF(i.EQ.85) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
544  IF(i.EQ.86) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
545  IF(i.EQ.87) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
546  IF(i.EQ.88) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
547  IF(i.EQ.89) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
548  IF(i.EQ.90) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
549  IF(i.EQ.91) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
550  IF(i.EQ.92) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
551  IF(i.EQ.93) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
552 
553  ELSE
554  jlist(i) = 0
555  gamprt(i) = 0.
556  ENDIF
557  1 CONTINUE
558  DO i=1,nmode
559  mulpik(i)=npik(i)
560  DO j=1,mulpik(i)
561  idffin(j,i)=nopik(j,i)
562  ENDDO
563  ENDDO
564  DO i=1,nchan
565  gamprt(i) = 1d0/nchan
566  ENDDO
567  gamprt(31)=gamprt(31)*0.001
568  gamprt(32)=gamprt(32)*0.001
569  do k=1,10 ! these are brs for empty slots prepared for new channels
570  gamprt(36+k)=gamprt(36+k)*0.001
571  gamprt(30-k)=gamprt(30-k)*0.001
572  gamprt(30+10+k)=gamprt(30+10+k)*0.001
573  gamprt(30-10-k)=gamprt(30-10-k)*0.001
574 
575  gamprt(53+k)=gamprt(53+k)*0.001
576  gamprt(72+k)=gamprt(72+k)*0.001
577  gamprt(83+k)=gamprt(83+k)*0.001
578  enddo
579  gamprt(72)=gamprt(72)/2
580  gamprt(5)=gamprt(5)/2
581 
582 *
583 *
584 * --- COEFFICIENTS TO FIX RATIO OF:
585 * --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
586 * --- PROBABILITY OF K0 TO BE KS
587 * --- PROBABILITY OF K0B TO BE KS
588 * --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
589 * --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
590 * --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
591 * --- NEGLECTS MASS-PHASE SPACE EFFECTS
592  bra1=1d0 ! 0.5
593  brk0=0.5
594  brk0b=0.5
595  brks=0.6667
596 *
597 
598  gfermi = 1.16637e-5
599  ccabib = 0.975
600  gv = 1.0
601  ga =-1.0
602 
603 
604 
605 * ZW 13.04.89 HERE WAS AN ERROR
606  scabib = sqrt(1.-ccabib**2)
607  pi =4.*atan(1.)
608  gamel = gfermi**2*amtau**5/(192*pi**3)
609 *
610  CALL dexay(-1,pol1)
611 *
612  RETURN
613  END
614  FUNCTION dcdmas(IDENT)
615  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
616  * ,ampiz,ampi,amro,gamro,ama1,gama1
617  * ,amk,amkz,amkst,gamkst
618 *
619  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
620  * ,ampiz,ampi,amro,gamro,ama1,gama1
621  * ,amk,amkz,amkst,gamkst
622  IF (ident.EQ. 1) THEN
623  apkmas=ampi
624  ELSEIF (ident.EQ.-1) THEN
625  apkmas=ampi
626  ELSEIF (ident.EQ. 2) THEN
627  apkmas=ampiz
628  ELSEIF (ident.EQ.-2) THEN
629  apkmas=ampiz
630  ELSEIF (ident.EQ. 3) THEN
631  apkmas=amk
632  ELSEIF (ident.EQ.-3) THEN
633  apkmas=amk
634  ELSEIF (ident.EQ. 4) THEN
635  apkmas=amkz
636  ELSEIF (ident.EQ.-4) THEN
637  apkmas=amkz
638  ELSEIF (ident.EQ. 8) THEN
639  apkmas=0.0001
640  ELSEIF (ident.EQ.-8) THEN
641  apkmas=0.0001
642  ELSEIF (ident.EQ. 9) THEN
643  apkmas=0.5488
644  ELSEIF (ident.EQ.-9) THEN
645  apkmas=0.5488
646  ELSE
647  print *, 'STOP IN APKMAS, WRONG IDENT=',ident
648  stop
649  ENDIF
650  dcdmas=apkmas
651  END
652  FUNCTION lunpik(ID,ISGN)
653  COMMON / taukle / bra1,brk0,brk0b,brks
654  REAL*4 BRA1,BRK0,BRK0B,BRKS
655  REAL*4 XIO(1)
656  ident=id*isgn
657 
658  IF (ident.EQ. 1) THEN
659  ipkdef=-211
660  ELSEIF (ident.EQ.-1) THEN
661  ipkdef= 211
662  ELSEIF (ident.EQ. 2) THEN
663  ipkdef=111
664  ELSEIF (ident.EQ.-2) THEN
665  ipkdef=111
666  ELSEIF (ident.EQ. 3) THEN
667  ipkdef=-321
668  ELSEIF (ident.EQ.-3) THEN
669  ipkdef= 321
670 
671  ELSEIF (ident.EQ. 4) THEN
672 *
673 * K0 --> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
674  CALL ranmar(xio,1)
675  IF (xio(1).GT.brk0) THEN
676  ipkdef= 130
677  ELSE
678  ipkdef= 310
679  ENDIF
680  ELSEIF (ident.EQ.-4) THEN
681 *
682 * K0B--> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
683  CALL ranmar(xio,1)
684  IF (xio(1).GT.brk0b) THEN
685  ipkdef= 130
686  ELSE
687  ipkdef= 310
688  ENDIF
689  ELSEIF (ident.EQ. 8) THEN
690  ipkdef= 22
691  ELSEIF (ident.EQ.-8) THEN
692  ipkdef= 22
693  ELSEIF (ident.EQ. 9) THEN
694  ipkdef= 221
695  ELSEIF (ident.EQ.-9) THEN
696  ipkdef= 221
697  ELSE
698  print *, 'STOP IN IPKDEF, WRONG IDENT=',ident
699  stop
700  ENDIF
701  lunpik=ipkdef
702  END
703 
704 
705 
706 
707  SUBROUTINE taurdf(KTO)
708 C THIS ROUTINE CAN BE CALLED BEFORE ANY TAU+ OR TAU- EVENT IS GENERATED
709 C IT CAN BE USED TO GENERATE TAU+ AND TAU- SAMPLES OF DIFFERENT
710 C CONTENTS
711  COMMON / taukle / bra1,brk0,brk0b,brks
712  REAL*4 BRA1,BRK0,BRK0B,BRKS
713  COMMON / taubra / gamprt(500),jlist(500),nchan
714  IF (kto.EQ.1) THEN
715 C ==================
716 C AJWMOD: Set the BRs for (A1+ -> rho+ pi0) and (K*+ -> K0 pi+)
717  bra1 = pkorb(4,1)
718  brks = pkorb(4,3)
719  brk0 = pkorb(4,5)
720  brk0b = pkorb(4,6)
721  ELSE
722 C ====
723 C AJWMOD: Set the BRs for (A1+ -> rho+ pi0) and (K*+ -> K0 pi+)
724  bra1 = pkorb(4,2)
725  brks = pkorb(4,4)
726  brk0 = pkorb(4,5)
727  brk0b = pkorb(4,6)
728  ENDIF
729 C =====
730  END
731 
732 
733  SUBROUTINE iniphx(XK00)
734 * ----------------------------------------------------------------------
735 * INITIALISATION OF PARAMETERS
736 * USED IN QED and/or GSW ROUTINES
737 * ----------------------------------------------------------------------
738  COMMON / qedprm /alfinv,alfpi,xk0
739  REAL*8 ALFINV,ALFPI,XK0
740  REAL*8 PI8,XK00
741 *
742  pi8 = 4.d0*datan(1.d0)
743  alfinv = 137.03604d0
744  alfpi = 1d0/(alfinv*pi8)
745  xk0=xk00
746  END
747 
748  SUBROUTINE inimas
749 C ----------------------------------------------------------------------
750 C INITIALISATION OF MASSES
751 C
752 C called by : KORALZ
753 C ----------------------------------------------------------------------
754  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
755  * ,ampiz,ampi,amro,gamro,ama1,gama1
756  * ,amk,amkz,amkst,gamkst
757 *
758  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
759  * ,ampiz,ampi,amro,gamro,ama1,gama1
760  * ,amk,amkz,amkst,gamkst
761 C
762 C IN-COMING / OUT-GOING FERMION MASSES
763  amtau = 1.7842
764 C --- tau mass must be the same as in the host program, what-so-ever
765  amtau = 1.777
766  amnuta = 0.010
767  amel = 0.0005111
768  amnue = 0.0
769  ammu = 0.105659
770  amnumu = 0.0
771 *
772 * MASSES USED IN TAU DECAYS
773 
774  ampiz = 0.134964
775  ampi = 0.139568
776  amro = 0.773
777  gamro = 0.145
778 *C GAMRO = 0.666
779  ama1 = 1.251
780  gama1 = 0.599
781  amk = 0.493667
782  amkz = 0.49772
783  amkst = 0.8921
784  gamkst = 0.0513
785 C
786 C
787 C IN-COMING / OUT-GOING FERMION MASSES
788 !! AMNUTA = PKORB(1,2)
789 !! AMNUE = PKORB(1,4)
790 !! AMNUMU = PKORB(1,6)
791 C
792 C MASSES USED IN TAU DECAYS Cleo settings
793 !! AMPIZ = PKORB(1,7)
794 !! AMPI = PKORB(1,8)
795 !! AMRO = PKORB(1,9)
796 !! GAMRO = PKORB(2,9)
797  ama1 = 1.275 !! PKORB(1,10)
798  gama1 = 0.615 !! PKORB(2,10)
799 !! AMK = PKORB(1,11)
800 !! AMKZ = PKORB(1,12)
801 !! AMKST = PKORB(1,13)
802 !! GAMKST = PKORB(2,13)
803 C
804 
805 
806  RETURN
807  END
808  subroutine bostdq(idir,vv,pp,q)
809 * *******************************
810 c Boost along arbitrary vector v (see eg. J.D. Jacson, Classical
811 c Electrodynamics).
812 c Four-vector pp is boosted from an actual frame to the rest frame
813 c of the four-vector v (for idir=1) or back (for idir=-1).
814 c q is a resulting four-vector.
815 c Note: v must be time-like, pp may be arbitrary.
816 c
817 c Written by: Wieslaw Placzek date: 22.07.1994
818 c Last update: 3/29/95 by: M.S.
819 c
820  implicit DOUBLE PRECISION (a-h,o-z)
821  parameter(nout=6)
822  DOUBLE PRECISION v(4),p(4),q(4),pp(4),vv(4)
823  save
824 !
825  do 1 i=1,4
826  v(i)=vv(i)
827  1 p(i)=pp(i)
828  amv=(v(4)**2-v(1)**2-v(2)**2-v(3)**2)
829  if (amv.le.0d0) then
830  write(6,*) 'bosstv: warning amv**2=',amv
831  endif
832  amv=sqrt(abs(amv))
833  if (idir.eq.-1) then
834  q(4)=( p(1)*v(1)+p(2)*v(2)+p(3)*v(3)+p(4)*v(4))/amv
835  wsp =(q(4)+p(4))/(v(4)+amv)
836  elseif (idir.eq.1) then
837  q(4)=(-p(1)*v(1)-p(2)*v(2)-p(3)*v(3)+p(4)*v(4))/amv
838  wsp =-(q(4)+p(4))/(v(4)+amv)
839  else
840  write(nout,*)' >>> boostv: wrong value of idir = ',idir
841  endif
842  q(1)=p(1)+wsp*v(1)
843  q(2)=p(2)+wsp*v(2)
844  q(3)=p(3)+wsp*v(3)
845  end
846 
847 
848 
849 
850 
851 
852 
853 
854 
855