C++InterfacetoTauola
tauola-factory/prod/tauola.F
1 #if defined (ALEPH)
2 C=============================================================
3 #endif
4  SUBROUTINE jaker(JAK)
5 C *********************
6 C
7 C **********************************************************************
8 C *
9 #if defined (ALEPH)
10 C *********TAUOLA LIBRARY: VERSION 2.7 ******** *
11 C **************DECEMBER 1993****************** *
12 #else
13 C *********TAUOLA LIBRARY: VERSION 2.7 ******** *
14 C **************August 1995****************** *
15 #endif
16 C ** AUTHORS: S.JADACH, Z.WAS ***** *
17 C ** R. DECKER, M. JEZABEK, J.H.KUEHN, ***** *
18 C ********AVAILABLE FROM: WASM AT CERNVM ****** *
19 C *******PUBLISHED IN COMP. PHYS. COMM.******** *
20 C *** PREPRINT CERN-TH-5856 SEPTEMBER 1990 **** *
21 C *** PREPRINT CERN-TH-6195 OCTOBER 1991 **** *
22 C *** PREPRINT CERN-TH-6793 NOVEMBER 1992 **** *
23 C **********************************************************************
24 C
25 C ----------------------------------------------------------------------
26 c SUBROUTINE JAKER,
27 C CHOOSES DECAY MODE ACCORDING TO LIST OF BRANCHING RATIOS
28 C JAK=1 ELECTRON MODE
29 C JAK=2 MUON MODE
30 C JAK=3 PION MODE
31 C JAK=4 RHO MODE
32 C JAK=5 A1 MODE
33 C JAK=6 K MODE
34 C JAK=7 K* MODE
35 #if defined (ALEPH)
36 C JAK=8-13 npi modes
37 C JAK=14-19 KKpi & Kpipi modes
38 C JAK=20-21 eta pi pi; gamma pi pi modes
39 #else
40 C JAK=8 nPI MODE
41 #endif
42 C
43 C called by : DEXAY
44 C ----------------------------------------------------------------------
45  COMMON / taubra / gamprt(30),jlist(30),nchan
46 #if defined (ALEPH)
47 #else
48 C REAL CUMUL(20)
49 #endif
50  REAL CUMUL(30),RRR(1)
51 C
52  IF(nchan.LE.0.OR.nchan.GT.30) GOTO 902
53  CALL ranmar(rrr,1)
54  sum=0
55  DO 20 i=1,nchan
56  sum=sum+gamprt(i)
57  20 cumul(i)=sum
58  DO 25 i=nchan,1,-1
59  IF(rrr(1).LT.cumul(i)/cumul(nchan)) ji=i
60  25 CONTINUE
61  jak=jlist(ji)
62  RETURN
63  902 print 9020
64  9020 FORMAT(' ----- JAKER: WRONG NCHAN')
65  stop
66  END
67  SUBROUTINE dekay(KTO,HX)
68 C ***********************
69 C THIS DEKAY IS IN SPIRIT OF THE 'DECAY' WHICH
70 C WAS INCLUDED IN KORAL-B PROGRAM, COMP. PHYS. COMMUN.
71 C VOL. 36 (1985) 191, SEE COMMENTS ON GENERAL PHILOSOPHY THERE.
72 C KTO=0 INITIALISATION (OBLIGATORY)
73 C KTO=1,11 DENOTES TAU+ AND KTO=2,12 TAU-
74 C DEKAY(1,H) AND DEKAY(2,H) IS CALLED INTERNALLY BY MC GENERATOR.
75 C H DENOTES THE POLARIMETRIC VECTOR, USED BY THE HOST PROGRAM FOR
76 C CALCULATION OF THE SPIN WEIGHT.
77 C USER MAY OPTIONALLY CALL DEKAY(11,H) DEKAY(12,H) IN ORDER
78 C TO TRANSFORM DECAY PRODUCTS TO CMS AND WRITE LUND RECORD IN /LUJETS/.
79 C KTO=100, PRINT FINAL REPORT (OPTIONAL).
80 C DECAY MODES:
81 C JAK=1 ELECTRON DECAY
82 C JAK=2 MU DECAY
83 C JAK=3 PI DECAY
84 C JAK=4 RHO DECAY
85 C JAK=5 A1 DECAY
86 C JAK=6 K DECAY
87 C JAK=7 K* DECAY
88 #if defined (ALEPH)
89 C JAK= 8-13 npi modes
90 C JAK=14-19 KKpi & Kpipi modes
91 C JAK=20-21 eta pi pi; gamma pi pi modes
92 C JAK=0 INCLUSIVE: JAK=1-21
93 #else
94 C JAK=8 NPI DECAY
95 C JAK=0 INCLUSIVE: JAK=1,2,3,4,5,6,7,8
96 #endif
97  REAL H(4)
98  REAL*8 HX(4)
99  COMMON / jaki / jak1,jak2,jakp,jakm,ktom
100 #if defined (ALEPH)
101  COMMON / idfc / idff
102 #else
103  COMMON / idfc / idf
104 #endif
105  COMMON /taupos/ np1,np2
106  COMMON / taubmc / gampmc(30),gamper(30),nevdec(30)
107  REAL*4 GAMPMC ,GAMPER
108  parameter(nmode=15,nm1=0,nm2=1,nm3=8,nm4=2,nm5=1,nm6=3)
109 #if defined (ALEPH)
110  COMMON / taudcd /idffin(9,nmode),mulpik(nmode)
111 #else
112  COMMON / taudcd /idffin(9,nmode),mulpik(nmode)
113 #endif
114  & ,names
115  CHARACTER NAMES(NMODE)*31
116  COMMON / inout / inut,iout
117  REAL PDUM1(4),PDUM2(4),PDUM3(4),PDUM4(4),PDUM5(4),HDUM(4)
118  REAL PDUMX(4,9)
119  DATA iwarm/0/
120  ktom=kto
121 #if defined (ALEPH)
122  idf =idff
123 #endif
124  IF(kto.EQ.-1) THEN
125 C ==================
126 C INITIALISATION OR REINITIALISATION
127 C first or second tau positions in HEPEVT as in KORALB/Z
128  np1=3
129  np2=4
130  ktom=1
131  IF (iwarm.EQ.1) x=5/(iwarm-1)
132  iwarm=1
133  WRITE(iout,7001) jak1,jak2
134  nevtot=0
135  nev1=0
136  nev2=0
137  IF(jak1.NE.-1.OR.jak2.NE.-1) THEN
138  CALL dadmel(-1,idum,hdum,pdum1,pdum2,pdum3,pdum4,pdum5)
139  CALL dadmmu(-1,idum,hdum,pdum1,pdum2,pdum3,pdum4,pdum5)
140  CALL dadmpi(-1,idum,pdum,pdum1,pdum2)
141  CALL dadmro(-1,idum,hdum,pdum1,pdum2,pdum3,pdum4)
142  CALL dadmaa(-1,idum,hdum,pdum1,pdum2,pdum3,pdum4,pdum5,jdum)
143  CALL dadmkk(-1,idum,pdum,pdum1,pdum2)
144  CALL dadmks(-1,idum,hdum,pdum1,pdum2,pdum3,pdum4,jdum)
145  CALL dadnew(-1,idum,hdum,pdum1,pdum2,pdumx,jdum)
146  ENDIF
147  DO 21 i=1,30
148  nevdec(i)=0
149  gampmc(i)=0
150  21 gamper(i)=0
151  ELSEIF(kto.EQ.1) THEN
152 C =====================
153 C DECAY OF TAU+ IN THE TAU REST FRAME
154  nevtot=nevtot+1
155  IF(iwarm.EQ.0) GOTO 902
156  isgn= idf/iabs(idf)
157 #if defined (CePeCe)
158 #elif defined (ALEPH)
159 #else
160 C AJWMOD to change BRs depending on sign:
161  CALL taurdf(kto)
162 #endif
163  CALL dekay1(0,h,isgn)
164  ELSEIF(kto.EQ.2) THEN
165 C =================================
166 C DECAY OF TAU- IN THE TAU REST FRAME
167  nevtot=nevtot+1
168  IF(iwarm.EQ.0) GOTO 902
169  isgn=-idf/iabs(idf)
170 #if defined (CePeCe)
171 #elif defined (ALEPH)
172 #else
173 C AJWMOD to change BRs depending on sign:
174  CALL taurdf(kto)
175 #endif
176  CALL dekay2(0,h,isgn)
177  ELSEIF(kto.EQ.11) THEN
178 C ======================
179 C REST OF DECAY PROCEDURE FOR ACCEPTED TAU+ DECAY
180  nev1=nev1+1
181  isgn= idf/iabs(idf)
182  CALL dekay1(1,h,isgn)
183  ELSEIF(kto.EQ.12) THEN
184 C ======================
185 C REST OF DECAY PROCEDURE FOR ACCEPTED TAU- DECAY
186  nev2=nev2+1
187  isgn=-idf/iabs(idf)
188  CALL dekay2(1,h,isgn)
189  ELSEIF(kto.EQ.100) THEN
190 C =======================
191  IF(jak1.NE.-1.OR.jak2.NE.-1) THEN
192  CALL dadmel( 1,idum,hdum,pdum1,pdum2,pdum3,pdum4,pdum5)
193  CALL dadmmu( 1,idum,hdum,pdum1,pdum2,pdum3,pdum4,pdum5)
194  CALL dadmpi( 1,idum,pdum,pdum1,pdum2)
195  CALL dadmro( 1,idum,hdum,pdum1,pdum2,pdum3,pdum4)
196  CALL dadmaa( 1,idum,hdum,pdum1,pdum2,pdum3,pdum4,pdum5,jdum)
197  CALL dadmkk( 1,idum,pdum,pdum1,pdum2)
198  CALL dadmks( 1,idum,hdum,pdum1,pdum2,pdum3,pdum4,jdum)
199  CALL dadnew( 1,idum,hdum,pdum1,pdum2,pdumx,jdum)
200  WRITE(iout,7010) nev1,nev2,nevtot
201  WRITE(iout,7011) (nevdec(i),gampmc(i),gamper(i),i= 1,7)
202  WRITE(iout,7012)
203  $ (nevdec(i),gampmc(i),gamper(i),names(i-7),i=8,7+nmode)
204  WRITE(iout,7013)
205  ENDIF
206  ELSE
207 C ====
208  GOTO 910
209  ENDIF
210 C =====
211  DO 78 k=1,4
212  78 hx(k)=h(k)
213  RETURN
214  7001 FORMAT(///1x,15(5h*****)
215 #if defined (ALEPH)
216  $ /,' *', 25x,'*****TAUOLA LIBRARY: VERSION 2.7 ******',9x,1h*,
217  $ /,' *', 25x,'*DEC 1993; ALEPH fixes introd. dec 98 *',9x,1h*,
218  $ /,' *', 25x,'**AUTHORS: S.JADACH, Z.WAS*************',9x,1h*,
219  $ /,' *', 25x,'**R. DECKER, M. JEZABEK, J.H.KUEHN*****',9x,1h*,
220  $ /,' *', 25x,'***** PUBLISHED IN COMP. PHYS. COMM.***',9x,1h*,
221  $ /,' *', 25x,'Physics initialization by ALEPH collab ',9x,1h*,
222  $ /,' *', 25x,'it is suggested to use this version ',9x,1h*,
223  $ /,' *', 25x,' with the help of the collab. advice ',9x,1h*,
224  $ /,' *', 25x,'*******CERN TH-6793 NOVEMBER 1992*****',9x,1h*,
225  $ /,' *', 25x,'**5 or more pi dec.: precision limited ',9x,1h*,
226 #elif defined (CLEO)
227  $ /,' *', 25x,'*****TAUOLA LIBRARY: VERSION 2.7 ******',9x,1h*,
228  $ /,' *', 25x,'***********August 1995***************',9x,1h*,
229  $ /,' *', 25x,'**AUTHORS: S.JADACH, Z.WAS*************',9x,1h*,
230  $ /,' *', 25x,'**R. DECKER, M. JEZABEK, J.H.KUEHN*****',9x,1h*,
231  $ /,' *', 25x,'**AVAILABLE FROM: WASM AT CERNVM ******',9x,1h*,
232  $ /,' *', 25x,'***** PUBLISHED IN COMP. PHYS. COMM.***',9x,1h*,
233  $ /,' *', 25x,' Physics initialization by CLEO collab ',9x,1h*,
234  $ /,' *', 25x,' see Alain Weinstein www home page: ',9x,1h*,
235  $ /,' *', 25x,'http://www.cithep.caltech.edu/~ajw/ ',9x,1h*,
236  $ /,' *', 25x,'/korb_doc.html#files ',9x,1h*,
237  $ /,' *', 25x,'*******CERN TH-6793 NOVEMBER 1992*****',9x,1h*,
238  $ /,' *', 25x,'**5 or more pi dec.: precision limited ',9x,1h*,
239 #else
240  $ /,' *', 25x,'*****TAUOLA LIBRARY: VERSION 2.7 ******',9x,1h*,
241  $ /,' *', 25x,'***********August 1995***************',9x,1h*,
242  $ /,' *', 25x,'**AUTHORS: S.JADACH, Z.WAS*************',9x,1h*,
243  $ /,' *', 25x,'**R. DECKER, M. JEZABEK, J.H.KUEHN*****',9x,1h*,
244  $ /,' *', 25x,'**AVAILABLE FROM: WASM AT CERNVM ******',9x,1h*,
245  $ /,' *', 25x,'***** PUBLISHED IN COMP. PHYS. COMM.***',9x,1h*,
246  $ /,' *', 25x,'*******CERN-TH-5856 SEPTEMBER 1990*****',9x,1h*,
247  $ /,' *', 25x,'*******CERN-TH-6195 SEPTEMBER 1991*****',9x,1h*,
248  $ /,' *', 25x,'*******CERN TH-6793 NOVEMBER 1992*****',9x,1h*,
249  $ /,' *', 25x,'**5 or more pi dec.: precision limited ',9x,1h*,
250 #endif
251  $ /,' *', 25x,'****DEKAY ROUTINE: INITIALIZATION******',9x,1h*,
252  $ /,' *',i20 ,5x,'JAK1 = DECAY MODE TAU+ ',9x,1h*,
253  $ /,' *',i20 ,5x,'JAK2 = DECAY MODE TAU- ',9x,1h*,
254  $ /,1x,15(5h*****)/)
255  7010 FORMAT(///1x,15(5h*****)
256 #if defined (ALEPH)
257  $ /,' *', 25x,'*****TAUOLA LIBRARY: VERSION 2.7 ******',9x,1h*,
258  $ /,' *', 25x,'***********DECEMBER 1993***************',9x,1h*,
259 #else
260  $ /,' *', 25x,'*****TAUOLA LIBRARY: VERSION 2.7 ******',9x,1h*,
261  $ /,' *', 25x,'***********August 1995***************',9x,1h*,
262 #endif
263  $ /,' *', 25x,'**AUTHORS: S.JADACH, Z.WAS*************',9x,1h*,
264  $ /,' *', 25x,'**R. DECKER, M. JEZABEK, J.H.KUEHN*****',9x,1h*,
265  $ /,' *', 25x,'**AVAILABLE FROM: WASM AT CERNVM ******',9x,1h*,
266  $ /,' *', 25x,'***** PUBLISHED IN COMP. PHYS. COMM.***',9x,1h*,
267  $ /,' *', 25x,'*******CERN-TH-5856 SEPTEMBER 1990*****',9x,1h*,
268  $ /,' *', 25x,'*******CERN-TH-6195 SEPTEMBER 1991*****',9x,1h*,
269  $ /,' *', 25x,'*******CERN TH-6793 NOVEMBER 1992*****',9x,1h*,
270  $ /,' *', 25x,'*****DEKAY ROUTINE: FINAL REPORT*******',9x,1h*,
271  $ /,' *',i20 ,5x,'NEV1 = NO. OF TAU+ DECS. ACCEPTED ',9x,1h*,
272  $ /,' *',i20 ,5x,'NEV2 = NO. OF TAU- DECS. ACCEPTED ',9x,1h*,
273  $ /,' *',i20 ,5x,'NEVTOT = SUM ',9x,1h*,
274  $ /,' *',' NOEVTS ',
275  $ ' PART.WIDTH ERROR ROUTINE DECAY MODE ',9x,1h*)
276  7011 FORMAT(1x,'*'
277  $ ,i10,2f12.7 ,' DADMEL ELECTRON ',9x,1h*
278  $ /,' *',i10,2f12.7 ,' DADMMU MUON ',9x,1h*
279  $ /,' *',i10,2f12.7 ,' DADMPI PION ',9x,1h*
280  $ /,' *',i10,2f12.7, ' DADMRO RHO (->2PI) ',9x,1h*
281  $ /,' *',i10,2f12.7, ' DADMAA A1 (->3PI) ',9x,1h*
282  $ /,' *',i10,2f12.7, ' DADMKK KAON ',9x,1h*
283  $ /,' *',i10,2f12.7, ' DADMKS K* ',9x,1h*)
284  7012 FORMAT(1x,'*'
285  $ ,i10,2f12.7,a31 ,8x,1h*)
286  7013 FORMAT(1x,'*'
287  $ ,20x,'THE ERROR IS RELATIVE AND PART.WIDTH ',10x,1h*
288  $ /,' *',20x,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',10x,1h*
289  $ /,1x,15(5h*****)/)
290  902 print 9020
291  9020 FORMAT(' ----- DEKAY: LACK OF INITIALISATION')
292  stop
293  910 print 9100
294  9100 FORMAT(' ----- DEKAY: WRONG VALUE OF KTO ')
295  stop
296  END
297  SUBROUTINE dekay1(IMOD,HH,ISGN)
298 C *******************************
299 C THIS ROUTINE SIMULATES TAU+ DECAY
300 #if defined (ALEPH)
301  COMMON / jaki / jak1,jak2,jakp,jakm,ktom
302  COMMON / taubmc / gampmc(30),gamper(30),nevdec(30)
303  REAL*4 GAMPMC ,GAMPER
304  COMMON / decp4 / pp1(4),pp2(4),kff1,kff2
305  REAL*4 PP1 ,PP2
306  INTEGER KFF1,KFF2
307 #else
308  COMMON / decp4 / pp1(4),pp2(4),kf1,kf2
309  COMMON / jaki / jak1,jak2,jakp,jakm,ktom
310  COMMON / taubmc / gampmc(30),gamper(30),nevdec(30)
311  REAL*4 GAMPMC ,GAMPER
312 #endif
313  REAL HH(4)
314  REAL HV(4),PNU(4),PPI(4)
315  REAL PWB(4),PMU(4),PNM(4)
316  REAL PRHO(4),PIC(4),PIZ(4)
317  REAL PAA(4),PIM1(4),PIM2(4),PIPL(4)
318  REAL PKK(4),PKS(4)
319  REAL PNPI(4,9)
320  REAL PHOT(4)
321  REAL PDUM(4)
322  DATA nev,nprin/0,10/
323  kto=1
324  IF(jak1.EQ.-1) RETURN
325  imd=imod
326  IF(imd.EQ.0) THEN
327 C =================
328  jak=jak1
329  IF(jak1.EQ.0) CALL jaker(jak)
330  IF(jak.EQ.1) THEN
331  CALL dadmel(0, isgn,hv,pnu,pwb,pmu,pnm,phot)
332  ELSEIF(jak.EQ.2) THEN
333  CALL dadmmu(0, isgn,hv,pnu,pwb,pmu,pnm,phot)
334  ELSEIF(jak.EQ.3) THEN
335  CALL dadmpi(0, isgn,hv,ppi,pnu)
336  ELSEIF(jak.EQ.4) THEN
337  CALL dadmro(0, isgn,hv,pnu,prho,pic,piz)
338  ELSEIF(jak.EQ.5) THEN
339  CALL dadmaa(0, isgn,hv,pnu,paa,pim1,pim2,pipl,jaa)
340  ELSEIF(jak.EQ.6) THEN
341  CALL dadmkk(0, isgn,hv,pkk,pnu)
342  ELSEIF(jak.EQ.7) THEN
343  CALL dadmks(0, isgn,hv,pnu,pks ,pkk,ppi,jkst)
344  ELSE
345  CALL dadnew(0, isgn,hv,pnu,pwb,pnpi,jak-7)
346  ENDIF
347  DO 33 i=1,3
348  33 hh(i)=hv(i)
349  hh(4)=1.0
350 
351  ELSEIF(imd.EQ.1) THEN
352 C =====================
353  nev=nev+1
354  IF (jak.LT.31) THEN
355  nevdec(jak)=nevdec(jak)+1
356  ENDIF
357  DO 34 i=1,4
358  34 pdum(i)=.0
359  IF(jak.EQ.1) THEN
360  CALL dwluel(1,isgn,pnu,pwb,pmu,pnm)
361  CALL dwrph(ktom,phot)
362  DO 10 i=1,4
363  10 pp1(i)=pmu(i)
364 
365  ELSEIF(jak.EQ.2) THEN
366  CALL dwlumu(1,isgn,pnu,pwb,pmu,pnm)
367  CALL dwrph(ktom,phot)
368  DO 20 i=1,4
369  20 pp1(i)=pmu(i)
370 
371  ELSEIF(jak.EQ.3) THEN
372  CALL dwlupi(1,isgn,ppi,pnu)
373  DO 30 i=1,4
374  30 pp1(i)=ppi(i)
375 
376  ELSEIF(jak.EQ.4) THEN
377  CALL dwluro(1,isgn,pnu,prho,pic,piz)
378  DO 40 i=1,4
379  40 pp1(i)=prho(i)
380 
381  ELSEIF(jak.EQ.5) THEN
382  CALL dwluaa(1,isgn,pnu,paa,pim1,pim2,pipl,jaa)
383  DO 50 i=1,4
384  50 pp1(i)=paa(i)
385  ELSEIF(jak.EQ.6) THEN
386  CALL dwlukk(1,isgn,pkk,pnu)
387  DO 60 i=1,4
388  60 pp1(i)=pkk(i)
389  ELSEIF(jak.EQ.7) THEN
390  CALL dwluks(1,isgn,pnu,pks,pkk,ppi,jkst)
391  DO 70 i=1,4
392  70 pp1(i)=pks(i)
393  ELSE
394 CAM MULTIPION DECAY
395  CALL dwlnew(1,isgn,pnu,pwb,pnpi,jak)
396  DO 80 i=1,4
397  80 pp1(i)=pwb(i)
398  ENDIF
399 
400  ENDIF
401 C =====
402  END
403  SUBROUTINE dekay2(IMOD,HH,ISGN)
404 C *******************************
405 C THIS ROUTINE SIMULATES TAU- DECAY
406 #if defined (ALEPH)
407  COMMON / jaki / jak1,jak2,jakp,jakm,ktom
408  COMMON / taubmc / gampmc(30),gamper(30),nevdec(30)
409  REAL*4 GAMPMC ,GAMPER
410  COMMON / decp4 / pp1(4),pp2(4),kff1,kff2
411  REAL*4 PP1 ,PP2
412  INTEGER KFF1,KFF2
413 #else
414  COMMON / decp4 / pp1(4),pp2(4),kf1,kf2
415  COMMON / jaki / jak1,jak2,jakp,jakm,ktom
416  COMMON / taubmc / gampmc(30),gamper(30),nevdec(30)
417  REAL*4 GAMPMC ,GAMPER
418 #endif
419  REAL HH(4)
420  REAL HV(4),PNU(4),PPI(4)
421  REAL PWB(4),PMU(4),PNM(4)
422  REAL PRHO(4),PIC(4),PIZ(4)
423  REAL PAA(4),PIM1(4),PIM2(4),PIPL(4)
424  REAL PKK(4),PKS(4)
425  REAL PNPI(4,9)
426  REAL PHOT(4)
427  REAL PDUM(4)
428  DATA nev,nprin/0,10/
429  kto=2
430  IF(jak2.EQ.-1) RETURN
431  imd=imod
432  IF(imd.EQ.0) THEN
433 C =================
434  jak=jak2
435  IF(jak2.EQ.0) CALL jaker(jak)
436  IF(jak.EQ.1) THEN
437  CALL dadmel(0, isgn,hv,pnu,pwb,pmu,pnm,phot)
438  ELSEIF(jak.EQ.2) THEN
439  CALL dadmmu(0, isgn,hv,pnu,pwb,pmu,pnm,phot)
440  ELSEIF(jak.EQ.3) THEN
441  CALL dadmpi(0, isgn,hv,ppi,pnu)
442  ELSEIF(jak.EQ.4) THEN
443  CALL dadmro(0, isgn,hv,pnu,prho,pic,piz)
444  ELSEIF(jak.EQ.5) THEN
445  CALL dadmaa(0, isgn,hv,pnu,paa,pim1,pim2,pipl,jaa)
446  ELSEIF(jak.EQ.6) THEN
447  CALL dadmkk(0, isgn,hv,pkk,pnu)
448  ELSEIF(jak.EQ.7) THEN
449  CALL dadmks(0, isgn,hv,pnu,pks ,pkk,ppi,jkst)
450  ELSE
451  CALL dadnew(0, isgn,hv,pnu,pwb,pnpi,jak-7)
452  ENDIF
453  DO 33 i=1,3
454  33 hh(i)=hv(i)
455  hh(4)=1.0
456  ELSEIF(imd.EQ.1) THEN
457 C =====================
458  nev=nev+1
459  IF (jak.LT.31) THEN
460  nevdec(jak)=nevdec(jak)+1
461  ENDIF
462  DO 34 i=1,4
463  34 pdum(i)=.0
464  IF(jak.EQ.1) THEN
465  CALL dwluel(2,isgn,pnu,pwb,pmu,pnm)
466  CALL dwrph(ktom,phot)
467  DO 10 i=1,4
468  10 pp2(i)=pmu(i)
469 
470  ELSEIF(jak.EQ.2) THEN
471  CALL dwlumu(2,isgn,pnu,pwb,pmu,pnm)
472  CALL dwrph(ktom,phot)
473  DO 20 i=1,4
474  20 pp2(i)=pmu(i)
475 
476  ELSEIF(jak.EQ.3) THEN
477  CALL dwlupi(2,isgn,ppi,pnu)
478  DO 30 i=1,4
479  30 pp2(i)=ppi(i)
480 
481  ELSEIF(jak.EQ.4) THEN
482  CALL dwluro(2,isgn,pnu,prho,pic,piz)
483  DO 40 i=1,4
484  40 pp2(i)=prho(i)
485 
486  ELSEIF(jak.EQ.5) THEN
487  CALL dwluaa(2,isgn,pnu,paa,pim1,pim2,pipl,jaa)
488  DO 50 i=1,4
489  50 pp2(i)=paa(i)
490  ELSEIF(jak.EQ.6) THEN
491  CALL dwlukk(2,isgn,pkk,pnu)
492  DO 60 i=1,4
493  60 pp1(i)=pkk(i)
494  ELSEIF(jak.EQ.7) THEN
495  CALL dwluks(2,isgn,pnu,pks,pkk,ppi,jkst)
496  DO 70 i=1,4
497  70 pp1(i)=pks(i)
498  ELSE
499 CAM MULTIPION DECAY
500  CALL dwlnew(2,isgn,pnu,pwb,pnpi,jak)
501  DO 80 i=1,4
502  80 pp1(i)=pwb(i)
503  ENDIF
504 C
505  ENDIF
506 C =====
507  END
508  SUBROUTINE dexay(KTO,POL)
509 C ----------------------------------------------------------------------
510 C THIS 'DEXAY' IS A ROUTINE WHICH GENERATES DECAY OF THE SINGLE
511 C POLARIZED TAU, POL IS A POLARIZATION VECTOR (NOT A POLARIMETER
512 C VECTOR AS IN DEKAY) OF THE TAU AND IT IS AN INPUT PARAMETER.
513 C KTO=0 INITIALISATION (OBLIGATORY)
514 C KTO=1 DENOTES TAU+ AND KTO=2 TAU-
515 C DEXAY(1,POL) AND DEXAY(2,POL) ARE CALLED INTERNALLY BY MC GENERATOR.
516 C DECAY PRODUCTS ARE TRANSFORMED READILY
517 C TO CMS AND WRITEN IN THE LUND RECORD IN /LUJETS/
518 C KTO=100, PRINT FINAL REPORT (OPTIONAL).
519 C
520 C called by : KORALZ
521 C ----------------------------------------------------------------------
522  COMMON / taubmc / gampmc(30),gamper(30),nevdec(30)
523  REAL*4 GAMPMC ,GAMPER
524  COMMON / jaki / jak1,jak2,jakp,jakm,ktom
525  COMMON / idfc / idff
526  COMMON /taupos/ np1,np2
527  parameter(nmode=15,nm1=0,nm2=1,nm3=8,nm4=2,nm5=1,nm6=3)
528 #if defined (ALEPH)
529  COMMON / taudcd /idffin(9,nmode),mulpik(nmode)
530 #else
531  COMMON / taudcd /idffin(9,nmode),mulpik(nmode)
532 #endif
533  & ,names
534  CHARACTER NAMES(NMODE)*31
535  COMMON / inout / inut,iout
536  REAL POL(4)
537  REAL PDUM1(4),PDUM2(4),PDUM3(4),PDUM4(4),PDUM5(4)
538  REAL PDUM(4)
539  REAL PDUMI(4,9)
540  DATA iwarm/0/
541  ktom=kto
542 C
543  IF(kto.EQ.-1) THEN
544 C ==================
545 
546 C INITIALISATION OR REINITIALISATION
547 C first or second tau positions in HEPEVT as in KORALB/Z
548  np1=3
549  np2=4
550  iwarm=1
551  WRITE(iout, 7001) jak1,jak2
552  nevtot=0
553  nev1=0
554  nev2=0
555  IF(jak1.NE.-1.OR.jak2.NE.-1) THEN
556  CALL dexel(-1,idum,pdum,pdum1,pdum2,pdum3,pdum4,pdum5)
557  CALL dexmu(-1,idum,pdum,pdum1,pdum2,pdum3,pdum4,pdum5)
558  CALL dexpi(-1,idum,pdum,pdum1,pdum2)
559  CALL dexro(-1,idum,pdum,pdum1,pdum2,pdum3,pdum4)
560  CALL dexaa(-1,idum,pdum,pdum1,pdum2,pdum3,pdum4,pdum5,idum)
561  CALL dexkk(-1,idum,pdum,pdum1,pdum2)
562  CALL dexks(-1,idum,pdum,pdum1,pdum2,pdum3,pdum4,idum)
563  CALL dexnew(-1,idum,pdum,pdum1,pdum2,pdumi,idum)
564  ENDIF
565  DO 21 i=1,30
566  nevdec(i)=0
567  gampmc(i)=0
568  21 gamper(i)=0
569  ELSEIF(kto.EQ.1) THEN
570 C =====================
571 C DECAY OF TAU+ IN THE TAU REST FRAME
572  nevtot=nevtot+1
573  nev1=nev1+1
574  IF(iwarm.EQ.0) GOTO 902
575  isgn=idff/iabs(idff)
576 CAM CALL DEXAY1(POL,ISGN)
577  CALL dexay1(kto,jak1,jakp,pol,isgn)
578  ELSEIF(kto.EQ.2) THEN
579 C =================================
580 C DECAY OF TAU- IN THE TAU REST FRAME
581  nevtot=nevtot+1
582  nev2=nev2+1
583  IF(iwarm.EQ.0) GOTO 902
584  isgn=-idff/iabs(idff)
585 CAM CALL DEXAY2(POL,ISGN)
586  CALL dexay1(kto,jak2,jakm,pol,isgn)
587  ELSEIF(kto.EQ.100) THEN
588 C =======================
589  IF(jak1.NE.-1.OR.jak2.NE.-1) THEN
590  CALL dexel( 1,idum,pdum,pdum1,pdum2,pdum3,pdum4,pdum5)
591  CALL dexmu( 1,idum,pdum,pdum1,pdum2,pdum3,pdum4,pdum5)
592  CALL dexpi( 1,idum,pdum,pdum1,pdum2)
593  CALL dexro( 1,idum,pdum,pdum1,pdum2,pdum3,pdum4)
594  CALL dexaa( 1,idum,pdum,pdum1,pdum2,pdum3,pdum4,pdum5,idum)
595  CALL dexkk( 1,idum,pdum,pdum1,pdum2)
596  CALL dexks( 1,idum,pdum,pdum1,pdum2,pdum3,pdum4,idum)
597  CALL dexnew( 1,idum,pdum,pdum1,pdum2,pdumi,idum)
598  WRITE(iout,7010) nev1,nev2,nevtot
599  WRITE(iout,7011) (nevdec(i),gampmc(i),gamper(i),i= 1,7)
600  WRITE(iout,7012)
601  $ (nevdec(i),gampmc(i),gamper(i),names(i-7),i=8,7+nmode)
602  WRITE(iout,7013)
603  ENDIF
604  ELSE
605  GOTO 910
606  ENDIF
607  RETURN
608  7001 FORMAT(///1x,15(5h*****)
609 #if defined (ALEPH)
610  $ /,' *', 25x,'*****TAUOLA LIBRARY: VERSION 2.7 ******',9x,1h*,
611  $ /,' *', 25x,'*DEC 1993; ALEPH fixes introd. dec 98 *',9x,1h*,
612  $ /,' *', 25x,'**AUTHORS: S.JADACH, Z.WAS*************',9x,1h*,
613  $ /,' *', 25x,'**R. DECKER, M. JEZABEK, J.H.KUEHN*****',9x,1h*,
614  $ /,' *', 25x,'Physics initialization by ALEPH collab ',9x,1h*,
615  $ /,' *', 25x,'it is suggested to use this version ',9x,1h*,
616  $ /,' *', 25x,' with the help of the collab. advice ',9x,1h*,
617  $ /,' *', 25x,'**AVAILABLE FROM: WASM AT CERNVM ******',9x,1h*,
618  $ /,' *', 25x,'***** PUBLISHED IN COMP. PHYS. COMM.***',9x,1h*,
619 #elif defined (CLEO)
620  $ /,' *', 25x,'*****TAUOLA LIBRARY: VERSION 2.7 ******',9x,1h*,
621  $ /,' *', 25x,'***********August 1995***************',9x,1h*,
622  $ /,' *', 25x,'**AUTHORS: S.JADACH, Z.WAS*************',9x,1h*,
623  $ /,' *', 25x,'**R. DECKER, M. JEZABEK, J.H.KUEHN*****',9x,1h*,
624  $ /,' *', 25x,'**AVAILABLE FROM: WASM AT CERNVM ******',9x,1h*,
625  $ /,' *', 25x,'***** PUBLISHED IN COMP. PHYS. COMM.***',9x,1h*,
626  $ /,' *', 25x,' Physics initialization by CLEO collab ',9x,1h*,
627  $ /,' *', 25x,' see Alain Weinstein www home page: ',9x,1h*,
628  $ /,' *', 25x,'http://www.cithep.caltech.edu/~ajw/ ',9x,1h*,
629  $ /,' *', 25x,'/korb_doc.html#files ',9x,1h*,
630  $ /,' *', 25x,'*******CERN TH-6793 NOVEMBER 1992*****',9x,1h*,
631  $ /,' *', 25x,'**5 or more pi dec.: precision limited ',9x,1h*,
632 #else
633  $ /,' *', 25x,'*****TAUOLA LIBRARY: VERSION 2.7 ******',9x,1h*,
634  $ /,' *', 25x,'***********August 1995***************',9x,1h*,
635  $ /,' *', 25x,'**AUTHORS: S.JADACH, Z.WAS*************',9x,1h*,
636  $ /,' *', 25x,'**R. DECKER, M. JEZABEK, J.H.KUEHN*****',9x,1h*,
637  $ /,' *', 25x,'**AVAILABLE FROM: WASM AT CERNVM ******',9x,1h*,
638  $ /,' *', 25x,'***** PUBLISHED IN COMP. PHYS. COMM.***',9x,1h*,
639  $ /,' *', 25x,'*******CERN-TH-5856 SEPTEMBER 1990*****',9x,1h*,
640  $ /,' *', 25x,'*******CERN-TH-6195 SEPTEMBER 1991*****',9x,1h*,
641 #endif
642  $ /,' *', 25x,'*******CERN-TH-6793 NOVEMBER 1992*****',9x,1h*,
643  $ /,' *', 25x,'**5 or more pi dec.: precision limited ',9x,1h*,
644  $ /,' *', 25x,'******DEXAY ROUTINE: INITIALIZATION****',9x,1h*
645  $ /,' *',i20 ,5x,'JAK1 = DECAY MODE FERMION1 (TAU+) ',9x,1h*
646  $ /,' *',i20 ,5x,'JAK2 = DECAY MODE FERMION2 (TAU-) ',9x,1h*
647  $ /,1x,15(5h*****)/)
648 CHBU format 7010 had more than 19 continuation lines
649 CHBU split into two
650  7010 FORMAT(///1x,15(5h*****)
651 #if defined (ALEPH)
652  $ /,' *', 25x,'*****TAUOLA LIBRARY: VERSION 2.7 ******',9x,1h*,
653  $ /,' *', 25x,'***********DECEMBER 1993***************',9x,1h*,
654 #else
655  $ /,' *', 25x,'*****TAUOLA LIBRARY: VERSION 2.7 ******',9x,1h*,
656  $ /,' *', 25x,'***********August 1995***************',9x,1h*,
657 #endif
658  $ /,' *', 25x,'**AUTHORS: S.JADACH, Z.WAS*************',9x,1h*,
659  $ /,' *', 25x,'**R. DECKER, M. JEZABEK, J.H.KUEHN*****',9x,1h*,
660  $ /,' *', 25x,'**AVAILABLE FROM: WASM AT CERNVM ******',9x,1h*,
661  $ /,' *', 25x,'***** PUBLISHED IN COMP. PHYS. COMM.***',9x,1h*,
662  $ /,' *', 25x,'*******CERN-TH-5856 SEPTEMBER 1990*****',9x,1h*,
663  $ /,' *', 25x,'*******CERN-TH-6195 SEPTEMBER 1991*****',9x,1h*,
664  $ /,' *', 25x,'*******CERN-TH-6793 NOVEMBER 1992*****',9x,1h*,
665  $ /,' *', 25x,'******DEXAY ROUTINE: FINAL REPORT******',9x,1h*
666  $ /,' *',i20 ,5x,'NEV1 = NO. OF TAU+ DECS. ACCEPTED ',9x,1h*
667  $ /,' *',i20 ,5x,'NEV2 = NO. OF TAU- DECS. ACCEPTED ',9x,1h*
668  $ /,' *',i20 ,5x,'NEVTOT = SUM ',9x,1h*
669  $ /,' *',' NOEVTS ',
670  $ ' PART.WIDTH ERROR ROUTINE DECAY MODE ',9x,1h*)
671  7011 FORMAT(1x,'*'
672  $ ,i10,2f12.7 ,' DADMEL ELECTRON ',9x,1h*
673  $ /,' *',i10,2f12.7 ,' DADMMU MUON ',9x,1h*
674  $ /,' *',i10,2f12.7 ,' DADMPI PION ',9x,1h*
675  $ /,' *',i10,2f12.7, ' DADMRO RHO (->2PI) ',9x,1h*
676  $ /,' *',i10,2f12.7, ' DADMAA A1 (->3PI) ',9x,1h*
677  $ /,' *',i10,2f12.7, ' DADMKK KAON ',9x,1h*
678  $ /,' *',i10,2f12.7, ' DADMKS K* ',9x,1h*)
679  7012 FORMAT(1x,'*'
680  $ ,i10,2f12.7,a31 ,8x,1h*)
681  7013 FORMAT(1x,'*'
682  $ ,20x,'THE ERROR IS RELATIVE AND PART.WIDTH ',10x,1h*
683  $ /,' *',20x,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',10x,1h*
684  $ /,1x,15(5h*****)/)
685  902 WRITE(iout, 9020)
686  9020 FORMAT(' ----- DEXAY: LACK OF INITIALISATION')
687  stop
688  910 WRITE(iout, 9100)
689  9100 FORMAT(' ----- DEXAY: WRONG VALUE OF KTO ')
690  stop
691  END
692  SUBROUTINE dexay1(KTO,JAKIN,JAK,POL,ISGN)
693 C ---------------------------------------------------------------------
694 C THIS ROUTINE SIMULATES TAU+- DECAY
695 C
696 C called by : DEXAY
697 C ---------------------------------------------------------------------
698  COMMON / taubmc / gampmc(30),gamper(30),nevdec(30)
699  REAL*4 GAMPMC ,GAMPER
700  COMMON / inout / inut,iout
701  REAL POL(4),POLAR(4)
702  REAL PNU(4),PPI(4)
703  REAL PRHO(4),PIC(4),PIZ(4)
704  REAL PWB(4),PMU(4),PNM(4)
705  REAL PAA(4),PIM1(4),PIM2(4),PIPL(4)
706  REAL PKK(4),PKS(4)
707  REAL PNPI(4,9)
708  REAL PHOT(4)
709  REAL PDUM(4)
710 C
711  IF(jakin.EQ.-1) RETURN
712  DO 33 i=1,3
713  33 polar(i)=pol(i)
714  polar(4)=0.
715  DO 34 i=1,4
716  34 pdum(i)=.0
717  jak=jakin
718  IF(jak.EQ.0) CALL jaker(jak)
719 CAM
720  IF(jak.EQ.1) THEN
721  CALL dexel(0, isgn,polar,pnu,pwb,pmu,pnm,phot)
722  CALL dwluel(kto,isgn,pnu,pwb,pmu,pnm)
723  CALL dwrph(kto,phot )
724  ELSEIF(jak.EQ.2) THEN
725  CALL dexmu(0, isgn,polar,pnu,pwb,pmu,pnm,phot)
726  CALL dwlumu(kto,isgn,pnu,pwb,pmu,pnm)
727  CALL dwrph(kto,phot )
728  ELSEIF(jak.EQ.3) THEN
729  CALL dexpi(0, isgn,polar,ppi,pnu)
730  CALL dwlupi(kto,isgn,ppi,pnu)
731  ELSEIF(jak.EQ.4) THEN
732  CALL dexro(0, isgn,polar,pnu,prho,pic,piz)
733  CALL dwluro(kto,isgn,pnu,prho,pic,piz)
734  ELSEIF(jak.EQ.5) THEN
735  CALL dexaa(0, isgn,polar,pnu,paa,pim1,pim2,pipl,jaa)
736  CALL dwluaa(kto,isgn,pnu,paa,pim1,pim2,pipl,jaa)
737  ELSEIF(jak.EQ.6) THEN
738  CALL dexkk(0, isgn,polar,pkk,pnu)
739  CALL dwlukk(kto,isgn,pkk,pnu)
740  ELSEIF(jak.EQ.7) THEN
741  CALL dexks(0, isgn,polar,pnu,pks,pkk,ppi,jkst)
742  CALL dwluks(kto,isgn,pnu,pks,pkk,ppi,jkst)
743  ELSE
744  jnpi=jak-7
745  CALL dexnew(0, isgn,polar,pnu,pwb,pnpi,jnpi)
746  CALL dwlnew(kto,isgn,pnu,pwb,pnpi,jak)
747  ENDIF
748  nevdec(jak)=nevdec(jak)+1
749  END
750  SUBROUTINE dexel(MODE,ISGN,POL,PNU,PWB,Q1,Q2,PH)
751 C ----------------------------------------------------------------------
752 C THIS SIMULATES TAU DECAY IN TAU REST FRAME
753 C INTO ELECTRON AND TWO NEUTRINOS
754 C
755 C called by : DEXAY,DEXAY1
756 C ----------------------------------------------------------------------
757  REAL POL(4),HV(4),PWB(4),PNU(4),Q1(4),Q2(4),PH(4),RN(1)
758  DATA iwarm/0/
759 C
760  IF(mode.EQ.-1) THEN
761 C ===================
762  iwarm=1
763  CALL dadmel( -1,isgn,hv,pnu,pwb,q1,q2,ph)
764 CC CALL HBOOK1(813,'WEIGHT DISTRIBUTION DEXEL $',100,0,2)
765 C
766  ELSEIF(mode.EQ. 0) THEN
767 C =======================
768 300 CONTINUE
769  IF(iwarm.EQ.0) GOTO 902
770  CALL dadmel( 0,isgn,hv,pnu,pwb,q1,q2,ph)
771  wt=(1+pol(1)*hv(1)+pol(2)*hv(2)+pol(3)*hv(3))/2.
772 CC CALL HFILL(813,WT)
773  CALL ranmar(rn,1)
774  IF(rn(1).GT.wt) GOTO 300
775 C
776  ELSEIF(mode.EQ. 1) THEN
777 C =======================
778  CALL dadmel( 1,isgn,hv,pnu,pwb,q1,q2,ph)
779 CC CALL HPRINT(813)
780  ENDIF
781 C =====
782  RETURN
783  902 print 9020
784  9020 FORMAT(' ----- DEXEL: LACK OF INITIALISATION')
785  stop
786  END
787  SUBROUTINE dexmu(MODE,ISGN,POL,PNU,PWB,Q1,Q2,PH)
788 C ----------------------------------------------------------------------
789 C THIS SIMULATES TAU DECAY IN ITS REST FRAME
790 C INTO MUON AND TWO NEUTRINOS
791 C OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
792 C PWB W-BOSON
793 C Q1 MUON
794 C Q2 MUON-NEUTRINO
795 C ----------------------------------------------------------------------
796  COMMON / inout / inut,iout
797  REAL POL(4),HV(4),PWB(4),PNU(4),Q1(4),Q2(4),PH(4),RN(1)
798  DATA iwarm/0/
799 C
800  IF(mode.EQ.-1) THEN
801 C ===================
802  iwarm=1
803  CALL dadmmu( -1,isgn,hv,pnu,pwb,q1,q2,ph)
804 CC CALL HBOOK1(814,'WEIGHT DISTRIBUTION DEXMU $',100,0,2)
805 C
806  ELSEIF(mode.EQ. 0) THEN
807 C =======================
808 300 CONTINUE
809  IF(iwarm.EQ.0) GOTO 902
810  CALL dadmmu( 0,isgn,hv,pnu,pwb,q1,q2,ph)
811  wt=(1+pol(1)*hv(1)+pol(2)*hv(2)+pol(3)*hv(3))/2.
812 CC CALL HFILL(814,WT)
813  CALL ranmar(rn,1)
814  IF(rn(1).GT.wt) GOTO 300
815 C
816  ELSEIF(mode.EQ. 1) THEN
817 C =======================
818  CALL dadmmu( 1,isgn,hv,pnu,pwb,q1,q2,ph)
819 CC CALL HPRINT(814)
820  ENDIF
821 C =====
822  RETURN
823  902 WRITE(iout, 9020)
824  9020 FORMAT(' ----- DEXMU: LACK OF INITIALISATION')
825  stop
826  END
827  SUBROUTINE dadmel(MODE,ISGN,HHV,PNU,PWB,Q1,Q2,PHX)
828 C ----------------------------------------------------------------------
829 C
830 C called by : DEXEL,(DEKAY,DEKAY1)
831 C ----------------------------------------------------------------------
832  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
833  REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
834  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
835  * ,ampiz,ampi,amro,gamro,ama1,gama1
836  * ,amk,amkz,amkst,gamkst
837 C
838  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
839  * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
840  * ,AMK,AMKZ,AMKST,GAMKST
841  COMMON / taubmc / gampmc(30),gamper(30),nevdec(30)
842  REAL*4 GAMPMC ,GAMPER
843 #if defined (ALEPH)
844 #else
845  REAL*4 PHX(4)
846 #endif
847  COMMON / inout / inut,iout
848 #if defined (ALEPH)
849  REAL*4 PHX(4)
850 #else
851 #endif
852  REAL HHV(4),HV(4),PWB(4),PNU(4),Q1(4),Q2(4)
853  REAL PDUM1(4),PDUM2(4),PDUM3(4),PDUM4(4),PDUM5(4)
854  REAL*4 RRR(3)
855  REAL*8 SWT, SSWT
856  DATA pi /3.141592653589793238462643/
857  DATA iwarm/0/
858 C
859  IF(mode.EQ.-1) THEN
860 C ===================
861  iwarm=1
862  nevraw=0
863  nevacc=0
864  nevovr=0
865  swt=0
866  sswt=0
867  wtmax=1e-20
868  DO 15 i=1,500
869  CALL dphsel(wt,hv,pdum1,pdum2,pdum3,pdum4,pdum5)
870  IF(wt.GT.wtmax/1.2) wtmax=wt*1.2
871 15 CONTINUE
872 CC CALL HBOOK1(803,'WEIGHT DISTRIBUTION DADMEL $',100,0,2)
873 C
874  ELSEIF(mode.EQ. 0) THEN
875 C =======================
876 300 CONTINUE
877  IF(iwarm.EQ.0) GOTO 902
878  nevraw=nevraw+1
879  CALL dphsel(wt,hv,pnu,pwb,q1,q2,phx)
880 CC CALL HFILL(803,WT/WTMAX)
881  swt=swt+wt
882  sswt=sswt+wt**2
883  CALL ranmar(rrr,3)
884  rn=rrr(1)
885  IF(wt.GT.wtmax) nevovr=nevovr+1
886  IF(rn*wtmax.GT.wt) GOTO 300
887 C ROTATIONS TO BASIC TAU REST FRAME
888  rr2=rrr(2)
889  costhe=-1.+2.*rr2
890  thet=acos(costhe)
891  rr3=rrr(3)
892  phi =2*pi*rr3
893  CALL rotor2(thet,pnu,pnu)
894  CALL rotor3( phi,pnu,pnu)
895  CALL rotor2(thet,pwb,pwb)
896  CALL rotor3( phi,pwb,pwb)
897  CALL rotor2(thet,q1,q1)
898  CALL rotor3( phi,q1,q1)
899  CALL rotor2(thet,q2,q2)
900  CALL rotor3( phi,q2,q2)
901  CALL rotor2(thet,hv,hv)
902  CALL rotor3( phi,hv,hv)
903  CALL rotor2(thet,phx,phx)
904  CALL rotor3( phi,phx,phx)
905  DO 44,i=1,3
906  44 hhv(i)=-isgn*hv(i)
907  nevacc=nevacc+1
908 C
909  ELSEIF(mode.EQ. 1) THEN
910 C =======================
911  IF(nevraw.EQ.0) RETURN
912  pargam=swt/float(nevraw+1)
913  error=0
914  IF(nevraw.NE.0) error=sqrt(sswt/swt**2-1./float(nevraw))
915  rat=pargam/gamel
916  WRITE(iout, 7010) nevraw,nevacc,nevovr,pargam,rat,error
917 CC CALL HPRINT(803)
918  gampmc(1)=rat
919  gamper(1)=error
920 CAM NEVDEC(1)=NEVACC
921  ENDIF
922 C =====
923  RETURN
924  7010 FORMAT(///1x,15(5h*****)
925  $ /,' *', 25x,'******** DADMEL FINAL REPORT ******** ',9x,1h*
926  $ /,' *',i20 ,5x,'NEVRAW = NO. OF EL DECAYS TOTAL ',9x,1h*
927  $ /,' *',i20 ,5x,'NEVACC = NO. OF EL DECS. ACCEPTED ',9x,1h*
928  $ /,' *',i20 ,5x,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9x,1h*
929  $ /,' *',e20.5,5x,'PARTIAL WTDTH ( ELECTRON) IN GEV UNITS ',9x,1h*
930  $ /,' *',f20.9,5x,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',9x,1h*
931  $ /,' *',f20.9,5x,'RELATIVE ERROR OF PARTIAL WIDTH ',9x,1h*
932  $ /,' *',25x, 'COMPLETE QED CORRECTIONS INCLUDED ',9x,1h*
933  $ /,' *',25x, 'BUT ONLY V-A CUPLINGS ',9x,1h*
934  $ /,1x,15(5h*****)/)
935  902 WRITE(iout, 9020)
936  9020 FORMAT(' ----- DADMEL: LACK OF INITIALISATION')
937  stop
938  END
939  SUBROUTINE dadmmu(MODE,ISGN,HHV,PNU,PWB,Q1,Q2,PHX)
940 C ----------------------------------------------------------------------
941  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
942  * ,ampiz,ampi,amro,gamro,ama1,gama1
943  * ,amk,amkz,amkst,gamkst
944 C
945  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
946  * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
947  * ,AMK,AMKZ,AMKST,GAMKST
948  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
949  REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
950  COMMON / taubmc / gampmc(30),gamper(30),nevdec(30)
951  REAL*4 GAMPMC ,GAMPER
952  COMMON / inout / inut,iout
953  REAL*4 PHX(4)
954  REAL HHV(4),HV(4),PNU(4),PWB(4),Q1(4),Q2(4)
955  REAL PDUM1(4),PDUM2(4),PDUM3(4),PDUM4(4),PDUM5(4)
956  REAL*4 RRR(3)
957  REAL*8 SWT, SSWT
958  DATA pi /3.141592653589793238462643/
959  DATA iwarm /0/
960 C
961  IF(mode.EQ.-1) THEN
962 C ===================
963  iwarm=1
964  nevraw=0
965  nevacc=0
966  nevovr=0
967  swt=0
968  sswt=0
969  wtmax=1e-20
970  DO 15 i=1,500
971  CALL dphsmu(wt,hv,pdum1,pdum2,pdum3,pdum4,pdum5)
972  IF(wt.GT.wtmax/1.2) wtmax=wt*1.2
973 15 CONTINUE
974 CC CALL HBOOK1(802,'WEIGHT DISTRIBUTION DADMMU $',100,0,2)
975 C
976  ELSEIF(mode.EQ. 0) THEN
977 C =======================
978 300 CONTINUE
979  IF(iwarm.EQ.0) GOTO 902
980  nevraw=nevraw+1
981  CALL dphsmu(wt,hv,pnu,pwb,q1,q2,phx)
982 CC CALL HFILL(802,WT/WTMAX)
983  swt=swt+wt
984  sswt=sswt+wt**2
985  CALL ranmar(rrr,3)
986  rn=rrr(1)
987  IF(wt.GT.wtmax) nevovr=nevovr+1
988  IF(rn*wtmax.GT.wt) GOTO 300
989 C ROTATIONS TO BASIC TAU REST FRAME
990  costhe=-1.+2.*rrr(2)
991  thet=acos(costhe)
992  phi =2*pi*rrr(3)
993  CALL rotor2(thet,pnu,pnu)
994  CALL rotor3( phi,pnu,pnu)
995  CALL rotor2(thet,pwb,pwb)
996  CALL rotor3( phi,pwb,pwb)
997  CALL rotor2(thet,q1,q1)
998  CALL rotor3( phi,q1,q1)
999  CALL rotor2(thet,q2,q2)
1000  CALL rotor3( phi,q2,q2)
1001  CALL rotor2(thet,hv,hv)
1002  CALL rotor3( phi,hv,hv)
1003  CALL rotor2(thet,phx,phx)
1004  CALL rotor3( phi,phx,phx)
1005  DO 44,i=1,3
1006  44 hhv(i)=-isgn*hv(i)
1007  nevacc=nevacc+1
1008 C
1009  ELSEIF(mode.EQ. 1) THEN
1010 C =======================
1011  IF(nevraw.EQ.0) RETURN
1012  pargam=swt/float(nevraw+1)
1013  error=0
1014  IF(nevraw.NE.0) error=sqrt(sswt/swt**2-1./float(nevraw))
1015  rat=pargam/gamel
1016  WRITE(iout, 7010) nevraw,nevacc,nevovr,pargam,rat,error
1017 CC CALL HPRINT(802)
1018  gampmc(2)=rat
1019  gamper(2)=error
1020 CAM NEVDEC(2)=NEVACC
1021  ENDIF
1022 C =====
1023  RETURN
1024  7010 FORMAT(///1x,15(5h*****)
1025  $ /,' *', 25x,'******** DADMMU FINAL REPORT ******** ',9x,1h*
1026  $ /,' *',i20 ,5x,'NEVRAW = NO. OF MU DECAYS TOTAL ',9x,1h*
1027  $ /,' *',i20 ,5x,'NEVACC = NO. OF MU DECS. ACCEPTED ',9x,1h*
1028  $ /,' *',i20 ,5x,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9x,1h*
1029  $ /,' *',e20.5,5x,'PARTIAL WTDTH (MU DECAY) IN GEV UNITS ',9x,1h*
1030  $ /,' *',f20.9,5x,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',9x,1h*
1031  $ /,' *',f20.9,5x,'RELATIVE ERROR OF PARTIAL WIDTH ',9x,1h*
1032  $ /,' *',25x, 'COMPLETE QED CORRECTIONS INCLUDED ',9x,1h*
1033  $ /,' *',25x, 'BUT ONLY V-A CUPLINGS ',9x,1h*
1034  $ /,1x,15(5h*****)/)
1035  902 WRITE(iout, 9020)
1036  9020 FORMAT(' ----- DADMMU: LACK OF INITIALISATION')
1037  stop
1038  END
1039  SUBROUTINE dphsel(DGAMX,HVX,XNX,PAAX,QPX,XAX,PHX)
1040 C XNX,XNA was flipped in parameters of dphsel and dphsmu
1041 C *********************************************************************
1042 C * ELECTRON DECAY MODE *
1043 C *********************************************************************
1044  REAL*4 PHX(4)
1045  REAL*4 HVX(4),PAAX(4),XAX(4),QPX(4),XNX(4)
1046  REAL*8 HV(4),PH(4),PAA(4),XA(4),QP(4),XN(4)
1047  REAL*8 DGAMT
1048  ielmu=1
1049  CALL drcmu(dgamt,hv,ph,paa,xa,qp,xn,ielmu)
1050  DO 7 k=1,4
1051  hvx(k)=hv(k)
1052  phx(k)=ph(k)
1053  paax(k)=paa(k)
1054  xax(k)=xa(k)
1055  qpx(k)=qp(k)
1056  xnx(k)=xn(k)
1057  7 CONTINUE
1058  dgamx=dgamt
1059  END
1060  SUBROUTINE dphsmu(DGAMX,HVX,XNX,PAAX,QPX,XAX,PHX)
1061 C XNX,XNA was flipped in parameters of dphsel and dphsmu
1062 C *********************************************************************
1063 C * MUON DECAY MODE *
1064 C *********************************************************************
1065  REAL*4 PHX(4)
1066  REAL*4 HVX(4),PAAX(4),XAX(4),QPX(4),XNX(4)
1067  REAL*8 HV(4),PH(4),PAA(4),XA(4),QP(4),XN(4)
1068  REAL*8 DGAMT
1069  ielmu=2
1070  CALL drcmu(dgamt,hv,ph,paa,xa,qp,xn,ielmu)
1071  DO 7 k=1,4
1072  hvx(k)=hv(k)
1073  phx(k)=ph(k)
1074  paax(k)=paa(k)
1075  xax(k)=xa(k)
1076  qpx(k)=qp(k)
1077  xnx(k)=xn(k)
1078  7 CONTINUE
1079  dgamx=dgamt
1080  END
1081  SUBROUTINE drcmu(DGAMT,HV,PH,PAA,XA,QP,XN,IELMU)
1082  IMPLICIT REAL*8 (a-h,o-z)
1083 C ----------------------------------------------------------------------
1084 * IT SIMULATES E,MU CHANNELS OF TAU DECAY IN ITS REST FRAME WITH
1085 * QED ORDER ALPHA CORRECTIONS
1086 C ----------------------------------------------------------------------
1087  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
1088  * ,ampiz,ampi,amro,gamro,ama1,gama1
1089  * ,amk,amkz,amkst,gamkst
1090 C
1091  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
1092  * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
1093  * ,AMK,AMKZ,AMKST,GAMKST
1094  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
1095  REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
1096 #if defined (ALEPH)
1097  COMMON / taubmc / gampmc(30),gamper(30),nevdec(30)
1098  REAL*4 GAMPMC ,GAMPER
1099 #endif
1100  COMMON / inout / inut,iout
1101  COMMON / taurad / xk0dec,itdkrc
1102  REAL*8 XK0DEC
1103  REAL*8 HV(4),PT(4),PH(4),PAA(4),XA(4),QP(4),XN(4)
1104  REAL*8 PR(4)
1105  REAL*4 RRR(6)
1106  LOGICAL IHARD
1107  DATA pi /3.141592653589793238462643d0/
1108 #if defined (CLEO)
1109 C AJWMOD to satisfy compiler, comment out this unused function.
1110 #else
1111  xlam(x,y,z)=sqrt((x-y-z)**2-4.0*y*z)
1112 #endif
1113 C AMRO, GAMRO IS ONLY A PARAMETER FOR GETING HIGHT EFFICIENCY
1114 C
1115 C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
1116 C D**3 P /2E/(2PI)**3 (2PI)**4 DELTA4(SUM P)
1117  phspac=1./2**17/pi**8
1118  amtax=amtau
1119 C TAU MOMENTUM
1120  pt(1)=0.d0
1121  pt(2)=0.d0
1122  pt(3)=0.d0
1123  pt(4)=amtax
1124 C
1125  CALL ranmar(rrr,6)
1126 C
1127  IF (ielmu.EQ.1) THEN
1128  amu=amel
1129  ELSE
1130  amu=ammu
1131  ENDIF
1132 C
1133  prhard=0.30d0
1134  IF ( itdkrc.EQ.0) prhard=0d0
1135  prsoft=1.-prhard
1136  IF(prsoft.LT.0.1) THEN
1137  print *, 'ERROR IN DRCMU; PRSOFT=',prsoft
1138  stop
1139  ENDIF
1140 C
1141  rr5=rrr(5)
1142  ihard=(rr5.GT.prsoft)
1143  IF (ihard) THEN
1144 C TAU DECAY TO 'TAU+photon'
1145  rr1=rrr(1)
1146  ams1=(amu+amnuta)**2
1147  ams2=(amtax)**2
1148  xk1=1-ams1/ams2
1149  xl1=log(xk1/2/xk0dec)
1150  xl0=log(2*xk0dec)
1151  xk=exp(xl1*rr1+xl0)
1152  am3sq=(1-xk)*ams2
1153  am3 =sqrt(am3sq)
1154  phspac=phspac*ams2*xl1*xk
1155  phspac=phspac/prhard
1156  ELSE
1157  am3=amtax
1158  phspac=phspac*2**6*pi**3
1159  phspac=phspac/prsoft
1160  ENDIF
1161 C MASS OF NEUTRINA SYSTEM
1162  rr2=rrr(2)
1163  ams1=(amnuta)**2
1164  ams2=(am3-amu)**2
1165 CAM
1166 CAM
1167 * FLAT PHASE SPACE;
1168  am2sq=ams1+ rr2*(ams2-ams1)
1169  am2 =sqrt(am2sq)
1170  phspac=phspac*(ams2-ams1)
1171 * NEUTRINA REST FRAME, DEFINE XN AND XA
1172  enq1=(am2sq+amnuta**2)/(2*am2)
1173  enq2=(am2sq-amnuta**2)/(2*am2)
1174  ppi= enq1**2-amnuta**2
1175  pppi=sqrt(abs(enq1**2-amnuta**2))
1176  phspac=phspac*(4*pi)*(2*pppi/am2)
1177 * NU TAU IN NUNU REST FRAME
1178  CALL spherd(pppi,xn)
1179  xn(4)=enq1
1180 * NU LIGHT IN NUNU REST FRAME
1181  DO 30 i=1,3
1182  30 xa(i)=-xn(i)
1183  xa(4)=enq2
1184 * TAU-prim REST FRAME, DEFINE QP (muon
1185 * NUNU MOMENTUM
1186  pr(1)=0
1187  pr(2)=0
1188  pr(4)=1.d0/(2*am3)*(am3**2+am2**2-amu**2)
1189  pr(3)= sqrt(abs(pr(4)**2-am2**2))
1190  ppi = pr(4)**2-am2**2
1191 * MUON MOMENTUM
1192  qp(1)=0
1193  qp(2)=0
1194  qp(4)=1.d0/(2*am3)*(am3**2-am2**2+amu**2)
1195  qp(3)=-pr(3)
1196  phspac=phspac*(4*pi)*(2*pr(3)/am3)
1197 * NEUTRINA BOOSTED FROM THEIR FRAME TO TAU-prim REST FRAME
1198  exe=(pr(4)+pr(3))/am2
1199  CALL bostd3(exe,xn,xn)
1200  CALL bostd3(exe,xa,xa)
1201  rr3=rrr(3)
1202  rr4=rrr(4)
1203  IF (ihard) THEN
1204  eps=4*(amu/amtax)**2
1205  xl1=log((2+eps)/eps)
1206  xl0=log(eps)
1207  eta =exp(xl1*rr3+xl0)
1208  cthet=1+eps-eta
1209  thet =acos(cthet)
1210  phspac=phspac*xl1/2*eta
1211  phi = 2*pi*rr4
1212  CALL rotpox(thet,phi,xn)
1213  CALL rotpox(thet,phi,xa)
1214  CALL rotpox(thet,phi,qp)
1215  CALL rotpox(thet,phi,pr)
1216 C
1217 * NOW TO THE TAU REST FRAME, DEFINE TAU-prim AND GAMMA MOMENTA
1218 * tau-prim MOMENTUM
1219  paa(1)=0
1220  paa(2)=0
1221  paa(4)=1/(2*amtax)*(amtax**2+am3**2)
1222  paa(3)= sqrt(abs(paa(4)**2-am3**2))
1223  ppi = paa(4)**2-am3**2
1224  phspac=phspac*(4*pi)*(2*paa(3)/amtax)
1225 * GAMMA MOMENTUM
1226  ph(1)=0
1227  ph(2)=0
1228  ph(4)=paa(3)
1229  ph(3)=-paa(3)
1230 * ALL MOMENTA BOOSTED FROM TAU-prim REST FRAME TO TAU REST FRAME
1231 * Z-AXIS ANTIPARALLEL TO PHOTON MOMENTUM
1232  exe=(paa(4)+paa(3))/am3
1233  CALL bostd3(exe,xn,xn)
1234  CALL bostd3(exe,xa,xa)
1235  CALL bostd3(exe,qp,qp)
1236  CALL bostd3(exe,pr,pr)
1237  ELSE
1238  thet =acos(-1.+2*rr3)
1239  phi = 2*pi*rr4
1240  CALL rotpox(thet,phi,xn)
1241  CALL rotpox(thet,phi,xa)
1242  CALL rotpox(thet,phi,qp)
1243  CALL rotpox(thet,phi,pr)
1244 C
1245 * NOW TO THE TAU REST FRAME, DEFINE TAU-prim AND GAMMA MOMENTA
1246 * tau-prim MOMENTUM
1247  paa(1)=0
1248  paa(2)=0
1249  paa(4)=amtax
1250  paa(3)=0
1251 * GAMMA MOMENTUM
1252  ph(1)=0
1253  ph(2)=0
1254  ph(4)=0
1255  ph(3)=0
1256  ENDIF
1257 C PARTIAL WIDTH CONSISTS OF PHASE SPACE AND AMPLITUDE
1258  CALL dampry(itdkrc,xk0dec,ph,xa,qp,xn,amplit,hv)
1259  dgamt=1/(2.*amtax)*amplit*phspac
1260  END
1261  SUBROUTINE dampry(ITDKRC,XK0DEC,XK,XA,QP,XN,AMPLIT,HV)
1262  IMPLICIT REAL*8 (a-h,o-z)
1263 C ----------------------------------------------------------------------
1264 C IT CALCULATES MATRIX ELEMENT FOR THE
1265 C TAU --> MU(E) NU NUBAR DECAY MODE
1266 C INCLUDING COMPLETE ORDER ALPHA QED CORRECTIONS.
1267 C ----------------------------------------------------------------------
1268  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
1269  * ,ampiz,ampi,amro,gamro,ama1,gama1
1270  * ,amk,amkz,amkst,gamkst
1271 C
1272  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
1273  * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
1274  * ,AMK,AMKZ,AMKST,GAMKST
1275  REAL*8 HV(4),QP(4),XN(4),XA(4),XK(4)
1276 C
1277  hv(4)=1.d0
1278  ak0=xk0dec*amtau
1279  IF(xk(4).LT.0.1d0*ak0) THEN
1280  amplit=thb(itdkrc,qp,xn,xa,ak0,hv)
1281  ELSE
1282  amplit=sqm2(itdkrc,qp,xn,xa,xk,ak0,hv)
1283  ENDIF
1284  RETURN
1285  END
1286  FUNCTION sqm2(ITDKRC,QP,XN,XA,XK,AK0,HV)
1287 C
1288 C **********************************************************************
1289 C REAL PHOTON MATRIX ELEMENT SQUARED *
1290 C PARAMETERS: *
1291 C HV- POLARIMETRIC FOUR-VECTOR OF TAU *
1292 C QP,XN,XA,XK - 4-momenta of electron (muon), NU, NUBAR and PHOTON *
1293 C All four-vectors in TAU rest frame (in GeV) *
1294 C AK0 - INFRARED CUTOFF, MINIMAL ENERGY OF HARD PHOTONS (GEV) *
1295 C SQM2 - value for S=0 *
1296 C see Eqs. (2.9)-(2.10) from CJK ( Nucl.Phys.B(1991) ) *
1297 C **********************************************************************
1298 C
1299  IMPLICIT REAL*8(a-h,o-z)
1300  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
1301  * ,ampiz,ampi,amro,gamro,ama1,gama1
1302  * ,amk,amkz,amkst,gamkst
1303 C
1304  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
1305  * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
1306  * ,AMK,AMKZ,AMKST,GAMKST
1307  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
1308  REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
1309  COMMON / qedprm /alfinv,alfpi,xk0
1310  REAL*8 ALFINV,ALFPI,XK0
1311  REAL*8 QP(4),XN(4),XA(4),XK(4)
1312  REAL*8 R(4)
1313  REAL*8 HV(4)
1314  REAL*8 S0(3),RXA(3),RXK(3),RQP(3)
1315  DATA pi /3.141592653589793238462643d0/
1316 C
1317  tmass=amtau
1318  gf=gfermi
1319  alphai=alfinv
1320  tmass2=tmass**2
1321  emass2=qp(4)**2-qp(1)**2-qp(2)**2-qp(3)**2
1322  r(4)=tmass
1323 C SCALAR PRODUCTS OF FOUR-MOMENTA
1324  DO 7 i=1,3
1325  r(1)=0.d0
1326  r(2)=0.d0
1327  r(3)=0.d0
1328  r(i)=tmass
1329  rxa(i)=r(4)*xa(4)-r(1)*xa(1)-r(2)*xa(2)-r(3)*xa(3)
1330 C RXN(I)=R(4)*XN(4)-R(1)*XN(1)-R(2)*XN(2)-R(3)*XN(3)
1331  rxk(i)=r(4)*xk(4)-r(1)*xk(1)-r(2)*xk(2)-r(3)*xk(3)
1332  rqp(i)=r(4)*qp(4)-r(1)*qp(1)-r(2)*qp(2)-r(3)*qp(3)
1333  7 CONTINUE
1334  qpxn=qp(4)*xn(4)-qp(1)*xn(1)-qp(2)*xn(2)-qp(3)*xn(3)
1335  qpxa=qp(4)*xa(4)-qp(1)*xa(1)-qp(2)*xa(2)-qp(3)*xa(3)
1336  qpxk=qp(4)*xk(4)-qp(1)*xk(1)-qp(2)*xk(2)-qp(3)*xk(3)
1337 c XNXA=XN(4)*XA(4)-XN(1)*XA(1)-XN(2)*XA(2)-XN(3)*XA(3)
1338  xnxk=xn(4)*xk(4)-xn(1)*xk(1)-xn(2)*xk(2)-xn(3)*xk(3)
1339  xaxk=xa(4)*xk(4)-xa(1)*xk(1)-xa(2)*xk(2)-xa(3)*xk(3)
1340  txn=tmass*xn(4)
1341  txa=tmass*xa(4)
1342  tqp=tmass*qp(4)
1343  txk=tmass*xk(4)
1344 C
1345  x= xnxk/qpxn
1346  z= txk/tqp
1347  a= 1+x
1348  b= 1+ x*(1+z)/2+z/2
1349  s1= qpxn*txa*( -emass2/qpxk**2*a + 2*tqp/(qpxk*txk)*b-
1350  $tmass2/txk**2) +
1351  $qpxn/txk**2* ( tmass2*xaxk - txa*txk+ xaxk*txk) -
1352  $txa*txn/txk - qpxn/(qpxk*txk)* (tqp*xaxk-txk*qpxa)
1353  const4=256*pi/alphai*gf**2
1354  IF (itdkrc.EQ.0) const4=0d0
1355  sqm2=s1*const4
1356  DO 5 i=1,3
1357  s0(i) = qpxn*rxa(i)*(-emass2/qpxk**2*a + 2*tqp/(qpxk*txk)*b-
1358  $ tmass2/txk**2) +
1359  $ qpxn/txk**2* (tmass2*xaxk - txa*rxk(i)+ xaxk*rxk(i))-
1360  $ rxa(i)*txn/txk - qpxn/(qpxk*txk)*(rqp(i)*xaxk- rxk(i)*qpxa)
1361  5 hv(i)=s0(i)/s1-1.d0
1362  RETURN
1363  END
1364  FUNCTION thb(ITDKRC,QP,XN,XA,AK0,HV)
1365 C
1366 C **********************************************************************
1367 C BORN +VIRTUAL+SOFT PHOTON MATRIX ELEMENT**2 O(ALPHA) *
1368 C PARAMETERS: *
1369 C HV- POLARIMETRIC FOUR-VECTOR OF TAU *
1370 C QP,XN,XA - FOUR-MOMENTA OF ELECTRON (MUON), NU AND NUBAR IN GEV *
1371 C ALL FOUR-VECTORS IN TAU REST FRAME *
1372 C AK0 - INFRARED CUTOFF, MINIMAL ENERGY OF HARD PHOTONS *
1373 C THB - VALUE FOR S=0 *
1374 C SEE EQS. (2.2),(2.4)-(2.5) FROM CJK (NUCL.PHYS.B351(1991)70 *
1375 C AND (C.2) FROM JK (NUCL.PHYS.B320(1991)20 ) *
1376 C **********************************************************************
1377 C
1378  IMPLICIT REAL*8(a-h,o-z)
1379  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
1380  * ,ampiz,ampi,amro,gamro,ama1,gama1
1381  * ,amk,amkz,amkst,gamkst
1382 C
1383  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
1384  * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
1385  * ,AMK,AMKZ,AMKST,GAMKST
1386  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
1387  REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
1388  COMMON / qedprm /alfinv,alfpi,xk0
1389  REAL*8 ALFINV,ALFPI,XK0
1390  dimension qp(4),xn(4),xa(4)
1391  REAL*8 HV(4)
1392  dimension r(4)
1393  REAL*8 RXA(3),RXN(3),RQP(3)
1394  REAL*8 BORNPL(3),AM3POL(3),XM3POL(3)
1395  DATA pi /3.141592653589793238462643d0/
1396 C
1397  tmass=amtau
1398  gf=gfermi
1399  alphai=alfinv
1400 C
1401  tmass2=tmass**2
1402  r(4)=tmass
1403  DO 7 i=1,3
1404  r(1)=0.d0
1405  r(2)=0.d0
1406  r(3)=0.d0
1407  r(i)=tmass
1408  rxa(i)=r(4)*xa(4)-r(1)*xa(1)-r(2)*xa(2)-r(3)*xa(3)
1409  rxn(i)=r(4)*xn(4)-r(1)*xn(1)-r(2)*xn(2)-r(3)*xn(3)
1410 C RXK(I)=R(4)*XK(4)-R(1)*XK(1)-R(2)*XK(2)-R(3)*XK(3)
1411  rqp(i)=r(4)*qp(4)-r(1)*qp(1)-r(2)*qp(2)-r(3)*qp(3)
1412  7 CONTINUE
1413 C QUASI TWO-BODY VARIABLES
1414  u0=qp(4)/tmass
1415  u3=sqrt(qp(1)**2+qp(2)**2+qp(3)**2)/tmass
1416  w3=u3
1417  w0=(xn(4)+xa(4))/tmass
1418  up=u0+u3
1419  um=u0-u3
1420  wp=w0+w3
1421  wm=w0-w3
1422  yu=log(up/um)/2
1423  yw=log(wp/wm)/2
1424  eps2=u0**2-u3**2
1425  eps=sqrt(eps2)
1426  y=w0**2-w3**2
1427  al=ak0/tmass
1428 C FORMFACTORS
1429  f0=2*u0/u3*( dilogt(1-(um*wm/(up*wp)))- dilogt(1-wm/wp) +
1430  $dilogt(1-um/up) -2*yu+ 2*log(up)*(yw+yu) ) +
1431  $1/y* ( 2*u3*yu + (1-eps2- 2*y)*log(eps) ) +
1432  $ 2 - 4*(u0/u3*yu -1)* log(2*al)
1433  fp= yu/(2*u3)*(1 + (1-eps2)/y ) + log(eps)/y
1434  fm= yu/(2*u3)*(1 - (1-eps2)/y ) - log(eps)/y
1435  f3= eps2*(fp+fm)/2
1436 C SCALAR PRODUCTS OF FOUR-MOMENTA
1437  qpxn=qp(4)*xn(4)-qp(1)*xn(1)-qp(2)*xn(2)-qp(3)*xn(3)
1438  qpxa=qp(4)*xa(4)-qp(1)*xa(1)-qp(2)*xa(2)-qp(3)*xa(3)
1439  xnxa=xn(4)*xa(4)-xn(1)*xa(1)-xn(2)*xa(2)-xn(3)*xa(3)
1440  txn=tmass*xn(4)
1441  txa=tmass*xa(4)
1442  tqp=tmass*qp(4)
1443 C DECAY DIFFERENTIAL WIDTH WITHOUT AND WITH POLARIZATION
1444  const3=1/(2*alphai*pi)*64*gf**2
1445  IF (itdkrc.EQ.0) const3=0d0
1446  xm3= -( f0* qpxn*txa + fp*eps2* txn*txa +
1447  $fm* qpxn*qpxa + f3* tmass2*xnxa )
1448  am3=xm3*const3
1449 C V-A AND V+A COUPLINGS, BUT IN THE BORN PART ONLY
1450  brak= (gv+ga)**2*tqp*xnxa+(gv-ga)**2*txa*qpxn
1451  & -(gv**2-ga**2)*tmass*amnuta*qpxa
1452  born= 32*(gfermi**2/2.)*brak
1453  DO 5 i=1,3
1454  xm3pol(i)= -( f0* qpxn*rxa(i) + fp*eps2* txn*rxa(i) +
1455  $ fm* qpxn* (qpxa + (rxa(i)*tqp-txa*rqp(i))/tmass2 ) +
1456  $ f3* (tmass2*xnxa +txn*rxa(i) -rxn(i)*txa) )
1457  am3pol(i)=xm3pol(i)*const3
1458 C V-A AND V+A COUPLINGS, BUT IN THE BORN PART ONLY
1459  bornpl(i)=born+(
1460  & (gv+ga)**2*tmass*xnxa*qp(i)
1461  & -(gv-ga)**2*tmass*qpxn*xa(i)
1462  & +(gv**2-ga**2)*amnuta*txa*qp(i)
1463  & -(gv**2-ga**2)*amnuta*tqp*xa(i) )*
1464  & 32*(gfermi**2/2.)
1465  5 hv(i)=(bornpl(i)+am3pol(i))/(born+am3)-1.d0
1466  thb=born+am3
1467  IF (thb/born.LT.0.1d0) THEN
1468  print *, 'ERROR IN THB, THB/BORN=',thb/born
1469 #if defined (CLEO)
1470  thb=0.d0
1471 #else
1472  stop
1473 #endif
1474  ENDIF
1475  RETURN
1476  END
1477  SUBROUTINE dexpi(MODE,ISGN,POL,PPI,PNU)
1478 C ----------------------------------------------------------------------
1479 C TAU DECAY INTO PION AND TAU-NEUTRINO
1480 C IN TAU REST FRAME
1481 C OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
1482 C PPI PION CHARGED
1483 C ----------------------------------------------------------------------
1484  REAL POL(4),HV(4),PNU(4),PPI(4),RN(1)
1485 CC
1486  IF(mode.EQ.-1) THEN
1487 C ===================
1488  CALL dadmpi(-1,isgn,hv,ppi,pnu)
1489 CC CALL HBOOK1(815,'WEIGHT DISTRIBUTION DEXPI $',100,0,2)
1490 
1491  ELSEIF(mode.EQ. 0) THEN
1492 C =======================
1493 300 CONTINUE
1494  CALL dadmpi( 0,isgn,hv,ppi,pnu)
1495  wt=(1+pol(1)*hv(1)+pol(2)*hv(2)+pol(3)*hv(3))/2.
1496 CC CALL HFILL(815,WT)
1497  CALL ranmar(rn,1)
1498  IF(rn(1).GT.wt) GOTO 300
1499 C
1500  ELSEIF(mode.EQ. 1) THEN
1501 C =======================
1502  CALL dadmpi( 1,isgn,hv,ppi,pnu)
1503 CC CALL HPRINT(815)
1504  ENDIF
1505 C =====
1506  RETURN
1507  END
1508  SUBROUTINE dadmpi(MODE,ISGN,HV,PPI,PNU)
1509 C ----------------------------------------------------------------------
1510  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
1511  * ,ampiz,ampi,amro,gamro,ama1,gama1
1512  * ,amk,amkz,amkst,gamkst
1513 C
1514  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
1515  * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
1516  * ,AMK,AMKZ,AMKST,GAMKST
1517  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
1518  REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
1519  COMMON / taubmc / gampmc(30),gamper(30),nevdec(30)
1520  REAL*4 GAMPMC ,GAMPER
1521  COMMON / inout / inut,iout
1522  REAL PPI(4),PNU(4),HV(4)
1523  DATA pi /3.141592653589793238462643/
1524 C
1525  IF(mode.EQ.-1) THEN
1526 C ===================
1527  nevtot=0
1528  ELSEIF(mode.EQ. 0) THEN
1529 C =======================
1530  nevtot=nevtot+1
1531  epi= (amtau**2+ampi**2-amnuta**2)/(2*amtau)
1532  enu= (amtau**2-ampi**2+amnuta**2)/(2*amtau)
1533  xpi= sqrt(epi**2-ampi**2)
1534 C PI MOMENTUM
1535  CALL sphera(xpi,ppi)
1536  ppi(4)=epi
1537 C TAU-NEUTRINO MOMENTUM
1538  DO 30 i=1,3
1539 30 pnu(i)=-ppi(i)
1540  pnu(4)=enu
1541  pxq=amtau*epi
1542  pxn=amtau*enu
1543  qxn=ppi(4)*pnu(4)-ppi(1)*pnu(1)-ppi(2)*pnu(2)-ppi(3)*pnu(3)
1544  brak=(gv**2+ga**2)*(2*pxq*qxn-ampi**2*pxn)
1545  & +(gv**2-ga**2)*amtau*amnuta*ampi**2
1546  DO 40 i=1,3
1547 40 hv(i)=-isgn*2*ga*gv*amtau*(2*ppi(i)*qxn-pnu(i)*ampi**2)/brak
1548  hv(4)=1
1549 C
1550  ELSEIF(mode.EQ. 1) THEN
1551 C =======================
1552  IF(nevtot.EQ.0) RETURN
1553  fpi=0.1284
1554 C GAMM=(GFERMI*FPI)**2/(16.*PI)*AMTAU**3*
1555 C * (BRAK/AMTAU**4)**2
1556 CZW 7.02.93 here was an error affecting non standard model
1557 C configurations only
1558  gamm=(gfermi*fpi)**2/(16.*pi)*amtau**3*
1559  $ (brak/amtau**4)*
1560  $ sqrt((amtau**2-ampi**2-amnuta**2)**2
1561  $ -4*ampi**2*amnuta**2 )/amtau**2
1562  error=0
1563  rat=gamm/gamel
1564  WRITE(iout, 7010) nevtot,gamm,rat,error
1565  gampmc(3)=rat
1566  gamper(3)=error
1567 CAM NEVDEC(3)=NEVTOT
1568  ENDIF
1569 C =====
1570  RETURN
1571  7010 FORMAT(///1x,15(5h*****)
1572  $ /,' *', 25x,'******** DADMPI FINAL REPORT ******** ',9x,1h*
1573  $ /,' *',i20 ,5x,'NEVTOT = NO. OF PI DECAYS TOTAL ',9x,1h*
1574  $ /,' *',e20.5,5x,'PARTIAL WTDTH ( PI DECAY) IN GEV UNITS ',9x,1h*
1575  $ /,' *',f20.9,5x,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',9x,1h*
1576  $ /,' *',f20.8,5x,'RELATIVE ERROR OF PARTIAL WIDTH (STAT.)',9x,1h*
1577  $ /,1x,15(5h*****)/)
1578  END
1579  SUBROUTINE dexro(MODE,ISGN,POL,PNU,PRO,PIC,PIZ)
1580 C ----------------------------------------------------------------------
1581 C THIS SIMULATES TAU DECAY IN TAU REST FRAME
1582 C INTO NU RHO, NEXT RHO DECAYS INTO PION PAIR.
1583 C OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
1584 C PRO RHO
1585 C PIC PION CHARGED
1586 C PIZ PION ZERO
1587 C ----------------------------------------------------------------------
1588  COMMON / inout / inut,iout
1589  REAL POL(4),HV(4),PRO(4),PNU(4),PIC(4),PIZ(4),RN(1)
1590  DATA iwarm/0/
1591 C
1592  IF(mode.EQ.-1) THEN
1593 C ===================
1594  iwarm=1
1595  CALL dadmro( -1,isgn,hv,pnu,pro,pic,piz)
1596 CC CALL HBOOK1(816,'WEIGHT DISTRIBUTION DEXRO $',100,0,2)
1597 CC CALL HBOOK1(916,'ABS2 OF HV IN ROUTINE DEXRO $',100,0,2)
1598 C
1599  ELSEIF(mode.EQ. 0) THEN
1600 C =======================
1601 300 CONTINUE
1602  IF(iwarm.EQ.0) GOTO 902
1603  CALL dadmro( 0,isgn,hv,pnu,pro,pic,piz)
1604  wt=(1+pol(1)*hv(1)+pol(2)*hv(2)+pol(3)*hv(3))/2.
1605 CC CALL HFILL(816,WT)
1606 CC XHELP=HV(1)**2+HV(2)**2+HV(3)**2
1607 CC CALL HFILL(916,XHELP)
1608  CALL ranmar(rn,1)
1609  IF(rn(1).GT.wt) GOTO 300
1610 C
1611  ELSEIF(mode.EQ. 1) THEN
1612 C =======================
1613  CALL dadmro( 1,isgn,hv,pnu,pro,pic,piz)
1614 CC CALL HPRINT(816)
1615 CC CALL HPRINT(916)
1616  ENDIF
1617 C =====
1618  RETURN
1619  902 WRITE(iout, 9020)
1620  9020 FORMAT(' ----- DEXRO: LACK OF INITIALISATION')
1621  stop
1622  END
1623  SUBROUTINE dadmro(MODE,ISGN,HHV,PNU,PRO,PIC,PIZ)
1624 C ----------------------------------------------------------------------
1625  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
1626  * ,ampiz,ampi,amro,gamro,ama1,gama1
1627  * ,amk,amkz,amkst,gamkst
1628 C
1629  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
1630  * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
1631  * ,AMK,AMKZ,AMKST,GAMKST
1632  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
1633  REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
1634  COMMON / taubmc / gampmc(30),gamper(30),nevdec(30)
1635  REAL*4 GAMPMC ,GAMPER
1636  COMMON / inout / inut,iout
1637  REAL HHV(4)
1638  REAL HV(4),PRO(4),PNU(4),PIC(4),PIZ(4)
1639  REAL PDUM1(4),PDUM2(4),PDUM3(4),PDUM4(4)
1640  REAL*4 RRR(3)
1641  REAL*8 SWT, SSWT
1642  DATA pi /3.141592653589793238462643/
1643  DATA iwarm/0/
1644 C
1645  IF(mode.EQ.-1) THEN
1646 C ===================
1647  iwarm=1
1648  nevraw=0
1649  nevacc=0
1650  nevovr=0
1651  swt=0
1652  sswt=0
1653  wtmax=1e-20
1654  DO 15 i=1,500
1655  CALL dphsro(wt,hv,pdum1,pdum2,pdum3,pdum4)
1656  IF(wt.GT.wtmax/1.2) wtmax=wt*1.2
1657 15 CONTINUE
1658 CC CALL HBOOK1(801,'WEIGHT DISTRIBUTION DADMRO $',100,0,2)
1659 CC PRINT 7003,WTMAX
1660 C
1661  ELSEIF(mode.EQ. 0) THEN
1662 C =======================
1663 300 CONTINUE
1664  IF(iwarm.EQ.0) GOTO 902
1665  CALL dphsro(wt,hv,pnu,pro,pic,piz)
1666 CC CALL HFILL(801,WT/WTMAX)
1667  nevraw=nevraw+1
1668  swt=swt+wt
1669  sswt=sswt+wt**2
1670  CALL ranmar(rrr,3)
1671  rn=rrr(1)
1672  IF(wt.GT.wtmax) nevovr=nevovr+1
1673  IF(rn*wtmax.GT.wt) GOTO 300
1674 C ROTATIONS TO BASIC TAU REST FRAME
1675  costhe=-1.+2.*rrr(2)
1676  thet=acos(costhe)
1677  phi =2*pi*rrr(3)
1678  CALL rotor2(thet,pnu,pnu)
1679  CALL rotor3( phi,pnu,pnu)
1680  CALL rotor2(thet,pro,pro)
1681  CALL rotor3( phi,pro,pro)
1682  CALL rotor2(thet,pic,pic)
1683  CALL rotor3( phi,pic,pic)
1684  CALL rotor2(thet,piz,piz)
1685  CALL rotor3( phi,piz,piz)
1686  CALL rotor2(thet,hv,hv)
1687  CALL rotor3( phi,hv,hv)
1688  DO 44 i=1,3
1689  44 hhv(i)=-isgn*hv(i)
1690  nevacc=nevacc+1
1691 C
1692  ELSEIF(mode.EQ. 1) THEN
1693 C =======================
1694  IF(nevraw.EQ.0) RETURN
1695  pargam=swt/float(nevraw+1)
1696  error=0
1697  IF(nevraw.NE.0) error=sqrt(sswt/swt**2-1./float(nevraw))
1698  rat=pargam/gamel
1699  WRITE(iout, 7010) nevraw,nevacc,nevovr,pargam,rat,error
1700 CC CALL HPRINT(801)
1701  gampmc(4)=rat
1702  gamper(4)=error
1703 CAM NEVDEC(4)=NEVACC
1704  ENDIF
1705 C =====
1706  RETURN
1707  7003 FORMAT(///1x,15(5h*****)
1708  $ /,' *', 25x,'******** DADMRO INITIALISATION ********',9x,1h*
1709  $ /,' *',e20.5,5x,'WTMAX = MAXIMUM WEIGHT ',9x,1h*
1710  $ /,1x,15(5h*****)/)
1711  7010 FORMAT(///1x,15(5h*****)
1712  $ /,' *', 25x,'******** DADMRO FINAL REPORT ******** ',9x,1h*
1713  $ /,' *',i20 ,5x,'NEVRAW = NO. OF RHO DECAYS TOTAL ',9x,1h*
1714  $ /,' *',i20 ,5x,'NEVACC = NO. OF RHO DECS. ACCEPTED ',9x,1h*
1715  $ /,' *',i20 ,5x,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9x,1h*
1716  $ /,' *',e20.5,5x,'PARTIAL WTDTH (RHO DECAY) IN GEV UNITS ',9x,1h*
1717  $ /,' *',f20.9,5x,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',9x,1h*
1718  $ /,' *',f20.8,5x,'RELATIVE ERROR OF PARTIAL WIDTH ',9x,1h*
1719  $ /,1x,15(5h*****)/)
1720  902 WRITE(iout, 9020)
1721  9020 FORMAT(' ----- DADMRO: LACK OF INITIALISATION')
1722  stop
1723  END
1724  SUBROUTINE dphsro(DGAMT,HV,PN,PR,PIC,PIZ)
1725 C ----------------------------------------------------------------------
1726 C IT SIMULATES RHO DECAY IN TAU REST FRAME WITH
1727 C Z-AXIS ALONG RHO MOMENTUM
1728 C ----------------------------------------------------------------------
1729  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
1730  * ,ampiz,ampi,amro,gamro,ama1,gama1
1731  * ,amk,amkz,amkst,gamkst
1732 C
1733  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
1734  * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
1735  * ,AMK,AMKZ,AMKST,GAMKST
1736  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
1737  REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
1738  REAL HV(4),PT(4),PN(4),PR(4),PIC(4),PIZ(4),QQ(4),RR1(1)
1739  DATA pi /3.141592653589793238462643/
1740  DATA icont /0/
1741 C
1742 C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
1743  phspac=1./2**11/pi**5
1744 C TAU MOMENTUM
1745  pt(1)=0.
1746  pt(2)=0.
1747  pt(3)=0.
1748  pt(4)=amtau
1749 C MASS OF (REAL/VIRTUAL) RHO
1750  ams1=(ampi+ampiz)**2
1751  ams2=(amtau-amnuta)**2
1752 C FLAT PHASE SPACE
1753 #if defined (ALEPH)
1754 C AMX2=AMS1+ RR1(1)*(AMS2-AMS1)
1755 #else
1756 C AMX2=AMS1+ RR1*(AMS2-AMS1)
1757 #endif
1758 C AMX=SQRT(AMX2)
1759 C PHSPAC=PHSPAC*(AMS2-AMS1)
1760 C PHASE SPACE WITH SAMPLING FOR RHO RESONANCE
1761  alp1=atan((ams1-amro**2)/amro/gamro)
1762  alp2=atan((ams2-amro**2)/amro/gamro)
1763 CAM
1764  100 CONTINUE
1765  CALL ranmar(rr1,1)
1766  alp=alp1+rr1(1)*(alp2-alp1)
1767  amx2=amro**2+amro*gamro*tan(alp)
1768  amx=sqrt(amx2)
1769  IF(amx.LT.2.*ampi) GO TO 100
1770 CAM
1771  phspac=phspac*((amx2-amro**2)**2+(amro*gamro)**2)/(amro*gamro)
1772  phspac=phspac*(alp2-alp1)
1773 C
1774 C TAU-NEUTRINO MOMENTUM
1775  pn(1)=0
1776  pn(2)=0
1777  pn(4)=1./(2*amtau)*(amtau**2+amnuta**2-amx**2)
1778  pn(3)=-sqrt((pn(4)-amnuta)*(pn(4)+amnuta))
1779 C RHO MOMENTUM
1780  pr(1)=0
1781  pr(2)=0
1782  pr(4)=1./(2*amtau)*(amtau**2-amnuta**2+amx**2)
1783  pr(3)=-pn(3)
1784  phspac=phspac*(4*pi)*(2*pr(3)/amtau)
1785 C
1786 CAM
1787  enq1=(amx2+ampi**2-ampiz**2)/(2.*amx)
1788  enq2=(amx2-ampi**2+ampiz**2)/(2.*amx)
1789  pppi=sqrt((enq1-ampi)*(enq1+ampi))
1790  phspac=phspac*(4*pi)*(2*pppi/amx)
1791 C CHARGED PI MOMENTUM IN RHO REST FRAME
1792  CALL sphera(pppi,pic)
1793  pic(4)=enq1
1794 C NEUTRAL PI MOMENTUM IN RHO REST FRAME
1795  DO 20 i=1,3
1796 20 piz(i)=-pic(i)
1797  piz(4)=enq2
1798  exe=(pr(4)+pr(3))/amx
1799 C PIONS BOOSTED FROM RHO REST FRAME TO TAU REST FRAME
1800  CALL bostr3(exe,pic,pic)
1801  CALL bostr3(exe,piz,piz)
1802  DO 30 i=1,4
1803 30 qq(i)=pic(i)-piz(i)
1804 C AMPLITUDE
1805  prodpq=pt(4)*qq(4)
1806  prodnq=pn(4)*qq(4)-pn(1)*qq(1)-pn(2)*qq(2)-pn(3)*qq(3)
1807  prodpn=pt(4)*pn(4)
1808  qq2= qq(4)**2-qq(1)**2-qq(2)**2-qq(3)**2
1809  brak=(gv**2+ga**2)*(2*prodpq*prodnq-prodpn*qq2)
1810  & +(gv**2-ga**2)*amtau*amnuta*qq2
1811  amplit=(gfermi*ccabib)**2*brak*2*fpirho(amx)
1812  dgamt=1/(2.*amtau)*amplit*phspac
1813  DO 40 i=1,3
1814  40 hv(i)=2*gv*ga*amtau*(2*prodnq*qq(i)-qq2*pn(i))/brak
1815  RETURN
1816  END
1817  SUBROUTINE dexaa(MODE,ISGN,POL,PNU,PAA,PIM1,PIM2,PIPL,JAA)
1818 C ----------------------------------------------------------------------
1819 * THIS SIMULATES TAU DECAY IN TAU REST FRAME
1820 * INTO NU A1, NEXT A1 DECAYS INTO RHO PI AND FINALLY RHO INTO PI PI.
1821 * OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
1822 * PAA A1
1823 * PIM1 PION MINUS (OR PI0) 1 (FOR TAU MINUS)
1824 * PIM2 PION MINUS (OR PI0) 2
1825 * PIPL PION PLUS (OR PI-)
1826 * (PIPL,PIM1) FORM A RHO
1827 C ----------------------------------------------------------------------
1828  COMMON / inout / inut,iout
1829  REAL POL(4),HV(4),PAA(4),PNU(4),PIM1(4),PIM2(4),PIPL(4),RN(1)
1830  DATA iwarm/0/
1831 C
1832  IF(mode.EQ.-1) THEN
1833 C ===================
1834  iwarm=1
1835  CALL dadmaa( -1,isgn,hv,pnu,paa,pim1,pim2,pipl,jaa)
1836 CC CALL HBOOK1(816,'WEIGHT DISTRIBUTION DEXAA $',100,-2.,2.)
1837 C
1838  ELSEIF(mode.EQ. 0) THEN
1839 * =======================
1840  300 CONTINUE
1841  IF(iwarm.EQ.0) GOTO 902
1842  CALL dadmaa( 0,isgn,hv,pnu,paa,pim1,pim2,pipl,jaa)
1843  wt=(1+pol(1)*hv(1)+pol(2)*hv(2)+pol(3)*hv(3))/2.
1844 CC CALL HFILL(816,WT)
1845  CALL ranmar(rn,1)
1846  IF(rn(1).GT.wt) GOTO 300
1847 C
1848  ELSEIF(mode.EQ. 1) THEN
1849 * =======================
1850  CALL dadmaa( 1,isgn,hv,pnu,paa,pim1,pim2,pipl,jaa)
1851 CC CALL HPRINT(816)
1852  ENDIF
1853 C =====
1854  RETURN
1855  902 WRITE(iout, 9020)
1856  9020 FORMAT(' ----- DEXAA: LACK OF INITIALISATION')
1857  stop
1858  END
1859  SUBROUTINE dadmaa(MODE,ISGN,HHV,PNU,PAA,PIM1,PIM2,PIPL,JAA)
1860 C ----------------------------------------------------------------------
1861 * A1 DECAY UNWEIGHTED EVENTS
1862 C ----------------------------------------------------------------------
1863  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
1864  * ,ampiz,ampi,amro,gamro,ama1,gama1
1865  * ,amk,amkz,amkst,gamkst
1866 C
1867  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
1868  * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
1869  * ,AMK,AMKZ,AMKST,GAMKST
1870  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
1871  REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
1872  COMMON / taubmc / gampmc(30),gamper(30),nevdec(30)
1873  REAL*4 GAMPMC ,GAMPER
1874  COMMON / inout / inut,iout
1875  REAL HHV(4)
1876  REAL HV(4),PAA(4),PNU(4),PIM1(4),PIM2(4),PIPL(4)
1877  REAL PDUM1(4),PDUM2(4),PDUM3(4),PDUM4(4),PDUM5(4)
1878  REAL*4 RRR(3)
1879  REAL*8 SWT, SSWT
1880  DATA pi /3.141592653589793238462643/
1881  DATA iwarm/0/
1882 C
1883  IF(mode.EQ.-1) THEN
1884 C ===================
1885  iwarm=1
1886  nevraw=0
1887  nevacc=0
1888  nevovr=0
1889  swt=0
1890  sswt=0
1891  wtmax=1e-20
1892  DO 15 i=1,500
1893  CALL dphsaa(wt,hv,pdum1,pdum2,pdum3,pdum4,pdum5,jaa)
1894  IF(wt.GT.wtmax/1.2) wtmax=wt*1.2
1895 15 CONTINUE
1896 CC CALL HBOOK1(801,'WEIGHT DISTRIBUTION DADMAA $',100,0,2)
1897 C
1898  ELSEIF(mode.EQ. 0) THEN
1899 C =======================
1900 300 CONTINUE
1901  IF(iwarm.EQ.0) GOTO 902
1902  CALL dphsaa(wt,hv,pnu,paa,pim1,pim2,pipl,jaa)
1903 CC CALL HFILL(801,WT/WTMAX)
1904  nevraw=nevraw+1
1905  swt=swt+wt
1906 #if defined (ALEPH)
1907  sswt=sswt+wt**2
1908 #else
1909 ccM.S.>>>>>>
1910 cc SSWT=SSWT+WT**2
1911  sswt=sswt+dble(wt)**2
1912 ccM.S.<<<<<<
1913 #endif
1914  CALL ranmar(rrr,3)
1915  rn=rrr(1)
1916  IF(wt.GT.wtmax) nevovr=nevovr+1
1917  IF(rn*wtmax.GT.wt) GOTO 300
1918 C ROTATIONS TO BASIC TAU REST FRAME
1919  costhe=-1.+2.*rrr(2)
1920  thet=acos(costhe)
1921  phi =2*pi*rrr(3)
1922  CALL rotpol(thet,phi,pnu)
1923  CALL rotpol(thet,phi,paa)
1924  CALL rotpol(thet,phi,pim1)
1925  CALL rotpol(thet,phi,pim2)
1926  CALL rotpol(thet,phi,pipl)
1927  CALL rotpol(thet,phi,hv)
1928  DO 44 i=1,3
1929  44 hhv(i)=-isgn*hv(i)
1930  nevacc=nevacc+1
1931 C
1932  ELSEIF(mode.EQ. 1) THEN
1933 C =======================
1934  IF(nevraw.EQ.0) RETURN
1935  pargam=swt/float(nevraw+1)
1936  error=0
1937  IF(nevraw.NE.0) error=sqrt(sswt/swt**2-1./float(nevraw))
1938  rat=pargam/gamel
1939  WRITE(iout, 7010) nevraw,nevacc,nevovr,pargam,rat,error
1940 CC CALL HPRINT(801)
1941  gampmc(5)=rat
1942  gamper(5)=error
1943 CAM NEVDEC(5)=NEVACC
1944  ENDIF
1945 C =====
1946  RETURN
1947  7003 FORMAT(///1x,15(5h*****)
1948  $ /,' *', 25x,'******** DADMAA INITIALISATION ********',9x,1h*
1949  $ /,' *',e20.5,5x,'WTMAX = MAXIMUM WEIGHT ',9x,1h*
1950  $ /,1x,15(5h*****)/)
1951  7010 FORMAT(///1x,15(5h*****)
1952  $ /,' *', 25x,'******** DADMAA FINAL REPORT ******** ',9x,1h*
1953  $ /,' *',i20 ,5x,'NEVRAW = NO. OF A1 DECAYS TOTAL ',9x,1h*
1954  $ /,' *',i20 ,5x,'NEVACC = NO. OF A1 DECS. ACCEPTED ',9x,1h*
1955  $ /,' *',i20 ,5x,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9x,1h*
1956  $ /,' *',e20.5,5x,'PARTIAL WTDTH (A1 DECAY) IN GEV UNITS ',9x,1h*
1957  $ /,' *',f20.9,5x,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',9x,1h*
1958  $ /,' *',f20.8,5x,'RELATIVE ERROR OF PARTIAL WIDTH ',9x,1h*
1959  $ /,1x,15(5h*****)/)
1960  902 WRITE(iout, 9020)
1961  9020 FORMAT(' ----- DADMAA: LACK OF INITIALISATION')
1962  stop
1963  END
1964  SUBROUTINE dphsaa(DGAMT,HV,PN,PAA,PIM1,PIM2,PIPL,JAA)
1965 C ----------------------------------------------------------------------
1966 * IT SIMULATES A1 DECAY IN TAU REST FRAME WITH
1967 * Z-AXIS ALONG A1 MOMENTUM
1968 C ----------------------------------------------------------------------
1969  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
1970  * ,ampiz,ampi,amro,gamro,ama1,gama1
1971  * ,amk,amkz,amkst,gamkst
1972 C
1973  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
1974  * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
1975  * ,AMK,AMKZ,AMKST,GAMKST
1976  COMMON / taukle / bra1,brk0,brk0b,brks
1977  REAL*4 BRA1,BRK0,BRK0B,BRKS
1978  REAL HV(4),PN(4),PAA(4),PIM1(4),PIM2(4),PIPL(4)
1979 
1980 
1981  REAL*4 RRR(1)
1982 C MATRIX ELEMENT NUMBER:
1983  mnum=0
1984 C TYPE OF THE GENERATION:
1985  keyt=1
1986  CALL ranmar(rrr,1)
1987  rmod=rrr(1)
1988  IF (rmod.LT.bra1) THEN
1989  jaa=1
1990  amp1=ampi
1991  amp2=ampi
1992  amp3=ampi
1993  ELSE
1994  jaa=2
1995  amp1=ampiz
1996  amp2=ampiz
1997  amp3=ampi
1998  ENDIF
1999  call
2000  $ dphtre(dgamt,hv,pn,paa,pim1,amp1,pim2,amp2,pipl,amp3,keyt,mnum)
2001  END
2002  SUBROUTINE dexkk(MODE,ISGN,POL,PKK,PNU)
2003 C ----------------------------------------------------------------------
2004 C TAU DECAY INTO KAON AND TAU-NEUTRINO
2005 C IN TAU REST FRAME
2006 C OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
2007 C PKK KAON CHARGED
2008 C ----------------------------------------------------------------------
2009  REAL POL(4),HV(4),PNU(4),PKK(4),RN(1)
2010 C
2011  IF(mode.EQ.-1) THEN
2012 C ===================
2013  CALL dadmkk(-1,isgn,hv,pkk,pnu)
2014 CC CALL HBOOK1(815,'WEIGHT DISTRIBUTION DEXPI $',100,0,2)
2015 C
2016  ELSEIF(mode.EQ. 0) THEN
2017 C =======================
2018 300 CONTINUE
2019  CALL dadmkk( 0,isgn,hv,pkk,pnu)
2020  wt=(1+pol(1)*hv(1)+pol(2)*hv(2)+pol(3)*hv(3))/2.
2021 CC CALL HFILL(815,WT)
2022  CALL ranmar(rn,1)
2023  IF(rn(1).GT.wt) GOTO 300
2024 C
2025  ELSEIF(mode.EQ. 1) THEN
2026 C =======================
2027  CALL dadmkk( 1,isgn,hv,pkk,pnu)
2028 CC CALL HPRINT(815)
2029  ENDIF
2030 C =====
2031  RETURN
2032  END
2033  SUBROUTINE dadmkk(MODE,ISGN,HV,PKK,PNU)
2034 C ----------------------------------------------------------------------
2035 C FZ
2036 #if defined (ALEPH)
2037 #else
2038  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
2039  REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
2040 #endif
2041  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
2042  * ,ampiz,ampi,amro,gamro,ama1,gama1
2043  * ,amk,amkz,amkst,gamkst
2044 C
2045  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
2046  * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
2047  * ,AMK,AMKZ,AMKST,GAMKST
2048 #if defined (ALEPH)
2049  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
2050  REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
2051 #else
2052 #endif
2053  COMMON / taubmc / gampmc(30),gamper(30),nevdec(30)
2054  REAL*4 GAMPMC ,GAMPER
2055  COMMON / inout / inut,iout
2056  REAL PKK(4),PNU(4),HV(4)
2057  DATA pi /3.141592653589793238462643/
2058 C
2059  IF(mode.EQ.-1) THEN
2060 C ===================
2061  nevtot=0
2062  ELSEIF(mode.EQ. 0) THEN
2063 C =======================
2064  nevtot=nevtot+1
2065  ekk= (amtau**2+amk**2-amnuta**2)/(2*amtau)
2066  enu= (amtau**2-amk**2+amnuta**2)/(2*amtau)
2067  xkk= sqrt(ekk**2-amk**2)
2068 C K MOMENTUM
2069  CALL sphera(xkk,pkk)
2070  pkk(4)=ekk
2071 C TAU-NEUTRINO MOMENTUM
2072  DO 30 i=1,3
2073 30 pnu(i)=-pkk(i)
2074  pnu(4)=enu
2075  pxq=amtau*ekk
2076  pxn=amtau*enu
2077  qxn=pkk(4)*pnu(4)-pkk(1)*pnu(1)-pkk(2)*pnu(2)-pkk(3)*pnu(3)
2078  brak=(gv**2+ga**2)*(2*pxq*qxn-amk**2*pxn)
2079  & +(gv**2-ga**2)*amtau*amnuta*amk**2
2080  DO 40 i=1,3
2081 40 hv(i)=-isgn*2*ga*gv*amtau*(2*pkk(i)*qxn-pnu(i)*amk**2)/brak
2082  hv(4)=1
2083 C
2084  ELSEIF(mode.EQ. 1) THEN
2085 C =======================
2086  IF(nevtot.EQ.0) RETURN
2087  fkk=0.0354
2088 CFZ THERE WAS BRAK/AMTAU**4 BEFORE
2089 C GAMM=(GFERMI*FKK)**2/(16.*PI)*AMTAU**3*
2090 C * (BRAK/AMTAU**4)**2
2091 CZW 7.02.93 here was an error affecting non standard model
2092 C configurations only
2093  gamm=(gfermi*fkk)**2/(16.*pi)*amtau**3*
2094  $ (brak/amtau**4)*
2095  $ sqrt((amtau**2-amk**2-amnuta**2)**2
2096  $ -4*amk**2*amnuta**2 )/amtau**2
2097  error=0
2098 
2099  error=0
2100  rat=gamm/gamel
2101  WRITE(iout, 7010) nevtot,gamm,rat,error
2102  gampmc(6)=rat
2103  gamper(6)=error
2104 CAM NEVDEC(6)=NEVTOT
2105  ENDIF
2106 C =====
2107  RETURN
2108  7010 FORMAT(///1x,15(5h*****)
2109  $ /,' *', 25x,'******** DADMKK FINAL REPORT ********',9x,1h*
2110  $ /,' *',i20 ,5x,'NEVTOT = NO. OF K DECAYS TOTAL ',9x,1h*,
2111  $ /,' *',e20.5,5x,'PARTIAL WTDTH ( K DECAY) IN GEV UNITS ',9x,1h*,
2112  $ /,' *',f20.9,5x,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',9x,1h*
2113  $ /,' *',f20.8,5x,'RELATIVE ERROR OF PARTIAL WIDTH (STAT.)',9x,1h*
2114  $ /,1x,15(5h*****)/)
2115  END
2116  SUBROUTINE dexks(MODE,ISGN,POL,PNU,PKS,PKK,PPI,JKST)
2117 C ----------------------------------------------------------------------
2118 C THIS SIMULATES TAU DECAY IN TAU REST FRAME
2119 C INTO NU K*, THEN K* DECAYS INTO PI0,K+-(JKST=20)
2120 C OR PI+-,K0(JKST=10).
2121 C OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
2122 C PKS K* CHARGED
2123 C PK0 K ZERO
2124 C PKC K CHARGED
2125 C PIC PION CHARGED
2126 C PIZ PION ZERO
2127 C ----------------------------------------------------------------------
2128  COMMON / inout / inut,iout
2129  REAL POL(4),HV(4),PKS(4),PNU(4),PKK(4),PPI(4),RN(1)
2130  DATA iwarm/0/
2131 C
2132  IF(mode.EQ.-1) THEN
2133 C ===================
2134  iwarm=1
2135 CFZ INITIALISATION DONE WITH THE GHARGED PION NEUTRAL KAON MODE(JKST=10
2136  CALL dadmks( -1,isgn,hv,pnu,pks,pkk,ppi,jkst)
2137 CC CALL HBOOK1(816,'WEIGHT DISTRIBUTION DEXKS $',100,0,2)
2138 CC CALL HBOOK1(916,'ABS2 OF HV IN ROUTINE DEXKS $',100,0,2)
2139 C
2140  ELSEIF(mode.EQ. 0) THEN
2141 C =======================
2142 300 CONTINUE
2143  IF(iwarm.EQ.0) GOTO 902
2144  CALL dadmks( 0,isgn,hv,pnu,pks,pkk,ppi,jkst)
2145  wt=(1+pol(1)*hv(1)+pol(2)*hv(2)+pol(3)*hv(3))/2.
2146 CC CALL HFILL(816,WT)
2147 CC XHELP=HV(1)**2+HV(2)**2+HV(3)**2
2148 CC CALL HFILL(916,XHELP)
2149  CALL ranmar(rn,1)
2150  IF(rn(1).GT.wt) GOTO 300
2151 C
2152  ELSEIF(mode.EQ. 1) THEN
2153 C ======================================
2154  CALL dadmks( 1,isgn,hv,pnu,pks,pkk,ppi,jkst)
2155 CC CALL HPRINT(816)
2156 CC CALL HPRINT(916)
2157  ENDIF
2158 C =====
2159  RETURN
2160  902 WRITE(iout, 9020)
2161  9020 FORMAT(' ----- DEXKS: LACK OF INITIALISATION')
2162  stop
2163  END
2164  SUBROUTINE dadmks(MODE,ISGN,HHV,PNU,PKS,PKK,PPI,JKST)
2165 C ----------------------------------------------------------------------
2166  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
2167  * ,ampiz,ampi,amro,gamro,ama1,gama1
2168  * ,amk,amkz,amkst,gamkst
2169 C
2170  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
2171  * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
2172  * ,AMK,AMKZ,AMKST,GAMKST
2173  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
2174  REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
2175  COMMON / taubmc / gampmc(30),gamper(30),nevdec(30)
2176  REAL*4 GAMPMC ,GAMPER
2177  COMMON / taukle / bra1,brk0,brk0b,brks
2178  REAL*4 BRA1,BRK0,BRK0B,BRKS
2179  COMMON / inout / inut,iout
2180  REAL HHV(4)
2181  REAL HV(4),PKS(4),PNU(4),PKK(4),PPI(4)
2182  REAL PDUM1(4),PDUM2(4),PDUM3(4),PDUM4(4)
2183  REAL*4 RRR(3),RMOD(1)
2184  REAL*8 SWT, SSWT
2185  DATA pi /3.141592653589793238462643/
2186  DATA iwarm/0/
2187 C
2188  IF(mode.EQ.-1) THEN
2189 C ===================
2190  iwarm=1
2191  nevraw=0
2192  nevacc=0
2193  nevovr=0
2194  swt=0
2195  sswt=0
2196  wtmax=1e-20
2197  DO 15 i=1,500
2198 C THE INITIALISATION IS DONE WITH THE 66.7% MODE
2199  jkst=10
2200  CALL dphsks(wt,hv,pdum1,pdum2,pdum3,pdum4,jkst)
2201  IF(wt.GT.wtmax/1.2) wtmax=wt*1.2
2202 15 CONTINUE
2203 CC CALL HBOOK1(801,'WEIGHT DISTRIBUTION DADMKS $',100,0,2)
2204 CC PRINT 7003,WTMAX
2205 CC CALL HBOOK1(112,'-------- K* MASS -------- $',100,0.,2.)
2206  ELSEIF(mode.EQ. 0) THEN
2207 C =====================================
2208  IF(iwarm.EQ.0) GOTO 902
2209 C HERE WE CHOOSE RANDOMLY BETWEEN K0 PI+_ (66.7%)
2210 C AND K+_ PI0 (33.3%)
2211  dec1=brks
2212 400 CONTINUE
2213  CALL ranmar(rmod,1)
2214  IF(rmod(1).LT.dec1) THEN
2215  jkst=10
2216  ELSE
2217  jkst=20
2218  ENDIF
2219  CALL dphsks(wt,hv,pnu,pks,pkk,ppi,jkst)
2220  CALL ranmar(rrr,3)
2221  rn=rrr(1)
2222  IF(wt.GT.wtmax) nevovr=nevovr+1
2223  nevraw=nevraw+1
2224  swt=swt+wt
2225  sswt=sswt+wt**2
2226  IF(rn*wtmax.GT.wt) GOTO 400
2227 C ROTATIONS TO BASIC TAU REST FRAME
2228  costhe=-1.+2.*rrr(2)
2229  thet=acos(costhe)
2230  phi =2*pi*rrr(3)
2231  CALL rotor2(thet,pnu,pnu)
2232  CALL rotor3( phi,pnu,pnu)
2233  CALL rotor2(thet,pks,pks)
2234  CALL rotor3( phi,pks,pks)
2235  CALL rotor2(thet,pkk,pkk)
2236  CALL rotor3(phi,pkk,pkk)
2237  CALL rotor2(thet,ppi,ppi)
2238  CALL rotor3( phi,ppi,ppi)
2239  CALL rotor2(thet,hv,hv)
2240  CALL rotor3( phi,hv,hv)
2241  DO 44 i=1,3
2242  44 hhv(i)=-isgn*hv(i)
2243  nevacc=nevacc+1
2244 C
2245  ELSEIF(mode.EQ. 1) THEN
2246 C =======================
2247  IF(nevraw.EQ.0) RETURN
2248  pargam=swt/float(nevraw+1)
2249  error=0
2250  IF(nevraw.NE.0) error=sqrt(sswt/swt**2-1./float(nevraw))
2251  rat=pargam/gamel
2252  WRITE(iout, 7010) nevraw,nevacc,nevovr,pargam,rat,error
2253 CC CALL HPRINT(801)
2254  gampmc(7)=rat
2255  gamper(7)=error
2256 CAM NEVDEC(7)=NEVACC
2257  ENDIF
2258 C =====
2259  RETURN
2260  7003 FORMAT(///1x,15(5h*****)
2261  $ /,' *', 25x,'******** DADMKS INITIALISATION ********',9x,1h*
2262  $ /,' *',e20.5,5x,'WTMAX = MAXIMUM WEIGHT ',9x,1h*
2263  $ /,1x,15(5h*****)/)
2264  7010 FORMAT(///1x,15(5h*****)
2265  $ /,' *', 25x,'******** DADMKS FINAL REPORT ********',9x,1h*
2266  $ /,' *',i20 ,5x,'NEVRAW = NO. OF K* DECAYS TOTAL ',9x,1h*,
2267  $ /,' *',i20 ,5x,'NEVACC = NO. OF K* DECS. ACCEPTED ',9x,1h*,
2268  $ /,' *',i20 ,5x,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9x,1h*
2269  $ /,' *',e20.5,5x,'PARTIAL WTDTH (K* DECAY) IN GEV UNITS ',9x,1h*,
2270  $ /,' *',f20.9,5x,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',9x,1h*
2271  $ /,' *',f20.8,5x,'RELATIVE ERROR OF PARTIAL WIDTH ',9x,1h*
2272  $ /,1x,15(5h*****)/)
2273  902 WRITE(iout, 9020)
2274  9020 FORMAT(' ----- DADMKS: LACK OF INITIALISATION')
2275  stop
2276  END
2277  SUBROUTINE dphsks(DGAMT,HV,PN,PKS,PKK,PPI,JKST)
2278 C ----------------------------------------------------------------------
2279 C IT SIMULATES KAON* DECAY IN TAU REST FRAME WITH
2280 C Z-AXIS ALONG KAON* MOMENTUM
2281 C JKST=10 FOR K* --->K0 + PI+-
2282 C JKST=20 FOR K* --->K+- + PI0
2283 C ----------------------------------------------------------------------
2284 #if defined (ALEPH)
2285 #else
2286  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
2287  REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
2288 #endif
2289  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
2290  * ,ampiz,ampi,amro,gamro,ama1,gama1
2291  * ,amk,amkz,amkst,gamkst
2292 C
2293  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
2294  * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
2295  * ,AMK,AMKZ,AMKST,GAMKST
2296 #if defined (ALEPH)
2297  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
2298  REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
2299 #else
2300 #endif
2301  REAL HV(4),PT(4),PN(4),PKS(4),PKK(4),PPI(4),QQ(4),RR1(1)
2302 #if defined (ALEPH)
2303 cam COMPLEX BWIGS
2304  COMPLEX BWIGM
2305 #else
2306  COMPLEX BWIGS
2307 #endif
2308  DATA pi /3.141592653589793238462643/
2309 C
2310  DATA icont /0/
2311 C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
2312  phspac=1./2**11/pi**5
2313 C TAU MOMENTUM
2314  pt(1)=0.
2315  pt(2)=0.
2316  pt(3)=0.
2317  pt(4)=amtau
2318  CALL ranmar(rr1,1)
2319 C HERE BEGIN THE K0,PI+_ DECAY
2320  IF(jkst.EQ.10)THEN
2321 C ==================
2322 C MASS OF (REAL/VIRTUAL) K*
2323  ams1=(ampi+amkz)**2
2324  ams2=(amtau-amnuta)**2
2325 C FLAT PHASE SPACE
2326 C AMX2=AMS1+ RR1(1)*(AMS2-AMS1)
2327 C AMX=SQRT(AMX2)
2328 C PHSPAC=PHSPAC*(AMS2-AMS1)
2329 C PHASE SPACE WITH SAMPLING FOR K* RESONANCE
2330  alp1=atan((ams1-amkst**2)/amkst/gamkst)
2331  alp2=atan((ams2-amkst**2)/amkst/gamkst)
2332  alp=alp1+rr1(1)*(alp2-alp1)
2333  amx2=amkst**2+amkst*gamkst*tan(alp)
2334  amx=sqrt(amx2)
2335  phspac=phspac*((amx2-amkst**2)**2+(amkst*gamkst)**2)
2336  & /(amkst*gamkst)
2337  phspac=phspac*(alp2-alp1)
2338 C
2339 C TAU-NEUTRINO MOMENTUM
2340  pn(1)=0
2341  pn(2)=0
2342  pn(4)=1./(2*amtau)*(amtau**2+amnuta**2-amx**2)
2343  pn(3)=-sqrt((pn(4)-amnuta)*(pn(4)+amnuta))
2344 C
2345 C K* MOMENTUM
2346  pks(1)=0
2347  pks(2)=0
2348  pks(4)=1./(2*amtau)*(amtau**2-amnuta**2+amx**2)
2349  pks(3)=-pn(3)
2350  phspac=phspac*(4*pi)*(2*pks(3)/amtau)
2351 C
2352 CAM
2353  enpi=( amx**2+ampi**2-amkz**2 ) / ( 2*amx )
2354  pppi=sqrt((enpi-ampi)*(enpi+ampi))
2355  phspac=phspac*(4*pi)*(2*pppi/amx)
2356 C CHARGED PI MOMENTUM IN KAON* REST FRAME
2357  CALL sphera(pppi,ppi)
2358  ppi(4)=enpi
2359 C NEUTRAL KAON MOMENTUM IN K* REST FRAME
2360  DO 20 i=1,3
2361 20 pkk(i)=-ppi(i)
2362  pkk(4)=( amx**2+amkz**2-ampi**2 ) / ( 2*amx )
2363  exe=(pks(4)+pks(3))/amx
2364 C PION AND K BOOSTED FROM K* REST FRAME TO TAU REST FRAME
2365  CALL bostr3(exe,ppi,ppi)
2366  CALL bostr3(exe,pkk,pkk)
2367  DO 30 i=1,4
2368 30 qq(i)=ppi(i)-pkk(i)
2369 C QQ transverse to PKS
2370  pksd =pks(4)*pks(4)-pks(3)*pks(3)-pks(2)*pks(2)-pks(1)*pks(1)
2371  qqpks=pks(4)* qq(4)-pks(3)* qq(3)-pks(2)* qq(2)-pks(1)* qq(1)
2372  DO 31 i=1,4
2373 31 qq(i)=qq(i)-pks(i)*qqpks/pksd
2374 C AMPLITUDE
2375  prodpq=pt(4)*qq(4)
2376  prodnq=pn(4)*qq(4)-pn(1)*qq(1)-pn(2)*qq(2)-pn(3)*qq(3)
2377  prodpn=pt(4)*pn(4)
2378  qq2= qq(4)**2-qq(1)**2-qq(2)**2-qq(3)**2
2379  brak=(gv**2+ga**2)*(2*prodpq*prodnq-prodpn*qq2)
2380  & +(gv**2-ga**2)*amtau*amnuta*qq2
2381 C A SIMPLE BREIT-WIGNER IS CHOSEN FOR K* RESONANCE
2382 #if defined (ALEPH)
2383 cam FKS=CABS(BWIGS(AMX2,AMKST,GAMKST))**2
2384  fks=cabs(bwigm(amx2,amkst,gamkst,ampi,amkz))**2
2385 #else
2386  fks=cabs(bwigs(amx2,amkst,gamkst))**2
2387 #endif
2388  amplit=(gfermi*scabib)**2*brak*2*fks
2389  dgamt=1/(2.*amtau)*amplit*phspac
2390  DO 40 i=1,3
2391  40 hv(i)=2*gv*ga*amtau*(2*prodnq*qq(i)-qq2*pn(i))/brak
2392 C
2393 C HERE BEGIN THE K+-,PI0 DECAY
2394  ELSEIF(jkst.EQ.20)THEN
2395 C ======================
2396 C MASS OF (REAL/VIRTUAL) K*
2397  ams1=(ampiz+amk)**2
2398  ams2=(amtau-amnuta)**2
2399 C FLAT PHASE SPACE
2400 #if defined (ALEPH)
2401 C AMX2=AMS1+ RR1(1)*(AMS2-AMS1)
2402 #else
2403 C AMX2=AMS1+ RR1*(AMS2-AMS1)
2404 #endif
2405 C AMX=SQRT(AMX2)
2406 C PHSPAC=PHSPAC*(AMS2-AMS1)
2407 C PHASE SPACE WITH SAMPLING FOR K* RESONANCE
2408  alp1=atan((ams1-amkst**2)/amkst/gamkst)
2409  alp2=atan((ams2-amkst**2)/amkst/gamkst)
2410  alp=alp1+rr1(1)*(alp2-alp1)
2411  amx2=amkst**2+amkst*gamkst*tan(alp)
2412  amx=sqrt(amx2)
2413  phspac=phspac*((amx2-amkst**2)**2+(amkst*gamkst)**2)
2414  & /(amkst*gamkst)
2415  phspac=phspac*(alp2-alp1)
2416 C
2417 C TAU-NEUTRINO MOMENTUM
2418  pn(1)=0
2419  pn(2)=0
2420  pn(4)=1./(2*amtau)*(amtau**2+amnuta**2-amx**2)
2421  pn(3)=-sqrt((pn(4)-amnuta)*(pn(4)+amnuta))
2422 C KAON* MOMENTUM
2423  pks(1)=0
2424  pks(2)=0
2425  pks(4)=1./(2*amtau)*(amtau**2-amnuta**2+amx**2)
2426  pks(3)=-pn(3)
2427  phspac=phspac*(4*pi)*(2*pks(3)/amtau)
2428 C
2429 CAM
2430  enpi=( amx**2+ampiz**2-amk**2 ) / ( 2*amx )
2431  pppi=sqrt((enpi-ampiz)*(enpi+ampiz))
2432  phspac=phspac*(4*pi)*(2*pppi/amx)
2433 C NEUTRAL PI MOMENTUM IN K* REST FRAME
2434  CALL sphera(pppi,ppi)
2435  ppi(4)=enpi
2436 C CHARGED KAON MOMENTUM IN K* REST FRAME
2437  DO 50 i=1,3
2438 50 pkk(i)=-ppi(i)
2439  pkk(4)=( amx**2+amk**2-ampiz**2 ) / ( 2*amx )
2440  exe=(pks(4)+pks(3))/amx
2441 C PION AND K BOOSTED FROM K* REST FRAME TO TAU REST FRAME
2442  CALL bostr3(exe,ppi,ppi)
2443  CALL bostr3(exe,pkk,pkk)
2444  DO 60 i=1,4
2445 60 qq(i)=pkk(i)-ppi(i)
2446 C QQ transverse to PKS
2447  pksd =pks(4)*pks(4)-pks(3)*pks(3)-pks(2)*pks(2)-pks(1)*pks(1)
2448  qqpks=pks(4)* qq(4)-pks(3)* qq(3)-pks(2)* qq(2)-pks(1)* qq(1)
2449  DO 61 i=1,4
2450 61 qq(i)=qq(i)-pks(i)*qqpks/pksd
2451 C AMPLITUDE
2452  prodpq=pt(4)*qq(4)
2453  prodnq=pn(4)*qq(4)-pn(1)*qq(1)-pn(2)*qq(2)-pn(3)*qq(3)
2454  prodpn=pt(4)*pn(4)
2455  qq2= qq(4)**2-qq(1)**2-qq(2)**2-qq(3)**2
2456  brak=(gv**2+ga**2)*(2*prodpq*prodnq-prodpn*qq2)
2457  & +(gv**2-ga**2)*amtau*amnuta*qq2
2458 C A SIMPLE BREIT-WIGNER IS CHOSEN FOR THE K* RESONANCE
2459 #if defined (ALEPH)
2460 cam FKS=CABS(BWIGS(AMX2,AMKST,GAMKST))**2
2461  fks=cabs(bwigm(amx2,amkst,gamkst,amk,ampiz))**2
2462 #else
2463  fks=cabs(bwigs(amx2,amkst,gamkst))**2
2464 #endif
2465  amplit=(gfermi*scabib)**2*brak*2*fks
2466  dgamt=1/(2.*amtau)*amplit*phspac
2467  DO 70 i=1,3
2468  70 hv(i)=2*gv*ga*amtau*(2*prodnq*qq(i)-qq2*pn(i))/brak
2469  ENDIF
2470  RETURN
2471  END
2472 
2473 
2474 
2475 #if defined (ALEPH)
2476  SUBROUTINE dphnpi(DGAMT,HV,PN,PR,PPI,JNPI)
2477 #else
2478  SUBROUTINE dphnpi(DGAMT,HVX,PNX,PRX,PPIX,JNPI)
2479 #endif
2480 C ----------------------------------------------------------------------
2481 C IT SIMULATES MULTIPI DECAY IN TAU REST FRAME WITH
2482 C Z-AXIS OPPOSITE TO NEUTRINO MOMENTUM
2483 C ----------------------------------------------------------------------
2484  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
2485  * ,ampiz,ampi,amro,gamro,ama1,gama1
2486  * ,amk,amkz,amkst,gamkst
2487 C
2488  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
2489  * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
2490  * ,AMK,AMKZ,AMKST,GAMKST
2491  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
2492  REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
2493  parameter(nmode=15,nm1=0,nm2=1,nm3=8,nm4=2,nm5=1,nm6=3)
2494 #if defined (ALEPH)
2495  COMMON / taudcd /idffin(9,nmode),mulpik(nmode)
2496  & ,names
2497  CHARACTER NAMES(NMODE)*31
2498 C
2499 #else
2500  COMMON / taudcd /idffin(9,nmode),mulpik(nmode)
2501  & ,names
2502  CHARACTER NAMES(NMODE)*31
2503  REAL*8 WETMAX(20)
2504 C
2505 #endif
2506 #if defined (ALEPH)
2507  REAL PN(4),PR(4),PPI(4,9),HV(4)
2508  REAL PV(5,9),PT(4),UE(3),BE(3)
2509  REAL*4 RRR(9),RORD(9),RR1(1)
2510  real dpar(8)
2511 C
2512  DATA pi /3.141592653589793238462643/
2513  DATA dpar/2.,5.,15.,60.,250.,1500.,1.2e4,1.2e5/
2514 C
2515 C PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2.*A)
2516  pawt(a,b,c)=sqrt(max(0.,(a**2-(b+c)**2)*(a**2-(b-c)**2)))/(2.*a)
2517 #else
2518  REAL*8 PN(4),PR(4),PPI(4,9),HV(4)
2519  REAL*4 PNX(4),PRX(4),PPIX(4,9),HVX(4)
2520  REAL*8 PV(5,9),PT(4),UE(3),BE(3)
2521  REAL*8 PAWT,AMX,AMS1,AMS2,PA,PHS,PHSMAX,PMIN,PMAX
2522 !!! M.S. to fix underflow >>>
2523  REAL*8 PHSPAC
2524 !!! M.S. to fix underflow <<<
2525  REAL*8 GAM,BEP,PHI,A,B,C
2526  REAL*8 AMPIK
2527  REAL*4 RRR(9),RRX(2),RN(1),RR2(1)
2528 C
2529  DATA pi /3.141592653589793238462643/
2530  DATA wetmax /20*1d-15/
2531 C
2532 CC-- PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2.*A)
2533 C
2534  pawt(a,b,c)=
2535  $ sqrt(max(0.d0,(a**2-(b+c)**2)*(a**2-(b-c)**2)))/(2.d0*a)
2536 #endif
2537 C
2538  ampik(i,j)=dcdmas(idffin(i,j))
2539 C
2540 C
2541 #if defined (ALEPH)
2542 #else
2543  IF ((jnpi.LE.0).OR.jnpi.GT.20) THEN
2544  WRITE(6,*) 'JNPI OUTSIDE RANGE DEFINED BY WETMAX; JNPI=',jnpi
2545  stop
2546  ENDIF
2547 
2548 #endif
2549 C TAU MOMENTUM
2550  pt(1)=0.
2551  pt(2)=0.
2552  pt(3)=0.
2553  pt(4)=amtau
2554 C
2555 #if defined (ALEPH)
2556 #else
2557  500 CONTINUE
2558 #endif
2559 C MASS OF VIRTUAL W
2560  nd=mulpik(jnpi)
2561  ps=0.
2562  phspac = 1./2.**5 /pi**2
2563  DO 4 i=1,nd
2564 4 ps =ps+ampik(i,jnpi)
2565 #if defined (ALEPH)
2566  CALL ranmar(rr1,1)
2567 #else
2568  CALL ranmar(rr2,1)
2569 #endif
2570  ams1=ps**2
2571  ams2=(amtau-amnuta)**2
2572 C
2573 C
2574 #if defined (ALEPH)
2575  amx2=ams1+ rr1(1)*(ams2-ams1)
2576 #else
2577  amx2=ams1+ rr2(1)*(ams2-ams1)
2578 #endif
2579  amx =sqrt(amx2)
2580  amw =amx
2581  phspac=phspac * (ams2-ams1)
2582 C
2583 C TAU-NEUTRINO MOMENTUM
2584  pn(1)=0
2585  pn(2)=0
2586  pn(4)=1./(2*amtau)*(amtau**2+amnuta**2-amx2)
2587  pn(3)=-sqrt((pn(4)-amnuta)*(pn(4)+amnuta))
2588 C W MOMENTUM
2589  pr(1)=0
2590  pr(2)=0
2591  pr(4)=1./(2*amtau)*(amtau**2-amnuta**2+amx2)
2592  pr(3)=-pn(3)
2593  phspac=phspac * (4.*pi) * (2.*pr(3)/amtau)
2594 C
2595 C AMPLITUDE (cf YS.Tsai Phys.Rev.D4,2821(1971)
2596 C or F.Gilman SH.Rhie Phys.Rev.D31,1066(1985)
2597 C
2598  pxq=amtau*pr(4)
2599  pxn=amtau*pn(4)
2600  qxn=pr(4)*pn(4)-pr(1)*pn(1)-pr(2)*pn(2)-pr(3)*pn(3)
2601 #if defined (ALEPH)
2602 #else
2603 C HERE WAS AN ERROR. 20.10.91 (ZW)
2604 C BRAK=2*(GV**2+GA**2)*(2*PXQ*PXN+AMX2*QXN)
2605 #endif
2606  brak=2*(gv**2+ga**2)*(2*pxq*qxn+amx2*pxn)
2607  & -6*(gv**2-ga**2)*amtau*amnuta*amx2
2608 CAM Assume neutrino mass=0. and sum over final polarisation
2609 C BRAK= 2*(AMTAU**2-AMX2) * (AMTAU**2+2.*AMX2)
2610  amplit=ccabib**2*gfermi**2/2. * brak * amx2*sigee(amx2,jnpi)
2611  dgamt=1./(2.*amtau)*amplit*phspac
2612 C
2613 C ISOTROPIC W DECAY IN W REST FRAME
2614 #if defined (ALEPH)
2615  phspac = 1./2.**(6*nd-7) /pi**(3*nd-4)
2616  phsmax = 1./dpar(nd-2)
2617 #else
2618  phsmax = 1.
2619 #endif
2620  DO 200 i=1,4
2621  200 pv(i,1)=pr(i)
2622  pv(5,1)=amw
2623  pv(5,nd)=ampik(nd,jnpi)
2624 C COMPUTE MAX. PHASE SPACE FACTOR
2625  pmax=amw-ps+ampik(nd,jnpi)
2626  pmin=.0
2627  DO 220 il=nd-1,1,-1
2628  pmax=pmax+ampik(il,jnpi)
2629  pmin=pmin+ampik(il+1,jnpi)
2630 #if defined (ALEPH)
2631  220 phsmax=phsmax*pawt(pmax,pmin,ampik(il,jnpi))
2632 CAM GENERATE ND-2 EFFECTIVE MASSES (cf LUDECY)
2633  phspac = 1./2.**(6*nd-7) /pi**(3*nd-4)
2634  240 rord(1)=1.
2635  CALL ranmar(rrr,nd-1)
2636  DO 260 il=2,nd-1
2637  rsav=rrr(il)
2638  DO 250 jl=il-1,1,-1
2639  IF(rsav.LE.rord(jl)) GOTO 260
2640  250 rord(jl+1)=rord(jl)
2641  260 rord(jl+1)=rsav
2642  rord(nd)=0.
2643  phs=1.
2644  DO 270 il=nd-1,1,-1
2645  pv(5,il)=pv(5,il+1)+ampik(il,jnpi)
2646  & +(rord(il)-rord(il+1))*(pv(5,1)-ps)
2647  270 phs=phs*pawt(pv(5,il),pv(5,il+1),ampik(il,jnpi))
2648  rn = rrr(1)
2649  IF(phs.LT.rn*phsmax) GOTO 240
2650 #else
2651  220 phsmax=phsmax*pawt(pmax,pmin,ampik(il,jnpi))/pmax
2652 
2653 C --- 2.02.94 ZW 9 lines
2654  amx=amw
2655  DO 222 il=1,nd-2
2656  ams1=.0
2657  DO 223 jl=il+1,nd
2658  223 ams1=ams1+ampik(jl,jnpi)
2659  ams1=ams1**2
2660  amx =(amx-ampik(il,jnpi))
2661  ams2=(amx)**2
2662  phsmax=phsmax * (ams2-ams1)
2663  222 CONTINUE
2664  ncont=0
2665  100 CONTINUE
2666  ncont=ncont+1
2667 CAM GENERATE ND-2 EFFECTIVE MASSES
2668  phs=1.d0
2669  phspac = 1./2.**(6*nd-7) /pi**(3*nd-4)
2670  amx=amw
2671  CALL ranmar(rrr,nd-2)
2672  DO 230 il=1,nd-2
2673  ams1=.0d0
2674  DO 231 jl=il+1,nd
2675  231 ams1=ams1+ampik(jl,jnpi)
2676  ams1=ams1**2
2677  ams2=(amx-ampik(il,jnpi))**2
2678  rr1=rrr(il)
2679  amx2=ams1+ rr1*(ams2-ams1)
2680  amx=sqrt(amx2)
2681  pv(5,il+1)=amx
2682  phspac=phspac * (ams2-ams1)
2683 C --- 2.02.94 ZW 1 line
2684  phs=phs* (ams2-ams1)
2685  pa=pawt(pv(5,il),pv(5,il+1),ampik(il,jnpi))
2686  phs =phs *pa/pv(5,il)
2687  230 CONTINUE
2688  pa=pawt(pv(5,nd-1),ampik(nd-1,jnpi),ampik(nd,jnpi))
2689  phs =phs *pa/pv(5,nd-1)
2690  CALL ranmar(rn,1)
2691  wetmax(jnpi)=1.2d0*max(wetmax(jnpi)/1.2d0,phs/phsmax)
2692  IF (ncont.EQ.500 000) THEN
2693  xnpi=0.0
2694  DO kk=1,nd
2695  xnpi=xnpi+ampik(kk,jnpi)
2696  ENDDO
2697  WRITE(6,*) 'ROUNDING INSTABILITY IN DPHNPI ?'
2698  WRITE(6,*) 'AMW=',amw,'XNPI=',xnpi
2699  WRITE(6,*) 'IF =AMW= IS NEARLY EQUAL =XNPI= THAT IS IT'
2700  WRITE(6,*) 'PHS=',phs,'PHSMAX=',phsmax
2701  GOTO 500
2702  ENDIF
2703  IF(rn(1)*phsmax*wetmax(jnpi).GT.phs) GO TO 100
2704 #endif
2705 C...PERFORM SUCCESSIVE TWO-PARTICLE DECAYS IN RESPECTIVE CM FRAME
2706  280 DO 300 il=1,nd-1
2707  pa=pawt(pv(5,il),pv(5,il+1),ampik(il,jnpi))
2708 #if defined (ALEPH)
2709  CALL ranmar(rrr,2)
2710  ue(3)=2.*rrr(1)-1.
2711  phi=2.*pi*rrr(2)
2712  ue(1)=sqrt(1.-ue(3)**2)*cos(phi)
2713  ue(2)=sqrt(1.-ue(3)**2)*sin(phi)
2714 #else
2715  CALL ranmar(rrx,2)
2716  ue(3)=2.*rrx(1)-1.
2717  phi=2.*pi*rrx(2)
2718  ue(1)=sqrt(1.d0-ue(3)**2)*cos(phi)
2719  ue(2)=sqrt(1.d0-ue(3)**2)*sin(phi)
2720 #endif
2721  DO 290 j=1,3
2722  ppi(j,il)=pa*ue(j)
2723  290 pv(j,il+1)=-pa*ue(j)
2724  ppi(4,il)=sqrt(pa**2+ampik(il,jnpi)**2)
2725  pv(4,il+1)=sqrt(pa**2+pv(5,il+1)**2)
2726  phspac=phspac *(4.*pi)*(2.*pa/pv(5,il))
2727  300 CONTINUE
2728 C...LORENTZ TRANSFORM DECAY PRODUCTS TO TAU FRAME
2729  DO 310 j=1,4
2730  310 ppi(j,nd)=pv(j,nd)
2731  DO 340 il=nd-1,1,-1
2732  DO 320 j=1,3
2733  320 be(j)=pv(j,il)/pv(4,il)
2734  gam=pv(4,il)/pv(5,il)
2735  DO 340 i=il,nd
2736  bep=be(1)*ppi(1,i)+be(2)*ppi(2,i)+be(3)*ppi(3,i)
2737  DO 330 j=1,3
2738 #if defined (ALEPH)
2739  330 ppi(j,i)=ppi(j,i)+gam*(gam*bep/(1.+gam)+ppi(4,i))*be(j)
2740 #else
2741  330 ppi(j,i)=ppi(j,i)+gam*(gam*bep/(1.d0+gam)+ppi(4,i))*be(j)
2742 #endif
2743  ppi(4,i)=gam*(ppi(4,i)+bep)
2744  340 CONTINUE
2745 C
2746  hv(4)=1.
2747  hv(3)=0.
2748  hv(2)=0.
2749  hv(1)=0.
2750 #if defined (ALEPH)
2751 #else
2752  DO k=1,4
2753  pnx(k)=pn(k)
2754  prx(k)=pr(k)
2755  hvx(k)=hv(k)
2756  DO l=1,nd
2757  ppix(k,l)=ppi(k,l)
2758  ENDDO
2759  ENDDO
2760 #endif
2761  RETURN
2762  END
2763  FUNCTION sigee(Q2,JNP)
2764 C ----------------------------------------------------------------------
2765 C e+e- cross section in the (1.GEV2,AMTAU**2) region
2766 C normalised to sig0 = 4/3 pi alfa2
2767 C used in matrix element for multipion tau decays
2768 C cf YS.Tsai Phys.Rev D4 ,2821(1971)
2769 C F.Gilman et al Phys.Rev D17,1846(1978)
2770 C C.Kiesling, to be pub. in High Energy e+e- Physics (1988)
2771 C DATSIG(*,1) = e+e- -> pi+pi-2pi0
2772 C DATSIG(*,2) = e+e- -> 2pi+2pi-
2773 C DATSIG(*,3) = 5-pion contribution (a la TN.Pham et al)
2774 C (Phys Lett 78B,623(1978)
2775 C DATSIG(*,5) = e+e- -> 6pi
2776 C
2777 C 4- and 6-pion cross sections from data
2778 C 5-pion contribution related to 4-pion cross section
2779 C
2780 C Called by DPHNPI
2781 C ----------------------------------------------------------------------
2782  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
2783  * ,ampiz,ampi,amro,gamro,ama1,gama1
2784  * ,amk,amkz,amkst,gamkst
2785 C
2786  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
2787  * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
2788  * ,AMK,AMKZ,AMKST,GAMKST
2789  REAL*4 DATSIG(17,6)
2790 C
2791  DATA datsig/
2792  1 7.40,12.00,16.15,21.25,24.90,29.55,34.15,37.40,37.85,37.40,
2793  2 36.00,33.25,30.50,27.70,24.50,21.25,18.90,
2794  3 1.24, 2.50, 3.70, 5.40, 7.45,10.75,14.50,18.20,22.30,28.90,
2795  4 29.35,25.60,22.30,18.60,14.05,11.60, 9.10,
2796  5 17*.0,
2797  6 17*.0,
2798  7 9*.0,.65,1.25,2.20,3.15,5.00,5.75,7.80,8.25,
2799  8 17*.0/
2800  DATA sig0 / 86.8 /
2801  DATA pi /3.141592653589793238462643/
2802  DATA init / 0 /
2803 C
2804  jnpi=jnp
2805  IF(jnp.EQ.4) jnpi=3
2806  IF(jnp.EQ.3) jnpi=4
2807  IF(init.EQ.0) THEN
2808  init=1
2809 #if defined (CLEO)
2810 C AJWMOD: initialize if called from outside QQ:
2811  IF (ampi.LT.0.139) ampi = 0.1395675
2812 #else
2813 #endif
2814  ampi2=ampi**2
2815  fpi = .943*ampi
2816  DO 100 i=1,17
2817  datsig(i,2) = datsig(i,2)/2.
2818  datsig(i,1) = datsig(i,1) + datsig(i,2)
2819  s = 1.025+(i-1)*.05
2820  fact=0.
2821  s2=s**2
2822  DO 200 j=1,17
2823  t= 1.025+(j-1)*.05
2824  IF(t . gt. s-ampi ) GO TO 201
2825  t2=t**2
2826  fact=(t2/s2)**2*sqrt((s2-t2-ampi2)**2-4.*t2*ampi2)/s2 *2.*t*.05
2827  fact = fact * (datsig(j,1)+datsig(j+1,1))
2828  200 datsig(i,3) = datsig(i,3) + fact
2829  201 datsig(i,3) = datsig(i,3) /(2*pi*fpi)**2
2830  datsig(i,4) = datsig(i,3)
2831  datsig(i,6) = datsig(i,5)
2832  100 CONTINUE
2833 C WRITE(6,1000) DATSIG
2834  1000 FORMAT(///1x,' EE SIGMA USED IN MULTIPI DECAYS'/
2835  % (17f7.2/))
2836  ENDIF
2837  q=sqrt(q2)
2838  qmin=1.
2839  IF(q.LT.qmin) THEN
2840  sigee=datsig(1,jnpi)+
2841  & (datsig(2,jnpi)-datsig(1,jnpi))*(q-1.)/.05
2842  ELSEIF(q.LT.1.8) THEN
2843  DO 1 i=1,16
2844  qmax = qmin + .05
2845  IF(q.LT.qmax) GO TO 2
2846  qmin = qmin + .05
2847  1 CONTINUE
2848  2 sigee=datsig(i,jnpi)+
2849  & (datsig(i+1,jnpi)-datsig(i,jnpi)) * (q-qmin)/.05
2850  ELSEIF(q.GT.1.8) THEN
2851  sigee=datsig(17,jnpi)+
2852  & (datsig(17,jnpi)-datsig(16,jnpi)) * (q-1.8)/.05
2853  ENDIF
2854  IF(sigee.LT..0) sigee=0.
2855 C
2856  sigee = sigee/(6.*pi**2*sig0)
2857 C
2858  RETURN
2859  END
2860 
2861  FUNCTION sigold(Q2,JNPI)
2862 C ----------------------------------------------------------------------
2863 C e+e- cross section in the (1.GEV2,AMTAU**2) region
2864 C normalised to sig0 = 4/3 pi alfa2
2865 C used in matrix element for multipion tau decays
2866 C cf YS.Tsai Phys.Rev D4 ,2821(1971)
2867 C F.Gilman et al Phys.Rev D17,1846(1978)
2868 C C.Kiesling, to be pub. in High Energy e+e- Physics (1988)
2869 C DATSIG(*,1) = e+e- -> pi+pi-2pi0
2870 C DATSIG(*,2) = e+e- -> 2pi+2pi-
2871 C DATSIG(*,3) = 5-pion contribution (a la TN.Pham et al)
2872 C (Phys Lett 78B,623(1978)
2873 C DATSIG(*,4) = e+e- -> 6pi
2874 C
2875 C 4- and 6-pion cross sections from data
2876 C 5-pion contribution related to 4-pion cross section
2877 C
2878 C Called by DPHNPI
2879 C ----------------------------------------------------------------------
2880  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
2881  * ,ampiz,ampi,amro,gamro,ama1,gama1
2882  * ,amk,amkz,amkst,gamkst
2883 C
2884  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
2885  * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
2886  * ,AMK,AMKZ,AMKST,GAMKST
2887  REAL*4 DATSIG(17,4)
2888 C
2889  DATA datsig/
2890  1 7.40,12.00,16.15,21.25,24.90,29.55,34.15,37.40,37.85,37.40,
2891  2 36.00,33.25,30.50,27.70,24.50,21.25,18.90,
2892  3 1.24, 2.50, 3.70, 5.40, 7.45,10.75,14.50,18.20,22.30,28.90,
2893  4 29.35,25.60,22.30,18.60,14.05,11.60, 9.10,
2894  5 17*.0,
2895  6 9*.0,.65,1.25,2.20,3.15,5.00,5.75,7.80,8.25/
2896  DATA sig0 / 86.8 /
2897  DATA pi /3.141592653589793238462643/
2898  DATA init / 0 /
2899 C
2900  IF(init.EQ.0) THEN
2901  init=1
2902  ampi2=ampi**2
2903  fpi = .943*ampi
2904  DO 100 i=1,17
2905  datsig(i,2) = datsig(i,2)/2.
2906  datsig(i,1) = datsig(i,1) + datsig(i,2)
2907  s = 1.025+(i-1)*.05
2908  fact=0.
2909  s2=s**2
2910  DO 200 j=1,17
2911  t= 1.025+(j-1)*.05
2912  IF(t . gt. s-ampi ) GO TO 201
2913  t2=t**2
2914  fact=(t2/s2)**2*sqrt((s2-t2-ampi2)**2-4.*t2*ampi2)/s2 *2.*t*.05
2915  fact = fact * (datsig(j,1)+datsig(j+1,1))
2916  200 datsig(i,3) = datsig(i,3) + fact
2917  201 datsig(i,3) = datsig(i,3) /(2*pi*fpi)**2
2918  100 CONTINUE
2919 C WRITE(6,1000) DATSIG
2920  1000 FORMAT(///1x,' EE SIGMA USED IN MULTIPI DECAYS'/
2921  % (17f7.2/))
2922  ENDIF
2923  q=sqrt(q2)
2924  qmin=1.
2925  IF(q.LT.qmin) THEN
2926  sigee=datsig(1,jnpi)+
2927  & (datsig(2,jnpi)-datsig(1,jnpi))*(q-1.)/.05
2928  ELSEIF(q.LT.1.8) THEN
2929  DO 1 i=1,16
2930  qmax = qmin + .05
2931  IF(q.LT.qmax) GO TO 2
2932  qmin = qmin + .05
2933  1 CONTINUE
2934  2 sigee=datsig(i,jnpi)+
2935  & (datsig(i+1,jnpi)-datsig(i,jnpi)) * (q-qmin)/.05
2936  ELSEIF(q.GT.1.8) THEN
2937  sigee=datsig(17,jnpi)+
2938  & (datsig(17,jnpi)-datsig(16,jnpi)) * (q-1.8)/.05
2939  ENDIF
2940  IF(sigee.LT..0) sigee=0.
2941 C
2942  sigee = sigee/(6.*pi**2*sig0)
2943  sigold=sigee
2944 C
2945  RETURN
2946  END
2947  SUBROUTINE dphspk(DGAMT,HV,PN,PAA,PNPI,JAA)
2948 C ----------------------------------------------------------------------
2949 * IT SIMULATES THREE PI (K) DECAY IN THE TAU REST FRAME
2950 * Z-AXIS ALONG HADRONIC SYSTEM
2951 C ----------------------------------------------------------------------
2952  parameter(nmode=15,nm1=0,nm2=1,nm3=8,nm4=2,nm5=1,nm6=3)
2953 #if defined (ALEPH)
2954  COMMON / taudcd /idffin(9,nmode),mulpik(nmode)
2955 #else
2956  COMMON / taudcd /idffin(9,nmode),mulpik(nmode)
2957 #endif
2958  & ,names
2959  CHARACTER NAMES(NMODE)*31
2960 
2961  REAL HV(4),PN(4),PAA(4),PIM1(4),PIM2(4),PIPL(4),PNPI(4,9)
2962 C MATRIX ELEMENT NUMBER:
2963  mnum=jaa
2964 C TYPE OF THE GENERATION:
2965  keyt=4
2966  IF(jaa.EQ.7) keyt=3
2967 C --- MASSES OF THE DECAY PRODUCTS
2968  amp1=dcdmas(idffin(1,jaa+nm4+nm5+nm6))
2969  amp2=dcdmas(idffin(2,jaa+nm4+nm5+nm6))
2970  amp3=dcdmas(idffin(3,jaa+nm4+nm5+nm6))
2971  call
2972  $ dphtre(dgamt,hv,pn,paa,pim1,amp1,pim2,amp2,pipl,amp3,keyt,mnum)
2973  DO i=1,4
2974  pnpi(i,1)=pim1(i)
2975  pnpi(i,2)=pim2(i)
2976  pnpi(i,3)=pipl(i)
2977  ENDDO
2978  END
2979 
2980 
2981 
2982 
2983  subroutine
2984  $ dphtre(dgamt,hv,pn,paa,pim1,ampa,pim2,ampb,pipl,amp3,keyt,mnum)
2985 C ----------------------------------------------------------------------
2986 * IT SIMULATES A1 DECAY IN TAU REST FRAME WITH
2987 * Z-AXIS ALONG A1 MOMENTUM
2988 * it can be also used to generate K K pi and K pi pi tau decays.
2989 * INPUT PARAMETERS
2990 * KEYT - algorithm controlling switch
2991 * 2 - flat phase space PIM1 PIM2 symmetrized statistical factor 1/2
2992 * 1 - like 1 but peaked around a1 and rho (two channels) masses.
2993 * 3 - peaked around omega, all particles different
2994 * other- flat phase space, all particles different
2995 * AMP1 - mass of first pi, etc. (1-3)
2996 * MNUM - matrix element type
2997 * 0 - a1 matrix element
2998 * 1-6 - matrix element for K pi pi, K K pi decay modes
2999 * 7 - pi- pi0 gamma matrix element
3000 C ----------------------------------------------------------------------
3001  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
3002  * ,ampiz,ampi,amro,gamro,ama1,gama1
3003  * ,amk,amkz,amkst,gamkst
3004 C
3005  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
3006  * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
3007  * ,AMK,AMKZ,AMKST,GAMKST
3008  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
3009  REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
3010  REAL HV(4),PT(4),PN(4),PAA(4),PIM1(4),PIM2(4),PIPL(4)
3011  REAL PR(4)
3012  REAL*4 RRR(5)
3013  DATA pi /3.141592653589793238462643/
3014  DATA icont /0/
3015  xlam(x,y,z)=sqrt(abs((x-y-z)**2-4.0*y*z))
3016 C AMRO, GAMRO IS ONLY A PARAMETER FOR GETING HIGHT EFFICIENCY
3017 C
3018 C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
3019 C D**3 P /2E/(2PI)**3 (2PI)**4 DELTA4(SUM P)
3020  phspac=1./2**17/pi**8
3021 C TAU MOMENTUM
3022  pt(1)=0.
3023  pt(2)=0.
3024  pt(3)=0.
3025  pt(4)=amtau
3026 C
3027  CALL ranmar(rrr,5)
3028  rr=rrr(5)
3029 C
3030  CALL choice(mnum,rr,ichan,prob1,prob2,prob3,
3031  $ amrx,gamrx,amra,gamra,amrb,gamrb)
3032  IF (ichan.EQ.1) THEN
3033  amp1=ampb
3034  amp2=ampa
3035  ELSEIF (ichan.EQ.2) THEN
3036  amp1=ampa
3037  amp2=ampb
3038  ELSE
3039  amp1=ampb
3040  amp2=ampa
3041  ENDIF
3042 CAM
3043  rr1=rrr(1)
3044  ams1=(amp1+amp2+amp3)**2
3045  ams2=(amtau-amnuta)**2
3046 #if defined (ALEPH)
3047 C phase space with sampling for a1 resonance
3048 #else
3049 * PHASE SPACE WITH SAMPLING FOR A1 RESONANCE
3050 #endif
3051  alp1=atan((ams1-amrx**2)/amrx/gamrx)
3052  alp2=atan((ams2-amrx**2)/amrx/gamrx)
3053  alp=alp1+rr1*(alp2-alp1)
3054  am3sq =amrx**2+amrx*gamrx*tan(alp)
3055  am3 =sqrt(am3sq)
3056  phspac=phspac*((am3sq-amrx**2)**2+(amrx*gamrx)**2)/(amrx*gamrx)
3057  phspac=phspac*(alp2-alp1)
3058 C MASS OF (REAL/VIRTUAL) RHO -
3059  rr2=rrr(2)
3060  ams1=(amp2+amp3)**2
3061  ams2=(am3-amp1)**2
3062  IF (ichan.LE.2) THEN
3063 #if defined (ALEPH)
3064 C phase space with sampling for rho resonance,
3065 #else
3066 * PHASE SPACE WITH SAMPLING FOR RHO RESONANCE,
3067 #endif
3068  alp1=atan((ams1-amra**2)/amra/gamra)
3069  alp2=atan((ams2-amra**2)/amra/gamra)
3070  alp=alp1+rr2*(alp2-alp1)
3071  am2sq =amra**2+amra*gamra*tan(alp)
3072  am2 =sqrt(am2sq)
3073 C --- THIS PART OF THE JACOBIAN WILL BE RECOVERED LATER ---------------
3074 C PHSPAC=PHSPAC*(ALP2-ALP1)
3075 C PHSPAC=PHSPAC*((AM2SQ-AMRA**2)**2+(AMRA*GAMRA)**2)/(AMRA*GAMRA)
3076 C----------------------------------------------------------------------
3077  ELSE
3078 #if defined (ALEPH)
3079 C flat phase space;
3080 #else
3081 * FLAT PHASE SPACE;
3082 #endif
3083  am2sq=ams1+ rr2*(ams2-ams1)
3084  am2 =sqrt(am2sq)
3085  phf0=(ams2-ams1)
3086  ENDIF
3087 #if defined (ALEPH)
3088 C rho restframe, define pipl and pim1
3089 #else
3090 * RHO RESTFRAME, DEFINE PIPL AND PIM1
3091 #endif
3092  enq1=(am2sq-amp2**2+amp3**2)/(2*am2)
3093  enq2=(am2sq+amp2**2-amp3**2)/(2*am2)
3094  ppi= enq1**2-amp3**2
3095  pppi=sqrt(abs(enq1**2-amp3**2))
3096 C --- this part of jacobian will be recovered later
3097  phf1=(4*pi)*(2*pppi/am2)
3098 #if defined (ALEPH)
3099 C pi minus momentum in rho rest frame
3100 #else
3101 * PI MINUS MOMENTUM IN RHO REST FRAME
3102 #endif
3103  CALL sphera(pppi,pipl)
3104  pipl(4)=enq1
3105 #if defined (ALEPH)
3106 C pi0 1 momentum in rho rest frame
3107 #else
3108 * PI0 1 MOMENTUM IN RHO REST FRAME
3109 #endif
3110  DO 30 i=1,3
3111  30 pim1(i)=-pipl(i)
3112  pim1(4)=enq2
3113 #if defined (ALEPH)
3114 C a1 rest frame, define pim2
3115 #else
3116 * A1 REST FRAME, DEFINE PIM2
3117 #endif
3118 * RHO MOMENTUM
3119  pr(1)=0
3120  pr(2)=0
3121  pr(4)=1./(2*am3)*(am3**2+am2**2-amp1**2)
3122  pr(3)= sqrt(abs(pr(4)**2-am2**2))
3123  ppi = pr(4)**2-am2**2
3124 * PI0 2 MOMENTUM
3125  pim2(1)=0
3126  pim2(2)=0
3127  pim2(4)=1./(2*am3)*(am3**2-am2**2+amp1**2)
3128  pim2(3)=-pr(3)
3129  phf2=(4*pi)*(2*pr(3)/am3)
3130 #if defined (ALEPH)
3131 C old pions boosted from rho rest frame to a1 rest frame
3132 #else
3133 * OLD PIONS BOOSTED FROM RHO REST FRAME TO A1 REST FRAME
3134 #endif
3135  exe=(pr(4)+pr(3))/am2
3136  CALL bostr3(exe,pipl,pipl)
3137  CALL bostr3(exe,pim1,pim1)
3138  rr3=rrr(3)
3139  rr4=rrr(4)
3140 #if defined (ALEPH)
3141 #else
3142 CAM THET =PI*RR3
3143 #endif
3144  thet =acos(-1.+2*rr3)
3145  phi = 2*pi*rr4
3146  CALL rotpol(thet,phi,pipl)
3147  CALL rotpol(thet,phi,pim1)
3148  CALL rotpol(thet,phi,pim2)
3149  CALL rotpol(thet,phi,pr)
3150 C
3151 * NOW TO THE TAU REST FRAME, DEFINE A1 AND NEUTRINO MOMENTA
3152 * A1 MOMENTUM
3153  paa(1)=0
3154  paa(2)=0
3155  paa(4)=1./(2*amtau)*(amtau**2-amnuta**2+am3**2)
3156  paa(3)= sqrt(abs(paa(4)**2-am3**2))
3157  ppi = paa(4)**2-am3**2
3158  phspac=phspac*(4*pi)*(2*paa(3)/amtau)
3159 * TAU-NEUTRINO MOMENTUM
3160  pn(1)=0
3161  pn(2)=0
3162  pn(4)=1./(2*amtau)*(amtau**2+amnuta**2-am3**2)
3163  pn(3)=-paa(3)
3164 C HERE WE CORRECT FOR THE JACOBIANS OF THE TWO CHAINS
3165 C ---FIRST CHANNEL ------- PIM1+PIPL
3166  ams1=(amp2+amp3)**2
3167  ams2=(am3-amp1)**2
3168  alp1=atan((ams1-amra**2)/amra/gamra)
3169  alp2=atan((ams2-amra**2)/amra/gamra)
3170  xpro = (pim1(3)+pipl(3))**2
3171  $ +(pim1(2)+pipl(2))**2+(pim1(1)+pipl(1))**2
3172  am2sq=-xpro+(pim1(4)+pipl(4))**2
3173 C JACOBIAN OF SPEEDING
3174  ff1 = ((am2sq-amra**2)**2+(amra*gamra)**2)/(amra*gamra)
3175  ff1 =ff1 *(alp2-alp1)
3176 C LAMBDA OF RHO DECAY
3177  gg1 = (4*pi)*(xlam(am2sq,amp2**2,amp3**2)/am2sq)
3178 C LAMBDA OF A1 DECAY
3179  gg1 =gg1 *(4*pi)*sqrt(4*xpro/am3sq)
3180  xjaje=gg1*(ams2-ams1)
3181 C ---SECOND CHANNEL ------ PIM2+PIPL
3182  ams1=(amp1+amp3)**2
3183  ams2=(am3-amp2)**2
3184  alp1=atan((ams1-amrb**2)/amrb/gamrb)
3185  alp2=atan((ams2-amrb**2)/amrb/gamrb)
3186  xpro = (pim2(3)+pipl(3))**2
3187  $ +(pim2(2)+pipl(2))**2+(pim2(1)+pipl(1))**2
3188  am2sq=-xpro+(pim2(4)+pipl(4))**2
3189  ff2 = ((am2sq-amrb**2)**2+(amrb*gamrb)**2)/(amrb*gamrb)
3190  ff2 =ff2 *(alp2-alp1)
3191  gg2 = (4*pi)*(xlam(am2sq,amp1**2,amp3**2)/am2sq)
3192  gg2 =gg2 *(4*pi)*sqrt(4*xpro/am3sq)
3193  xjadw=gg2*(ams2-ams1)
3194 C
3195  a1=0.0
3196  a2=0.0
3197  a3=0.0
3198  xjac1=ff1*gg1
3199  xjac2=ff2*gg2
3200  IF (ichan.EQ.2) THEN
3201  xjac3=xjadw
3202  ELSE
3203  xjac3=xjaje
3204  ENDIF
3205  IF (xjac1.NE.0.0) a1=prob1/xjac1
3206  IF (xjac2.NE.0.0) a2=prob2/xjac2
3207  IF (xjac3.NE.0.0) a3=prob3/xjac3
3208 C
3209  IF (a1+a2+a3.NE.0.0) THEN
3210  phspac=phspac/(a1+a2+a3)
3211  ELSE
3212  phspac=0.0
3213  ENDIF
3214  IF(ichan.EQ.2) THEN
3215  DO 70 i=1,4
3216  x=pim1(i)
3217  pim1(i)=pim2(i)
3218  70 pim2(i)=x
3219  ENDIF
3220 * ALL PIONS BOOSTED FROM A1 REST FRAME TO TAU REST FRAME
3221 * Z-AXIS ANTIPARALLEL TO NEUTRINO MOMENTUM
3222  exe=(paa(4)+paa(3))/am3
3223  CALL bostr3(exe,pipl,pipl)
3224  CALL bostr3(exe,pim1,pim1)
3225  CALL bostr3(exe,pim2,pim2)
3226  CALL bostr3(exe,pr,pr)
3227 C PARTIAL WIDTH CONSISTS OF PHASE SPACE AND AMPLITUDE
3228  IF (mnum.EQ.8) THEN
3229  CALL dampog(pt,pn,pim1,pim2,pipl,amplit,hv)
3230 C ELSEIF (MNUM.EQ.0) THEN
3231 C CALL DAMPAA(PT,PN,PIM1,PIM2,PIPL,AMPLIT,HV)
3232  ELSE
3233  CALL damppk(mnum,pt,pn,pim1,pim2,pipl,amplit,hv)
3234  ENDIF
3235  IF (keyt.EQ.1.OR.keyt.EQ.2) THEN
3236 C THE STATISTICAL FACTOR FOR IDENTICAL PI-S IS CANCELLED WITH
3237 C TWO, FOR TWO MODES OF A1 DECAY NAMELLY PI+PI-PI- AND PI-PI0PI0
3238 #if defined (ALEPH)
3239 Cam PHSPAC=PHSPAC*2.0
3240 Cam PHSPAC=PHSPAC/2.
3241 #else
3242  phspac=phspac*2.0
3243  phspac=phspac/2.
3244 #endif
3245  ENDIF
3246  dgamt=1/(2.*amtau)*amplit*phspac
3247  END
3248  SUBROUTINE dampaa(PT,PN,PIM1,PIM2,PIPL,AMPLIT,HV)
3249 C ----------------------------------------------------------------------
3250 * CALCULATES DIFFERENTIAL CROSS SECTION AND POLARIMETER VECTOR
3251 * FOR TAU DECAY INTO A1, A1 DECAYS NEXT INTO RHO+PI AND RHO INTO PI+PI.
3252 * ALL SPIN EFFECTS IN THE FULL DECAY CHAIN ARE TAKEN INTO ACCOUNT.
3253 * CALCULATIONS DONE IN TAU REST FRAME WITH Z-AXIS ALONG NEUTRINO MOMENT
3254 * THE ROUTINE IS WRITEN FOR ZERO NEUTRINO MASS.
3255 C
3256 C called by : DPHSAA
3257 C ----------------------------------------------------------------------
3258  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
3259  * ,ampiz,ampi,amro,gamro,ama1,gama1
3260  * ,amk,amkz,amkst,gamkst
3261 C
3262  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
3263  * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
3264  * ,AMK,AMKZ,AMKST,GAMKST
3265  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
3266  REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
3267  COMMON /testa1/ keya1
3268  REAL HV(4),PT(4),PN(4),PIM1(4),PIM2(4),PIPL(4)
3269  REAL PAA(4),VEC1(4),VEC2(4)
3270  REAL PIVEC(4),PIAKS(4),HVM(4)
3271  COMPLEX BWIGN,HADCUR(4),FPIK
3272  DATA icont /1/
3273 C
3274 * F CONSTANTS FOR A1, A1-RHO-PI, AND RHO-PI-PI
3275 *
3276  DATA fpi /93.3e-3/
3277 * THIS INLINE FUNCT. CALCULATES THE SCALAR PART OF THE PROPAGATOR
3278  bwign(xm,am,gamma)=1./cmplx(xm**2-am**2,gamma*am)
3279 C
3280 * FOUR MOMENTUM OF A1
3281  DO 10 i=1,4
3282  10 paa(i)=pim1(i)+pim2(i)+pipl(i)
3283 * MASSES OF A1, AND OF TWO PI-PAIRS WHICH MAY FORM RHO
3284  xmaa =sqrt(abs(paa(4)**2-paa(3)**2-paa(2)**2-paa(1)**2))
3285  xmro1 =sqrt(abs((pipl(4)+pim1(4))**2-(pipl(1)+pim1(1))**2
3286  $ -(pipl(2)+pim1(2))**2-(pipl(3)+pim1(3))**2))
3287  xmro2 =sqrt(abs((pipl(4)+pim2(4))**2-(pipl(1)+pim2(1))**2
3288  $ -(pipl(2)+pim2(2))**2-(pipl(3)+pim2(3))**2))
3289 * ELEMENTS OF HADRON CURRENT
3290  prod1 =paa(4)*(pim1(4)-pipl(4))-paa(1)*(pim1(1)-pipl(1))
3291  $ -paa(2)*(pim1(2)-pipl(2))-paa(3)*(pim1(3)-pipl(3))
3292  prod2 =paa(4)*(pim2(4)-pipl(4))-paa(1)*(pim2(1)-pipl(1))
3293  $ -paa(2)*(pim2(2)-pipl(2))-paa(3)*(pim2(3)-pipl(3))
3294  DO 40 i=1,4
3295  vec1(i)= pim1(i)-pipl(i) -paa(i)*prod1/xmaa**2
3296  40 vec2(i)= pim2(i)-pipl(i) -paa(i)*prod2/xmaa**2
3297 * HADRON CURRENT SATURATED WITH A1 AND RHO RESONANCES
3298  IF (keya1.EQ.1) THEN
3299  fa1=9.87
3300  faropi=1.0
3301  fro2pi=1.0
3302  fnorm=fa1/sqrt(2.)*faropi*fro2pi
3303  DO 45 i=1,4
3304  hadcur(i)= cmplx(fnorm) *ama1**2*bwign(xmaa,ama1,gama1)
3305  $ *(cmplx(vec1(i))*amro**2*bwign(xmro1,amro,gamro)
3306  $ +cmplx(vec2(i))*amro**2*bwign(xmro2,amro,gamro))
3307  45 CONTINUE
3308  ELSE
3309  fnorm=2.0*sqrt(2.)/3.0/fpi
3310  gamax=gama1*gfun(xmaa**2)/gfun(ama1**2)
3311  DO 46 i=1,4
3312  hadcur(i)= cmplx(fnorm) *ama1**2*bwign(xmaa,ama1,gamax)
3313  $ *(cmplx(vec1(i))*fpik(xmro1)
3314  $ +cmplx(vec2(i))*fpik(xmro2))
3315  46 CONTINUE
3316  ENDIF
3317 C
3318 * CALCULATE PI-VECTORS: VECTOR AND AXIAL
3319  CALL clvec(hadcur,pn,pivec)
3320  CALL claxi(hadcur,pn,piaks)
3321  CALL clnut(hadcur,brakm,hvm)
3322 * SPIN INDEPENDENT PART OF DECAY DIFF-CROSS-SECT. IN TAU REST FRAME
3323  brak= (gv**2+ga**2)*pt(4)*pivec(4) +2.*gv*ga*pt(4)*piaks(4)
3324  & +2.*(gv**2-ga**2)*amnuta*amtau*brakm
3325  amplit=(gfermi*ccabib)**2*brak/2.
3326 C THE STATISTICAL FACTOR FOR IDENTICAL PI-S WAS CANCELLED WITH
3327 C TWO, FOR TWO MODES OF A1 DECAY NAMELLY PI+PI-PI- AND PI-PI0PI0
3328 C POLARIMETER VECTOR IN TAU REST FRAME
3329  DO 90 i=1,3
3330  hv(i)=-(amtau*((gv**2+ga**2)*piaks(i)+2.*gv*ga*pivec(i)))
3331  & +(gv**2-ga**2)*amnuta*amtau*hvm(i)
3332 C HV IS DEFINED FOR TAU- WITH GAMMA=B+HV*POL
3333  hv(i)=-hv(i)/brak
3334  90 CONTINUE
3335  END
3336 
3337  FUNCTION gfun(QKWA)
3338 C ****************************************************************
3339 C G-FUNCTION USED TO INRODUCE ENERGY DEPENDENCE IN A1 WIDTH
3340 C ****************************************************************
3341  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
3342  * ,ampiz,ampi,amro,gamro,ama1,gama1
3343  * ,amk,amkz,amkst,gamkst
3344 C
3345  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
3346  * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
3347  * ,AMK,AMKZ,AMKST,GAMKST
3348 C
3349  IF (qkwa.LT.(amro+ampi)**2) THEN
3350  gfun=4.1*(qkwa-9*ampiz**2)**3
3351  $ *(1.-3.3*(qkwa-9*ampiz**2)+5.8*(qkwa-9*ampiz**2)**2)
3352  ELSE
3353  gfun=qkwa*(1.623+10.38/qkwa-9.32/qkwa**2+0.65/qkwa**3)
3354  ENDIF
3355  END
3356  COMPLEX FUNCTION bwigs(S,M,G)
3357 C **********************************************************
3358 C P-WAVE BREIT-WIGNER FOR K*
3359 C **********************************************************
3360  REAL S,M,G
3361  REAL PI,PIM,QS,QM,W,GS,MK
3362 #if defined (CLEO)
3363 C AJW: add K*-prim possibility:
3364  REAL PM, PG, PBETA
3365  COMPLEX BW,BWP
3366 #else
3367 #endif
3368  DATA init /0/
3369  p(a,b,c)=sqrt(abs(abs(((a+b-c)**2-4.*a*b)/4./a)
3370  $ +(((a+b-c)**2-4.*a*b)/4./a))/2.0)
3371 C ------------ PARAMETERS --------------------
3372  IF (init.EQ.0) THEN
3373  init=1
3374  pi=3.141592654
3375  pim=.139
3376  mk=.493667
3377 #if defined (CLEO)
3378 C AJW: add K*-prim possibility:
3379  pm = pkorb(1,16)
3380  pg = pkorb(2,16)
3381  pbeta = pkorb(3,16)
3382 #else
3383 #endif
3384 C ------- BREIT-WIGNER -----------------------
3385  ENDIF
3386 #if defined (ALEPH)
3387  IF (s.GT.(pim+mk)**2) THEN
3388 #endif
3389  qs=p(s,pim**2,mk**2)
3390  qm=p(m**2,pim**2,mk**2)
3391  w=sqrt(s)
3392  gs=g*(m/w)*(qs/qm)**3
3393 #if defined (CLEO)
3394  bw=m**2/cmplx(m**2-s,-m*gs)
3395  qpm=p(pm**2,pim**2,mk**2)
3396  g1=pg*(pm/w)*(qs/qpm)**3
3397  bwp=pm**2/cmplx(pm**2-s,-pm*g1)
3398  bwigs= (bw+pbeta*bwp)/(1+pbeta)
3399 #elif defined (ALEPH)
3400  ELSE
3401  gs=0.0
3402  ENDIF
3403  bwigs=m**2/cmplx(m**2-s,-m*gs)
3404 #else
3405  bwigs=m**2/cmplx(m**2-s,-m*gs)
3406 #endif
3407  RETURN
3408  END
3409  COMPLEX FUNCTION bwig(S,M,G)
3410 C **********************************************************
3411 C P-WAVE BREIT-WIGNER FOR RHO
3412 C **********************************************************
3413  REAL S,M,G
3414  REAL PI,PIM,QS,QM,W,GS
3415  DATA init /0/
3416 C ------------ PARAMETERS --------------------
3417  IF (init.EQ.0) THEN
3418  init=1
3419  pi=3.141592654
3420  pim=.139
3421 C ------- BREIT-WIGNER -----------------------
3422  ENDIF
3423  IF (s.GT.4.*pim**2) THEN
3424  qs=sqrt(abs(abs(s/4.-pim**2)+(s/4.-pim**2))/2.0)
3425  qm=sqrt(m**2/4.-pim**2)
3426  w=sqrt(s)
3427  gs=g*(m/w)*(qs/qm)**3
3428  ELSE
3429  gs=0.0
3430  ENDIF
3431  bwig=m**2/cmplx(m**2-s,-m*gs)
3432  RETURN
3433  END
3434  COMPLEX FUNCTION fpik(W)
3435 C **********************************************************
3436 C PION FORM FACTOR
3437 C **********************************************************
3438  COMPLEX BWIG
3439  REAL ROM,ROG,ROM1,ROG1,BETA1,PI,PIM,S,W
3440  EXTERNAL bwig
3441  DATA init /0/
3442 C
3443 C ------------ PARAMETERS --------------------
3444  IF (init.EQ.0 ) THEN
3445  init=1
3446  pi=3.141592654
3447  pim=.140
3448 #if defined (CLEO)
3449  rom=pkorb(1,9)
3450  rog=pkorb(2,9)
3451  rom1=pkorb(1,15)
3452  rog1=pkorb(2,15)
3453  beta1=pkorb(3,15)
3454 #else
3455  rom=0.773
3456  rog=0.145
3457  rom1=1.370
3458  rog1=0.510
3459  beta1=-0.145
3460 #endif
3461  ENDIF
3462 C -----------------------------------------------
3463  s=w**2
3464  fpik= (bwig(s,rom,rog)+beta1*bwig(s,rom1,rog1))
3465  & /(1+beta1)
3466  RETURN
3467  END
3468  FUNCTION fpirho(W)
3469 C **********************************************************
3470 C SQUARE OF PION FORM FACTOR
3471 C **********************************************************
3472  COMPLEX FPIK
3473  fpirho=cabs(fpik(w))**2
3474  END
3475  SUBROUTINE clvec(HJ,PN,PIV)
3476 C ----------------------------------------------------------------------
3477 * CALCULATES THE "VECTOR TYPE" PI-VECTOR PIV
3478 * NOTE THAT THE NEUTRINO MOM. PN IS ASSUMED TO BE ALONG Z-AXIS
3479 C
3480 C called by : DAMPAA
3481 C ----------------------------------------------------------------------
3482  REAL PIV(4),PN(4)
3483  COMPLEX HJ(4),HN
3484 C
3485  hn= hj(4)*cmplx(pn(4))-hj(3)*cmplx(pn(3))
3486  hh= REAL(HJ(4)*CONJG(HJ(4))-HJ(3)*CONJG(HJ(3))
3487  $ -HJ(2)*CONJG(HJ(2))-HJ(1)*CONJG(HJ(1)))
3488  DO 10 i=1,4
3489  10 piv(i)=4.*REAL(HN*CONJG(HJ(I)))-2.*HH*PN(I)
3490  RETURN
3491  END
3492  SUBROUTINE claxi(HJ,PN,PIA)
3493 C ----------------------------------------------------------------------
3494 * CALCULATES THE "AXIAL TYPE" PI-VECTOR PIA
3495 * NOTE THAT THE NEUTRINO MOM. PN IS ASSUMED TO BE ALONG Z-AXIS
3496 C SIGN is chosen +/- for decay of TAU +/- respectively
3497 C called by : DAMPAA, CLNUT
3498 C ----------------------------------------------------------------------
3499  COMMON / jaki / jak1,jak2,jakp,jakm,ktom
3500  COMMON / idfc / idff
3501  REAL PIA(4),PN(4)
3502  COMPLEX HJ(4),HJC(4)
3503 C DET2(I,J)=AIMAG(HJ(I)*HJC(J)-HJ(J)*HJC(I))
3504 C -- here was an error (ZW, 21.11.1991)
3505  det2(i,j)=aimag(hjc(i)*hj(j)-hjc(j)*hj(i))
3506 C -- it was affecting sign of A_LR asymmetry in a1 decay.
3507 C -- note also collision of notation of gamma_va as defined in
3508 C -- TAUOLA paper and J.H. Kuhn and Santamaria Z. Phys C 48 (1990) 445
3509 * -----------------------------------
3510  IF (ktom.EQ.1.OR.ktom.EQ.-1) THEN
3511  sign= idff/abs(idff)
3512  ELSEIF (ktom.EQ.2) THEN
3513  sign=-idff/abs(idff)
3514  ELSE
3515  print *, 'STOP IN CLAXI: KTOM=',ktom
3516  stop
3517  ENDIF
3518 C
3519  DO 10 i=1,4
3520  10 hjc(i)=conjg(hj(i))
3521  pia(1)= -2.*pn(3)*det2(2,4)+2.*pn(4)*det2(2,3)
3522  pia(2)= -2.*pn(4)*det2(1,3)+2.*pn(3)*det2(1,4)
3523  pia(3)= 2.*pn(4)*det2(1,2)
3524  pia(4)= 2.*pn(3)*det2(1,2)
3525 C ALL FOUR INDICES ARE UP SO PIA(3) AND PIA(4) HAVE SAME SIGN
3526  DO 20 i=1,4
3527  20 pia(i)=pia(i)*sign
3528  END
3529  SUBROUTINE clnut(HJ,B,HV)
3530 C ----------------------------------------------------------------------
3531 * CALCULATES THE CONTRIBUTION BY NEUTRINO MASS
3532 * NOTE THE TAU IS ASSUMED TO BE AT REST
3533 C
3534 C called by : DAMPAA
3535 C ----------------------------------------------------------------------
3536  COMPLEX HJ(4)
3537  REAL HV(4),P(4)
3538  DATA p /3*0.,1.0/
3539 C
3540  CALL claxi(hj,p,hv)
3541  b=REAL( HJ(4)*AIMAG(HJ(4)) - HJ(3)*AIMAG(HJ(3)) & - HJ(2)*AIMAG(HJ(2)) - HJ(1)*AIMAG(HJ(1)) )
3542  RETURN
3543  END
3544  SUBROUTINE dampog(PT,PN,PIM1,PIM2,PIPL,AMPLIT,HV)
3545 C ----------------------------------------------------------------------
3546 * CALCULATES DIFFERENTIAL CROSS SECTION AND POLARIMETER VECTOR
3547 * FOR TAU DECAY INTO A1, A1 DECAYS NEXT INTO RHO+PI AND RHO INTO PI+PI.
3548 * ALL SPIN EFFECTS IN THE FULL DECAY CHAIN ARE TAKEN INTO ACCOUNT.
3549 * CALCULATIONS DONE IN TAU REST FRAME WITH Z-AXIS ALONG NEUTRINO MOMENT
3550 * THE ROUTINE IS WRITEN FOR ZERO NEUTRINO MASS.
3551 C
3552 #if defined (ALEPH)
3553 C called by : DPHTRE
3554 #else
3555 C called by : DPHSAA
3556 #endif
3557 C ----------------------------------------------------------------------
3558  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
3559  * ,ampiz,ampi,amro,gamro,ama1,gama1
3560  * ,amk,amkz,amkst,gamkst
3561 C
3562  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
3563  * ,ampiz,ampi,amro,gamro,ama1,gama1
3564  * ,amk,amkz,amkst,gamkst
3565  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
3566  REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
3567  COMMON /testa1/ keya1
3568  REAL HV(4),PT(4),PN(4),PIM1(4),PIM2(4),PIPL(4)
3569  REAL PAA(4),VEC1(4),VEC2(4)
3570  REAL PIVEC(4),PIAKS(4),HVM(4)
3571  COMPLEX BWIGN,HADCUR(4),FNORM,FORMOM
3572  DATA icont /1/
3573 * THIS INLINE FUNCT. CALCULATES THE SCALAR PART OF THE PROPAGATOR
3574 #if defined (CLEO)
3575 C AJWMOD to satisfy compiler, comment out this unused function.
3576 #else
3577  bwign(xm,am,gamma)=1./cmplx(xm**2-am**2,gamma*am)
3578 #endif
3579 C
3580 * FOUR MOMENTUM OF A1
3581  DO 10 i=1,4
3582  vec1(i)=0.0
3583  vec2(i)=0.0
3584  hv(i) =0.0
3585  10 paa(i)=pim1(i)+pim2(i)+pipl(i)
3586  vec1(1)=1.0
3587 * MASSES OF A1, AND OF TWO PI-PAIRS WHICH MAY FORM RHO
3588  xmaa =sqrt(abs(paa(4)**2-paa(3)**2-paa(2)**2-paa(1)**2))
3589  xmom =sqrt(abs( (pim2(4)+pipl(4))**2-(pim2(3)+pipl(3))**2
3590  $ -(pim2(2)+pipl(2))**2-(pim2(1)+pipl(1))**2 ))
3591  xmro2 =(pipl(1))**2 +(pipl(2))**2 +(pipl(3))**2
3592 * ELEMENTS OF HADRON CURRENT
3593  prod1 =vec1(1)*pipl(1)
3594  prod2 =vec2(2)*pipl(2)
3595  p12 =pim1(4)*pim2(4)-pim1(1)*pim2(1)
3596  $ -pim1(2)*pim2(2)-pim1(3)*pim2(3)
3597  p1pl =pim1(4)*pipl(4)-pim1(1)*pipl(1)
3598  $ -pim1(2)*pipl(2)-pim1(3)*pipl(3)
3599  p2pl =pipl(4)*pim2(4)-pipl(1)*pim2(1)
3600  $ -pipl(2)*pim2(2)-pipl(3)*pim2(3)
3601  DO 40 i=1,3
3602  vec1(i)= (vec1(i)-prod1/xmro2*pipl(i))
3603  40 CONTINUE
3604  gnorm=sqrt(vec1(1)**2+vec1(2)**2+vec1(3)**2)
3605  DO 41 i=1,3
3606  vec1(i)= vec1(i)/gnorm
3607  41 CONTINUE
3608  vec2(1)=(vec1(2)*pipl(3)-vec1(3)*pipl(2))/sqrt(xmro2)
3609  vec2(2)=(vec1(3)*pipl(1)-vec1(1)*pipl(3))/sqrt(xmro2)
3610  vec2(3)=(vec1(1)*pipl(2)-vec1(2)*pipl(1))/sqrt(xmro2)
3611  p1vec1 =pim1(4)*vec1(4)-pim1(1)*vec1(1)
3612  $ -pim1(2)*vec1(2)-pim1(3)*vec1(3)
3613  p2vec1 =vec1(4)*pim2(4)-vec1(1)*pim2(1)
3614  $ -vec1(2)*pim2(2)-vec1(3)*pim2(3)
3615  p1vec2 =pim1(4)*vec2(4)-pim1(1)*vec2(1)
3616  $ -pim1(2)*vec2(2)-pim1(3)*vec2(3)
3617  p2vec2 =vec2(4)*pim2(4)-vec2(1)*pim2(1)
3618  $ -vec2(2)*pim2(2)-vec2(3)*pim2(3)
3619 * HADRON CURRENT
3620  fnorm=formom(xmaa,xmom)
3621  brak=0.0
3622  DO 120 jj=1,2
3623  DO 45 i=1,4
3624  IF (jj.EQ.1) THEN
3625  hadcur(i) = fnorm *(
3626  $ vec1(i)*(ampi**2*p1pl-p2pl*(p12-p1pl))
3627  $ -pim2(i)*(p2vec1*p1pl-p1vec1*p2pl)
3628  $ +pipl(i)*(p2vec1*p12 -p1vec1*(ampi**2+p2pl)) )
3629  ELSE
3630  hadcur(i) = fnorm *(
3631  $ vec2(i)*(ampi**2*p1pl-p2pl*(p12-p1pl))
3632  $ -pim2(i)*(p2vec2*p1pl-p1vec2*p2pl)
3633  $ +pipl(i)*(p2vec2*p12 -p1vec2*(ampi**2+p2pl)) )
3634  ENDIF
3635  45 CONTINUE
3636 C
3637 * CALCULATE PI-VECTORS: VECTOR AND AXIAL
3638  CALL clvec(hadcur,pn,pivec)
3639  CALL claxi(hadcur,pn,piaks)
3640  CALL clnut(hadcur,brakm,hvm)
3641 * SPIN INDEPENDENT PART OF DECAY DIFF-CROSS-SECT. IN TAU REST FRAME
3642  brak=brak+(gv**2+ga**2)*pt(4)*pivec(4) +2.*gv*ga*pt(4)*piaks(4)
3643  & +2.*(gv**2-ga**2)*amnuta*amtau*brakm
3644  DO 90 i=1,3
3645  hv(i)=hv(i)-(amtau*((gv**2+ga**2)*piaks(i)+2.*gv*ga*pivec(i)))
3646  & +(gv**2-ga**2)*amnuta*amtau*hvm(i)
3647  90 CONTINUE
3648 C HV IS DEFINED FOR TAU- WITH GAMMA=B+HV*POL
3649  120 CONTINUE
3650  amplit=(gfermi*ccabib)**2*brak/2.
3651 C THE STATISTICAL FACTOR FOR IDENTICAL PI-S WAS CANCELLED WITH
3652 C TWO, FOR TWO MODES OF A1 DECAY NAMELLY PI+PI-PI- AND PI-PI0PI0
3653 C POLARIMETER VECTOR IN TAU REST FRAME
3654  DO 91 i=1,3
3655  hv(i)=-hv(i)/brak
3656  91 CONTINUE
3657 
3658  END
3659  SUBROUTINE damppk(MNUM,PT,PN,PIM1,PIM2,PIM3,AMPLIT,HV)
3660 C ----------------------------------------------------------------------
3661 * CALCULATES DIFFERENTIAL CROSS SECTION AND POLARIMETER VECTOR
3662 * FOR TAU DECAY INTO K K pi, K pi pi.
3663 * ALL SPIN EFFECTS IN THE FULL DECAY CHAIN ARE TAKEN INTO ACCOUNT.
3664 * CALCULATIONS DONE IN TAU REST FRAME WITH Z-AXIS ALONG NEUTRINO MOMENT
3665 C MNUM DECAY MODE IDENTIFIER.
3666 C
3667 #if defined (ALEPH)
3668 C called by : DPHTRE
3669 #else
3670 C called by : DPHSAA
3671 #endif
3672 C ----------------------------------------------------------------------
3673  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
3674  * ,ampiz,ampi,amro,gamro,ama1,gama1
3675  * ,amk,amkz,amkst,gamkst
3676 C
3677  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
3678  * ,ampiz,ampi,amro,gamro,ama1,gama1
3679  * ,amk,amkz,amkst,gamkst
3680  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
3681  REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
3682  REAL HV(4),PT(4),PN(4),PIM1(4),PIM2(4),PIM3(4)
3683  REAL PAA(4),VEC1(4),VEC2(4),VEC3(4),VEC4(4),VEC5(4)
3684  REAL PIVEC(4),PIAKS(4),HVM(4)
3685  REAL FNORM(0:7),COEF(1:5,0:7)
3686  COMPLEX HADCUR(4),FORM1,FORM2,FORM3,FORM4,FORM5,UROJ
3687 #if defined (CLEO)
3688  COMPLEX F1,F2,F3,F4,F5
3689 #endif
3690  EXTERNAL form1,form2,form3,form4,form5
3691  DATA pi /3.141592653589793238462643/
3692  DATA icont /0/
3693 C
3694  DATA fpi /93.3e-3/
3695  IF (icont.EQ.0) THEN
3696  icont=1
3697  uroj=cmplx(0.0,1.0)
3698  dwapi0=sqrt(2.0)
3699  fnorm(0)=ccabib/fpi
3700  fnorm(1)=ccabib/fpi
3701  fnorm(2)=ccabib/fpi
3702  fnorm(3)=ccabib/fpi
3703  fnorm(4)=scabib/fpi/dwapi0
3704  fnorm(5)=scabib/fpi
3705  fnorm(6)=scabib/fpi
3706  fnorm(7)=ccabib/fpi
3707 C
3708  coef(1,0)= 2.0*sqrt(2.)/3.0
3709  coef(2,0)=-2.0*sqrt(2.)/3.0
3710 #if defined (CLEO)
3711 C AJW 2/98: Add in the D-wave and I=0 3pi substructure:
3712  coef(3,0)= 2.0*sqrt(2.)/3.0
3713 #else
3714  coef(3,0)= 0.0
3715 #endif
3716  coef(4,0)= fpi
3717  coef(5,0)= 0.0
3718 C
3719  coef(1,1)=-sqrt(2.)/3.0
3720  coef(2,1)= sqrt(2.)/3.0
3721  coef(3,1)= 0.0
3722  coef(4,1)= fpi
3723  coef(5,1)= sqrt(2.)
3724 C
3725  coef(1,2)=-sqrt(2.)/3.0
3726  coef(2,2)= sqrt(2.)/3.0
3727  coef(3,2)= 0.0
3728  coef(4,2)= 0.0
3729  coef(5,2)=-sqrt(2.)
3730 C
3731 #if defined (CLEO)
3732 C AJW 11/97: Add in the K*-prim-s, ala Finkemeier&Mirkes
3733  coef(1,3)= 1./3.
3734  coef(2,3)=-2./3.
3735  coef(3,3)= 2./3.
3736 #else
3737  coef(1,3)= 0.0
3738  coef(2,3)=-1.0
3739  coef(3,3)= 0.0
3740 #endif
3741  coef(4,3)= 0.0
3742  coef(5,3)= 0.0
3743 C
3744  coef(1,4)= 1.0/sqrt(2.)/3.0
3745  coef(2,4)=-1.0/sqrt(2.)/3.0
3746  coef(3,4)= 0.0
3747  coef(4,4)= 0.0
3748  coef(5,4)= 0.0
3749 C
3750  coef(1,5)=-sqrt(2.)/3.0
3751  coef(2,5)= sqrt(2.)/3.0
3752  coef(3,5)= 0.0
3753  coef(4,5)= 0.0
3754  coef(5,5)=-sqrt(2.)
3755 C
3756 #if defined (CLEO)
3757 C AJW 11/97: Add in the K*-prim-s, ala Finkemeier&Mirkes
3758  coef(1,6)= 1./3.
3759  coef(2,6)=-2./3.
3760  coef(3,6)= 2./3.
3761 #else
3762  coef(1,6)= 0.0
3763  coef(2,6)=-1.0
3764  coef(3,6)= 0.0
3765 #endif
3766  coef(4,6)= 0.0
3767  coef(5,6)=-2.0
3768 C
3769  coef(1,7)= 0.0
3770  coef(2,7)= 0.0
3771  coef(3,7)= 0.0
3772  coef(4,7)= 0.0
3773  coef(5,7)=-sqrt(2.0/3.0)
3774 C
3775  ENDIF
3776 C
3777  DO 10 i=1,4
3778  10 paa(i)=pim1(i)+pim2(i)+pim3(i)
3779  xmaa =sqrt(abs(paa(4)**2-paa(3)**2-paa(2)**2-paa(1)**2))
3780  xmro1 =sqrt(abs((pim3(4)+pim2(4))**2-(pim3(1)+pim2(1))**2
3781  $ -(pim3(2)+pim2(2))**2-(pim3(3)+pim2(3))**2))
3782  xmro2 =sqrt(abs((pim3(4)+pim1(4))**2-(pim3(1)+pim1(1))**2
3783  $ -(pim3(2)+pim1(2))**2-(pim3(3)+pim1(3))**2))
3784  xmro3 =sqrt(abs((pim1(4)+pim2(4))**2-(pim1(1)+pim2(1))**2
3785  $ -(pim1(2)+pim2(2))**2-(pim1(3)+pim2(3))**2))
3786 * ELEMENTS OF HADRON CURRENT
3787  prod1 =paa(4)*(pim2(4)-pim3(4))-paa(1)*(pim2(1)-pim3(1))
3788  $ -paa(2)*(pim2(2)-pim3(2))-paa(3)*(pim2(3)-pim3(3))
3789  prod2 =paa(4)*(pim3(4)-pim1(4))-paa(1)*(pim3(1)-pim1(1))
3790  $ -paa(2)*(pim3(2)-pim1(2))-paa(3)*(pim3(3)-pim1(3))
3791  prod3 =paa(4)*(pim1(4)-pim2(4))-paa(1)*(pim1(1)-pim2(1))
3792  $ -paa(2)*(pim1(2)-pim2(2))-paa(3)*(pim1(3)-pim2(3))
3793  DO 40 i=1,4
3794  vec1(i)= pim2(i)-pim3(i) -paa(i)*prod1/xmaa**2
3795  vec2(i)= pim3(i)-pim1(i) -paa(i)*prod2/xmaa**2
3796  vec3(i)= pim1(i)-pim2(i) -paa(i)*prod3/xmaa**2
3797  40 vec4(i)= pim1(i)+pim2(i)+pim3(i)
3798  CALL prod5(pim1,pim2,pim3,vec5)
3799 * HADRON CURRENT
3800 C be aware that sign of vec2 is opposite to sign of vec1 in a1 case
3801 #if defined (CLEO)
3802 C Rationalize this code:
3803  f1 = cmplx(coef(1,mnum))*form1(mnum,xmaa**2,xmro1**2,xmro2**2)
3804  f2 = cmplx(coef(2,mnum))*form2(mnum,xmaa**2,xmro2**2,xmro1**2)
3805  f3 = cmplx(coef(3,mnum))*form3(mnum,xmaa**2,xmro3**2,xmro1**2)
3806  f4 = (-1.0*uroj)*
3807  $cmplx(coef(4,mnum))*form4(mnum,xmaa**2,xmro1**2,xmro2**2,xmro3**2)
3808  f5 = (-1.0)*uroj/4.0/pi**2/fpi**2*
3809  $ cmplx(coef(5,mnum))*form5(mnum,xmaa**2,xmro1**2,xmro2**2)
3810 
3811  DO 45 i=1,4
3812  hadcur(i)= cmplx(fnorm(mnum)) * (
3813  $ cmplx(vec1(i))*f1+cmplx(vec2(i))*f2+cmplx(vec3(i))*f3+
3814  $ cmplx(vec4(i))*f4+cmplx(vec5(i))*f5)
3815  45 CONTINUE
3816 #else
3817  DO 45 i=1,4
3818  hadcur(i)= cmplx(fnorm(mnum)) * (
3819  $cmplx(vec1(i)*coef(1,mnum))*form1(mnum,xmaa**2,xmro1**2,xmro2**2)+
3820  $cmplx(vec2(i)*coef(2,mnum))*form2(mnum,xmaa**2,xmro2**2,xmro1**2)+
3821  $cmplx(vec3(i)*coef(3,mnum))*form3(mnum,xmaa**2,xmro3**2,xmro1**2)+
3822  *(-1.0*uroj)*
3823  $cmplx(vec4(i)*coef(4,mnum))*form4(mnum,xmaa**2,xmro1**2,
3824  $ xmro2**2,xmro3**2) +
3825  $(-1.0)*uroj/4.0/pi**2/fpi**2*
3826  $cmplx(vec5(i)*coef(5,mnum))*form5(mnum,xmaa**2,xmro1**2,xmro2**2))
3827  45 CONTINUE
3828 #endif
3829 C
3830 * CALCULATE PI-VECTORS: VECTOR AND AXIAL
3831  CALL clvec(hadcur,pn,pivec)
3832  CALL claxi(hadcur,pn,piaks)
3833  CALL clnut(hadcur,brakm,hvm)
3834 * SPIN INDEPENDENT PART OF DECAY DIFF-CROSS-SECT. IN TAU REST FRAME
3835  brak= (gv**2+ga**2)*pt(4)*pivec(4) +2.*gv*ga*pt(4)*piaks(4)
3836  & +2.*(gv**2-ga**2)*amnuta*amtau*brakm
3837  amplit=(gfermi)**2*brak/2.
3838  IF (mnum.GE.9) THEN
3839  print *, 'MNUM=',mnum
3840  znak=-1.0
3841  xm1=0.0
3842  xm2=0.0
3843  xm3=0.0
3844  DO 77 k=1,4
3845  IF (k.EQ.4) znak=1.0
3846  xm1=znak*pim1(k)**2+xm1
3847  xm2=znak*pim2(k)**2+xm2
3848  xm3=znak*pim3(k)**2+xm3
3849  77 print *, 'PIM1=',pim1(k),'PIM2=',pim2(k),'PIM3=',pim3(k)
3850  print *, 'XM1=',sqrt(xm1),'XM2=',sqrt(xm2),'XM3=',sqrt(xm3)
3851  print *, '************************************************'
3852  ENDIF
3853 C POLARIMETER VECTOR IN TAU REST FRAME
3854  DO 90 i=1,3
3855  hv(i)=-(amtau*((gv**2+ga**2)*piaks(i)+2.*gv*ga*pivec(i)))
3856  & +(gv**2-ga**2)*amnuta*amtau*hvm(i)
3857 C HV IS DEFINED FOR TAU- WITH GAMMA=B+HV*POL
3858  hv(i)=-hv(i)/brak
3859  90 CONTINUE
3860  END
3861  SUBROUTINE prod5(P1,P2,P3,PIA)
3862 C ----------------------------------------------------------------------
3863 C external product of P1, P2, P3 4-momenta.
3864 C SIGN is chosen +/- for decay of TAU +/- respectively
3865 C called by : DAMPAA, CLNUT
3866 C ----------------------------------------------------------------------
3867  COMMON / jaki / jak1,jak2,jakp,jakm,ktom
3868  COMMON / idfc / idff
3869  REAL PIA(4),P1(4),P2(4),P3(4)
3870  det2(i,j)=p1(i)*p2(j)-p2(i)*p1(j)
3871 * -----------------------------------
3872  IF (ktom.EQ.1.OR.ktom.EQ.-1) THEN
3873  sign= idff/abs(idff)
3874  ELSEIF (ktom.EQ.2) THEN
3875  sign=-idff/abs(idff)
3876  ELSE
3877  print *, 'STOP IN PROD5: KTOM=',ktom
3878  stop
3879  ENDIF
3880 C
3881 C EPSILON( p1(1), p2(2), p3(3), (4) ) = 1
3882 C
3883  pia(1)= -p3(3)*det2(2,4)+p3(4)*det2(2,3)+p3(2)*det2(3,4)
3884  pia(2)= -p3(4)*det2(1,3)+p3(3)*det2(1,4)-p3(1)*det2(3,4)
3885  pia(3)= p3(4)*det2(1,2)-p3(2)*det2(1,4)+p3(1)*det2(2,4)
3886  pia(4)= p3(3)*det2(1,2)-p3(2)*det2(1,3)+p3(1)*det2(2,3)
3887 C ALL FOUR INDICES ARE UP SO PIA(3) AND PIA(4) HAVE SAME SIGN
3888  DO 20 i=1,4
3889  20 pia(i)=pia(i)*sign
3890  END
3891 
3892  SUBROUTINE dexnew(MODE,ISGN,POL,PNU,PAA,PNPI,JNPI)
3893 C ----------------------------------------------------------------------
3894 * THIS SIMULATES TAU DECAY IN TAU REST FRAME
3895 * INTO NU A1, NEXT A1 DECAYS INTO RHO PI AND FINALLY RHO INTO PI PI.
3896 * OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
3897 #if defined (ALEPH)
3898 * PAA hadron 4-vector
3899 * PNPI final state particles
3900 * JNPI decay type
3901 #else
3902 * PAA A1
3903 * PIM1 PION MINUS (OR PI0) 1 (FOR TAU MINUS)
3904 * PIM2 PION MINUS (OR PI0) 2
3905 * PIPL PION PLUS (OR PI-)
3906 * (PIPL,PIM1) FORM A RHO
3907 #endif
3908 C ----------------------------------------------------------------------
3909  COMMON / inout / inut,iout
3910  REAL POL(4),HV(4),PAA(4),PNU(4),PNPI(4,9),RN(1)
3911  DATA iwarm/0/
3912 C
3913  IF(mode.EQ.-1) THEN
3914 C ===================
3915  iwarm=1
3916  CALL dadnew( -1,isgn,hv,pnu,paa,pnpi,jdumm)
3917 #if defined (ALEPH)
3918 CC CALL HBOOK1(816,'WEIGHT DISTRIBUTION DEXNEW $',100,-2.,2.)
3919 #else
3920 CC CALL HBOOK1(816,'WEIGHT DISTRIBUTION DEXAA $',100,-2.,2.)
3921 #endif
3922 C
3923  ELSEIF(mode.EQ. 0) THEN
3924 * =======================
3925  300 CONTINUE
3926  IF(iwarm.EQ.0) GOTO 902
3927  CALL dadnew( 0,isgn,hv,pnu,paa,pnpi,jnpi)
3928  wt=(1+pol(1)*hv(1)+pol(2)*hv(2)+pol(3)*hv(3))/2.
3929 CC CALL HFILL(816,WT)
3930  CALL ranmar(rn,1)
3931  IF(rn(1).GT.wt) GOTO 300
3932 C
3933  ELSEIF(mode.EQ. 1) THEN
3934 * =======================
3935  CALL dadnew( 1,isgn,hv,pnu,paa,pnpi,jdumm)
3936 CC CALL HPRINT(816)
3937  ENDIF
3938 C =====
3939  RETURN
3940  902 WRITE(iout, 9020)
3941  9020 FORMAT(' ----- DEXNEW: LACK OF INITIALISATION')
3942  stop
3943  END
3944  SUBROUTINE dadnew(MODE,ISGN,HV,PNU,PWB,PNPI,JNPI)
3945 C ----------------------------------------------------------------------
3946  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
3947  * ,ampiz,ampi,amro,gamro,ama1,gama1
3948  * ,amk,amkz,amkst,gamkst
3949 C
3950  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
3951  * ,ampiz,ampi,amro,gamro,ama1,gama1
3952  * ,amk,amkz,amkst,gamkst
3953  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
3954  REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
3955  COMMON / taubmc / gampmc(30),gamper(30),nevdec(30)
3956  REAL*4 GAMPMC ,GAMPER
3957 #if defined (ALEPH)
3958 #else
3959  COMMON / inout / inut,iout
3960 #endif
3961  parameter(nmode=15,nm1=0,nm2=1,nm3=8,nm4=2,nm5=1,nm6=3)
3962 #if defined (ALEPH)
3963  COMMON / taudcd /idffin(9,nmode),mulpik(nmode)
3964 #else
3965  COMMON / taudcd /idffin(9,nmode),mulpik(nmode)
3966 #endif
3967  & ,names
3968  CHARACTER NAMES(NMODE)*31
3969 #if defined (ALEPH)
3970  COMMON / inout / inut,iout
3971 #endif
3972 
3973  REAL*4 PNU(4),PWB(4),PNPI(4,9),HV(4),HHV(4)
3974  REAL*4 PDUM1(4),PDUM2(4),PDUMI(4,9)
3975  REAL*4 RRR(3)
3976  REAL*4 WTMAX(NMODE)
3977  REAL*8 SWT(NMODE),SSWT(NMODE)
3978  dimension nevraw(nmode),nevovr(nmode),nevacc(nmode)
3979 C
3980  DATA pi /3.141592653589793238462643/
3981  DATA iwarm/0/
3982 C
3983  IF(mode.EQ.-1) THEN
3984 C ===================
3985 C -- AT THE MOMENT ONLY TWO DECAY MODES OF MULTIPIONS HAVE M. ELEM
3986  nmod=nmode
3987  iwarm=1
3988 C PRINT 7003
3989  DO 1 jnpi=1,nmod
3990  nevraw(jnpi)=0
3991  nevacc(jnpi)=0
3992  nevovr(jnpi)=0
3993  swt(jnpi)=0
3994  sswt(jnpi)=0
3995  wtmax(jnpi)=-1.
3996 #if defined (CePeCe)
3997  DO i=1,500
3998 #elif defined (ALEPH)
3999  DO i=1,500
4000 #else
4001 C for 4pi phase space, need lots more trials at initialization,
4002 C or use the WTMAX determined with many trials for default model:
4003  ntrials = 500
4004  IF (jnpi.LE.nm4) THEN
4005  a = pkorb(3,37+jnpi)
4006  IF (a.LT.0.) THEN
4007  ntrials = 10000
4008  ELSE
4009  ntrials = 0
4010  wtmax(jnpi)=a
4011  END IF
4012  END IF
4013  DO i=1,ntrials
4014 #endif
4015  IF (jnpi.LE.0) THEN
4016  GOTO 903
4017  ELSEIF(jnpi.LE.nm4) THEN
4018  CALL dph4pi(wt,hv,pdum1,pdum2,pdumi,jnpi)
4019  ELSEIF(jnpi.LE.nm4+nm5) THEN
4020  CALL dph5pi(wt,hv,pdum1,pdum2,pdumi,jnpi)
4021  ELSEIF(jnpi.LE.nm4+nm5+nm6) THEN
4022  CALL dphnpi(wt,hv,pdum1,pdum2,pdumi,jnpi)
4023  ELSEIF(jnpi.LE.nm4+nm5+nm6+nm3) THEN
4024  inum=jnpi-nm4-nm5-nm6
4025  CALL dphspk(wt,hv,pdum1,pdum2,pdumi,inum)
4026  ELSEIF(jnpi.LE.nm4+nm5+nm6+nm3+nm2) THEN
4027  inum=jnpi-nm4-nm5-nm6-nm3
4028  CALL dphsrk(wt,hv,pdum1,pdum2,pdumi,inum)
4029  ELSE
4030  GOTO 903
4031  ENDIF
4032  IF(wt.GT.wtmax(jnpi)/1.2) wtmax(jnpi)=wt*1.2
4033  ENDDO
4034 #if defined (CePeCe)
4035 #elif defined (ALEPH)
4036 #else
4037 C PRINT *,' DADNEW JNPI,NTRIALS,WTMAX =',JNPI,NTRIALS,WTMAX(JNPI)
4038 #endif
4039 C CALL HBOOK1(801,'WEIGHT DISTRIBUTION DADNPI $',100,0.,2.,.0)
4040 C PRINT 7004,WTMAX(JNPI)
4041 1 CONTINUE
4042  WRITE(iout,7005)
4043 C
4044  ELSEIF(mode.EQ. 0) THEN
4045 C =======================
4046  IF(iwarm.EQ.0) GOTO 902
4047 C
4048 300 CONTINUE
4049  IF (jnpi.LE.0) THEN
4050  GOTO 903
4051  ELSEIF(jnpi.LE.nm4) THEN
4052  CALL dph4pi(wt,hhv,pnu,pwb,pnpi,jnpi)
4053  ELSEIF(jnpi.LE.nm4+nm5) THEN
4054  CALL dph5pi(wt,hhv,pnu,pwb,pnpi,jnpi)
4055  ELSEIF(jnpi.LE.nm4+nm5+nm6) THEN
4056  CALL dphnpi(wt,hhv,pnu,pwb,pnpi,jnpi)
4057  ELSEIF(jnpi.LE.nm4+nm5+nm6+nm3) THEN
4058  inum=jnpi-nm4-nm5-nm6
4059  CALL dphspk(wt,hhv,pnu,pwb,pnpi,inum)
4060  ELSEIF(jnpi.LE.nm4+nm5+nm6+nm3+nm2) THEN
4061  inum=jnpi-nm4-nm5-nm6-nm3
4062  CALL dphsrk(wt,hhv,pnu,pwb,pnpi,inum)
4063  ELSE
4064  GOTO 903
4065  ENDIF
4066  DO i=1,4
4067  hv(i)=-isgn*hhv(i)
4068  ENDDO
4069 C CALL HFILL(801,WT/WTMAX(JNPI))
4070  nevraw(jnpi)=nevraw(jnpi)+1
4071  swt(jnpi)=swt(jnpi)+wt
4072 #if defined (ALEPH)
4073  sswt(jnpi)=sswt(jnpi)+wt**2
4074 #else
4075 cccM.S.>>>>>>
4076 cc SSWT(JNPI)=SSWT(JNPI)+WT**2
4077  sswt(jnpi)=sswt(jnpi)+dble(wt)**2
4078 cccM.S.<<<<<<
4079 #endif
4080  CALL ranmar(rrr,3)
4081  rn=rrr(1)
4082  IF(wt.GT.wtmax(jnpi)) nevovr(jnpi)=nevovr(jnpi)+1
4083  IF(rn*wtmax(jnpi).GT.wt) GOTO 300
4084 C ROTATIONS TO BASIC TAU REST FRAME
4085  costhe=-1.+2.*rrr(2)
4086  thet=acos(costhe)
4087  phi =2*pi*rrr(3)
4088  CALL rotor2(thet,pnu,pnu)
4089  CALL rotor3( phi,pnu,pnu)
4090  CALL rotor2(thet,pwb,pwb)
4091  CALL rotor3( phi,pwb,pwb)
4092  CALL rotor2(thet,hv,hv)
4093  CALL rotor3( phi,hv,hv)
4094  nd=mulpik(jnpi)
4095  DO 301 i=1,nd
4096  CALL rotor2(thet,pnpi(1,i),pnpi(1,i))
4097  CALL rotor3( phi,pnpi(1,i),pnpi(1,i))
4098 301 CONTINUE
4099  nevacc(jnpi)=nevacc(jnpi)+1
4100 C
4101  ELSEIF(mode.EQ. 1) THEN
4102 C =======================
4103  DO 500 jnpi=1,nmod
4104  IF(nevraw(jnpi).EQ.0) GOTO 500
4105  pargam=swt(jnpi)/float(nevraw(jnpi)+1)
4106  error=0
4107  IF(nevraw(jnpi).NE.0)
4108  & error=sqrt(sswt(jnpi)/swt(jnpi)**2-1./float(nevraw(jnpi)))
4109  rat=pargam/gamel
4110  WRITE(iout, 7010) names(jnpi),
4111  & nevraw(jnpi),nevacc(jnpi),nevovr(jnpi),pargam,rat,error
4112 CC CALL HPRINT(801)
4113  gampmc(8+jnpi-1)=rat
4114  gamper(8+jnpi-1)=error
4115 CAM NEVDEC(8+JNPI-1)=NEVACC(JNPI)
4116  500 CONTINUE
4117  ENDIF
4118 C =====
4119  RETURN
4120  7003 FORMAT(///1x,15(5h*****)
4121  $ /,' *', 25x,'******** DADNEW INITIALISATION ********',9x,1h*
4122  $ )
4123  7004 FORMAT(' *',e20.5,5x,'WTMAX = MAXIMUM WEIGHT ',9x,1h*/)
4124  7005 FORMAT(
4125  $ /,1x,15(5h*****)/)
4126  7010 FORMAT(///1x,15(5h*****)
4127  $ /,' *', 25x,'******** DADNEW FINAL REPORT ******** ',9x,1h*
4128  $ /,' *', 25x,'CHANNEL:',a31 ,9x,1h*
4129  $ /,' *',i20 ,5x,'NEVRAW = NO. OF DECAYS TOTAL ',9x,1h*
4130  $ /,' *',i20 ,5x,'NEVACC = NO. OF DECAYS ACCEPTED ',9x,1h*
4131  $ /,' *',i20 ,5x,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9x,1h*
4132  $ /,' *',e20.5,5x,'PARTIAL WTDTH IN GEV UNITS ',9x,1h*
4133  $ /,' *',f20.9,5x,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',9x,1h*
4134  $ /,' *',f20.8,5x,'RELATIVE ERROR OF PARTIAL WIDTH ',9x,1h*
4135  $ /,1x,15(5h*****)/)
4136  902 WRITE(iout, 9020)
4137  9020 FORMAT(' ----- DADNEW: LACK OF INITIALISATION')
4138  stop
4139  903 WRITE(iout, 9030) jnpi,mode
4140  9030 FORMAT(' ----- DADNEW: WRONG JNPI',2i5)
4141  stop
4142  END
4143 
4144 
4145  SUBROUTINE dph4pi(DGAMT,HV,PN,PAA,PMULT,JNPI)
4146 C ----------------------------------------------------------------------
4147 #if defined (ALEPH)
4148 * IT SIMULATES 4pi DECAY IN TAU REST FRAME WITH
4149 * Z-AXIS ALONG 4pi MOMENTUM
4150 #else
4151 * IT SIMULATES A1 DECAY IN TAU REST FRAME WITH
4152 * Z-AXIS ALONG A1 MOMENTUM
4153 #endif
4154 C ----------------------------------------------------------------------
4155  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
4156  * ,ampiz,ampi,amro,gamro,ama1,gama1
4157  * ,amk,amkz,amkst,gamkst
4158 C
4159  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
4160  * ,ampiz,ampi,amro,gamro,ama1,gama1
4161  * ,amk,amkz,amkst,gamkst
4162  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
4163  REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
4164 #if defined (ALEPH)
4165  parameter(nmode=15,nm1=0,nm2=1,nm3=8,nm4=2,nm5=1,nm6=3)
4166  COMMON / taudcd /idffin(9,nmode),mulpik(nmode)
4167  & ,names
4168  CHARACTER NAMES(NMODE)*31
4169 #else
4170 #endif
4171  REAL HV(4),PT(4),PN(4),PAA(4),PIM1(4),PIM2(4),PIPL(4),PMULT(4,9)
4172  REAL PR(4),PIZ(4)
4173  REAL*4 RRR(9)
4174  REAL*8 UU,FF,FF1,FF2,FF3,FF4,GG1,GG2,GG3,GG4,RR
4175  DATA pi /3.141592653589793238462643/
4176  DATA icont /0/
4177  xlam(x,y,z)=sqrt(abs((x-y-z)**2-4.0*y*z))
4178 C AMRO, GAMRO IS ONLY A PARAMETER FOR GETING HIGHT EFFICIENCY
4179 C
4180 C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
4181 C D**3 P /2E/(2PI)**3 (2PI)**4 DELTA4(SUM P)
4182  phspac=1./2**23/pi**11
4183  phsp=1./2**5/pi**2
4184 #if defined (ALEPH)
4185 C init decay mode JNPI
4186  amp1=dcdmas(idffin(1,jnpi))
4187  amp2=dcdmas(idffin(2,jnpi))
4188  amp3=dcdmas(idffin(3,jnpi))
4189  amp4=dcdmas(idffin(4,jnpi))
4190 #endif
4191  IF (jnpi.EQ.1) THEN
4192  prez=0.7
4193 #if defined (CePeCe)
4194  amp1=ampi
4195  amp2=ampi
4196  amp3=ampi
4197  amp4=ampiz
4198  amrx=0.782
4199  gamrx=0.0084
4200 #elif defined (CLEO)
4201  amp1=ampi
4202  amp2=ampi
4203  amp3=ampi
4204  amp4=ampiz
4205  amrx=pkorb(1,14)
4206  gamrx=pkorb(2,14)
4207 C AJW: cant simply change AMROP, etc, here!
4208 C CHOICE is a by-hand tuning/optimization, no simple relationship
4209 C to actual resonance masses (accd to Z.Was).
4210 C What matters in the end is what you put in formf/curr .
4211 #else
4212  amrx=0.782
4213  gamrx=0.0084
4214 #endif
4215  amrop =1.2
4216  gamrop=.46
4217  ELSE
4218  prez=0.0
4219 #if defined (ALEPH)
4220 #else
4221  amp1=ampiz
4222  amp2=ampiz
4223  amp3=ampiz
4224  amp4=ampi
4225 #endif
4226  amrx=1.4
4227  gamrx=.6
4228  amrop =amrx
4229  gamrop=gamrx
4230 
4231  ENDIF
4232 #if defined (ALEPH)
4233 ! 07.06.96 here was an error in the type of variable.
4234  rrdum=0.3
4235  CALL choice(100+jnpi,rrdum,ichan,prob1,prob2,prob3,
4236 #else
4237  rrb=0.3
4238  CALL choice(100+jnpi,rrb,ichan,prob1,prob2,prob3,
4239 #endif
4240  $ amrop,gamrop,amrx,gamrx,amrb,gamrb)
4241  prez=prob1+prob2
4242 C TAU MOMENTUM
4243  pt(1)=0.
4244  pt(2)=0.
4245  pt(3)=0.
4246  pt(4)=amtau
4247 C
4248  CALL ranmar(rrr,9)
4249 C
4250 * MASSES OF 4, 3 AND 2 PI SYSTEMS
4251 C 3 PI WITH SAMPLING FOR RESONANCE
4252 CAM
4253  rr1=rrr(6)
4254  ams1=(amp1+amp2+amp3+amp4)**2
4255  ams2=(amtau-amnuta)**2
4256  alp1=atan((ams1-amrop**2)/amrop/gamrop)
4257  alp2=atan((ams2-amrop**2)/amrop/gamrop)
4258  alp=alp1+rr1*(alp2-alp1)
4259  am4sq =amrop**2+amrop*gamrop*tan(alp)
4260  am4 =sqrt(am4sq)
4261  phspac=phspac*
4262  $ ((am4sq-amrop**2)**2+(amrop*gamrop)**2)/(amrop*gamrop)
4263  phspac=phspac*(alp2-alp1)
4264 
4265 C
4266  rr1=rrr(1)
4267  ams1=(amp2+amp3+amp4)**2
4268  ams2=(am4-amp1)**2
4269  IF (rrr(9).GT.prez) THEN
4270  am3sq=ams1+ rr1*(ams2-ams1)
4271  am3 =sqrt(am3sq)
4272 C --- this part of jacobian will be recovered later
4273  ff1=ams2-ams1
4274  ELSE
4275 * PHASE SPACE WITH SAMPLING FOR OMEGA RESONANCE,
4276  alp1=atan((ams1-amrx**2)/amrx/gamrx)
4277  alp2=atan((ams2-amrx**2)/amrx/gamrx)
4278  alp=alp1+rr1*(alp2-alp1)
4279  am3sq =amrx**2+amrx*gamrx*tan(alp)
4280  am3 =sqrt(am3sq)
4281 C --- THIS PART OF THE JACOBIAN WILL BE RECOVERED LATER ---------------
4282  ff1=((am3sq-amrx**2)**2+(amrx*gamrx)**2)/(amrx*gamrx)
4283  ff1=ff1*(alp2-alp1)
4284  ENDIF
4285 C MASS OF 2
4286  rr2=rrr(2)
4287  ams1=(amp3+amp4)**2
4288  ams2=(am3-amp2)**2
4289 * FLAT PHASE SPACE;
4290  am2sq=ams1+ rr2*(ams2-ams1)
4291  am2 =sqrt(am2sq)
4292 C --- this part of jacobian will be recovered later
4293  ff2=(ams2-ams1)
4294 * 2 RESTFRAME, DEFINE PIZ AND PIPL
4295 #if defined (ALEPH)
4296  enq1=(am2sq+amp3**2-amp4**2)/(2*am2)
4297  enq2=(am2sq-amp3**2+amp4**2)/(2*am2)
4298  ppi= enq1**2-amp3**2
4299  pppi=sqrt(abs(enq1**2-amp3**2))
4300 #else
4301  enq1=(am2sq-amp3**2+amp4**2)/(2*am2)
4302  enq2=(am2sq+amp3**2-amp4**2)/(2*am2)
4303  ppi= enq1**2-amp4**2
4304  pppi=sqrt(abs(enq1**2-amp4**2))
4305 #endif
4306  phspac=phspac*(4*pi)*(2*pppi/am2)
4307 #if defined (ALEPH)
4308 * PIZ momentum in 2 rest frame (PIZ is 3rd pi)
4309 #else
4310 * PIZ MOMENTUM IN 2 REST FRAME
4311 #endif
4312  CALL sphera(pppi,piz)
4313  piz(4)=enq1
4314 #if defined (ALEPH)
4315 C PIPL momentum in 2 rest frame (PIPL is 4th pi)
4316 #else
4317 * PIPL MOMENTUM IN 2 REST FRAME
4318 #endif
4319  DO 30 i=1,3
4320  30 pipl(i)=-piz(i)
4321  pipl(4)=enq2
4322 * 3 REST FRAME, DEFINE PIM1
4323 #if defined (ALEPH)
4324 C PR momentum
4325 #else
4326 * PR MOMENTUM
4327 #endif
4328  pr(1)=0
4329  pr(2)=0
4330  pr(4)=1./(2*am3)*(am3**2+am2**2-amp2**2)
4331  pr(3)= sqrt(abs(pr(4)**2-am2**2))
4332  ppi = pr(4)**2-am2**2
4333 #if defined (ALEPH)
4334 C PIM1 momentum
4335 #else
4336 * PIM1 MOMENTUM
4337 #endif
4338  pim1(1)=0
4339  pim1(2)=0
4340  pim1(4)=1./(2*am3)*(am3**2-am2**2+amp2**2)
4341  pim1(3)=-pr(3)
4342 C --- this part of jacobian will be recovered later
4343  ff3=(4*pi)*(2*pr(3)/am3)
4344 * OLD PIONS BOOSTED FROM 2 REST FRAME TO 3 REST FRAME
4345  exe=(pr(4)+pr(3))/am2
4346  CALL bostr3(exe,piz,piz)
4347  CALL bostr3(exe,pipl,pipl)
4348  rr3=rrr(3)
4349  rr4=rrr(4)
4350  thet =acos(-1.+2*rr3)
4351  phi = 2*pi*rr4
4352  CALL rotpol(thet,phi,pipl)
4353  CALL rotpol(thet,phi,pim1)
4354  CALL rotpol(thet,phi,piz)
4355  CALL rotpol(thet,phi,pr)
4356 #if defined (ALEPH)
4357 C 4 rest frame, define PIM2
4358 C PR momentum
4359 #else
4360 * 4 REST FRAME, DEFINE PIM2
4361 * PR MOMENTUM
4362 #endif
4363  pr(1)=0
4364  pr(2)=0
4365  pr(4)=1./(2*am4)*(am4**2+am3**2-amp1**2)
4366  pr(3)= sqrt(abs(pr(4)**2-am3**2))
4367  ppi = pr(4)**2-am3**2
4368 #if defined (ALEPH)
4369 C PIM2 momentum
4370 #else
4371 * PIM2 MOMENTUM
4372 #endif
4373  pim2(1)=0
4374  pim2(2)=0
4375  pim2(4)=1./(2*am4)*(am4**2-am3**2+amp1**2)
4376  pim2(3)=-pr(3)
4377 C --- this part of jacobian will be recovered later
4378  ff4=(4*pi)*(2*pr(3)/am4)
4379 * OLD PIONS BOOSTED FROM 3 REST FRAME TO 4 REST FRAME
4380  exe=(pr(4)+pr(3))/am3
4381  CALL bostr3(exe,piz,piz)
4382  CALL bostr3(exe,pipl,pipl)
4383  CALL bostr3(exe,pim1,pim1)
4384  rr3=rrr(7)
4385  rr4=rrr(8)
4386  thet =acos(-1.+2*rr3)
4387  phi = 2*pi*rr4
4388  CALL rotpol(thet,phi,pipl)
4389  CALL rotpol(thet,phi,pim1)
4390  CALL rotpol(thet,phi,pim2)
4391  CALL rotpol(thet,phi,piz)
4392  CALL rotpol(thet,phi,pr)
4393 C
4394 * NOW TO THE TAU REST FRAME, DEFINE PAA AND NEUTRINO MOMENTA
4395 * PAA MOMENTUM
4396  paa(1)=0
4397  paa(2)=0
4398  paa(4)=1./(2*amtau)*(amtau**2-amnuta**2+am4**2)
4399  paa(3)= sqrt(abs(paa(4)**2-am4**2))
4400  ppi = paa(4)**2-am4**2
4401  phspac=phspac*(4*pi)*(2*paa(3)/amtau)
4402  phsp=phsp*(4*pi)*(2*paa(3)/amtau)
4403 * TAU-NEUTRINO MOMENTUM
4404  pn(1)=0
4405  pn(2)=0
4406  pn(4)=1./(2*amtau)*(amtau**2+amnuta**2-am4**2)
4407  pn(3)=-paa(3)
4408 C ZBW 20.12.2002 bug fix
4409  IF(rrr(9).LE.0.5*prez) THEN
4410  DO 72 i=1,4
4411  x=pim1(i)
4412  pim1(i)=pim2(i)
4413  72 pim2(i)=x
4414  ENDIF
4415 C end of bug fix
4416 C WE INCLUDE REMAINING PART OF THE JACOBIAN
4417 C --- FLAT CHANNEL
4418  am3sq=(pim1(4)+piz(4)+pipl(4))**2-(pim1(3)+piz(3)+pipl(3))**2
4419  $ -(pim1(2)+piz(2)+pipl(2))**2-(pim1(1)+piz(1)+pipl(1))**2
4420  ams2=(am4-amp2)**2
4421  ams1=(amp1+amp3+amp4)**2
4422  ff1=(ams2-ams1)
4423  ams1=(amp3+amp4)**2
4424  ams2=(sqrt(am3sq)-amp1)**2
4425  ff2=ams2-ams1
4426  ff3=(4*pi)*(xlam(am2**2,amp1**2,am3sq)/am3sq)
4427  ff4=(4*pi)*(xlam(am3sq,amp2**2,am4**2)/am4**2)
4428  uu=ff1*ff2*ff3*ff4
4429 C --- FIRST CHANNEL
4430  am3sq=(pim1(4)+piz(4)+pipl(4))**2-(pim1(3)+piz(3)+pipl(3))**2
4431  $ -(pim1(2)+piz(2)+pipl(2))**2-(pim1(1)+piz(1)+pipl(1))**2
4432  ams2=(am4-amp2)**2
4433  ams1=(amp1+amp3+amp4)**2
4434  alp1=atan((ams1-amrx**2)/amrx/gamrx)
4435  alp2=atan((ams2-amrx**2)/amrx/gamrx)
4436  ff1=((am3sq-amrx**2)**2+(amrx*gamrx)**2)/(amrx*gamrx)
4437  ff1=ff1*(alp2-alp1)
4438  ams1=(amp3+amp4)**2
4439  ams2=(sqrt(am3sq)-amp1)**2
4440  ff2=ams2-ams1
4441  ff3=(4*pi)*(xlam(am2**2,amp1**2,am3sq)/am3sq)
4442  ff4=(4*pi)*(xlam(am3sq,amp2**2,am4**2)/am4**2)
4443  ff=ff1*ff2*ff3*ff4
4444 C --- SECOND CHANNEL
4445  am3sq=(pim2(4)+piz(4)+pipl(4))**2-(pim2(3)+piz(3)+pipl(3))**2
4446  $ -(pim2(2)+piz(2)+pipl(2))**2-(pim2(1)+piz(1)+pipl(1))**2
4447  ams2=(am4-amp1)**2
4448  ams1=(amp2+amp3+amp4)**2
4449  alp1=atan((ams1-amrx**2)/amrx/gamrx)
4450  alp2=atan((ams2-amrx**2)/amrx/gamrx)
4451  gg1=((am3sq-amrx**2)**2+(amrx*gamrx)**2)/(amrx*gamrx)
4452  gg1=gg1*(alp2-alp1)
4453  ams1=(amp3+amp4)**2
4454  ams2=(sqrt(am3sq)-amp2)**2
4455  gg2=ams2-ams1
4456  gg3=(4*pi)*(xlam(am2**2,amp2**2,am3sq)/am3sq)
4457  gg4=(4*pi)*(xlam(am3sq,amp1**2,am4**2)/am4**2)
4458  gg=gg1*gg2*gg3*gg4
4459 C --- JACOBIAN AVERAGED OVER THE TWO
4460  IF ( ( (ff+gg)*uu+ff*gg ).GT.0.0d0) THEN
4461  rr=ff*gg*uu/(0.5*prez*(ff+gg)*uu+(1.0-prez)*ff*gg)
4462  phspac=phspac*rr
4463  ELSE
4464  phspac=0.0
4465  ENDIF
4466 * MOMENTA OF THE TWO PI-MINUS ARE RANDOMLY SYMMETRISED
4467  IF (jnpi.EQ.1) THEN
4468  rr5= rrr(5)
4469  IF(rr5.LE.0.5) THEN
4470  DO 70 i=1,4
4471  x=pim1(i)
4472  pim1(i)=pim2(i)
4473  70 pim2(i)=x
4474  ENDIF
4475  phspac=phspac/2.
4476  ELSE
4477 C MOMENTA OF PI0-S ARE GENERATED UNIFORMLY ONLY IF PREZ=0.0
4478  rr5= rrr(5)
4479  IF(rr5.LE.0.5) THEN
4480  DO 71 i=1,4
4481  x=pim1(i)
4482  pim1(i)=pim2(i)
4483  71 pim2(i)=x
4484  ENDIF
4485  phspac=phspac/6.
4486  ENDIF
4487 * ALL PIONS BOOSTED FROM 4 REST FRAME TO TAU REST FRAME
4488 * Z-AXIS ANTIPARALLEL TO NEUTRINO MOMENTUM
4489  exe=(paa(4)+paa(3))/am4
4490  CALL bostr3(exe,piz,piz)
4491  CALL bostr3(exe,pipl,pipl)
4492  CALL bostr3(exe,pim1,pim1)
4493  CALL bostr3(exe,pim2,pim2)
4494  CALL bostr3(exe,pr,pr)
4495 C PARTIAL WIDTH CONSISTS OF PHASE SPACE AND AMPLITUDE
4496 C CHECK ON CONSISTENCY WITH DADNPI, THEN, CODE BREAKES UNIFORM PION
4497 C DISTRIBUTION IN HADRONIC SYSTEM
4498 #if defined (ALEPH)
4499  CALL dam4pi(jnpi,pt,pn,pim1,pim2,piz,pipl,amplit,hv)
4500 #else
4501 CAM Assume neutrino mass=0. and sum over final polarisation
4502 C AMX2=AM4**2
4503 C BRAK= 2*(AMTAU**2-AMX2) * (AMTAU**2+2.*AMX2)
4504 C AMPLIT=CCABIB**2*GFERMI**2/2. * BRAK * AMX2*SIGEE(AMX2,1)
4505  IF (jnpi.EQ.1) THEN
4506  CALL dam4pi(jnpi,pt,pn,pim1,pim2,piz,pipl,amplit,hv)
4507  ELSEIF (jnpi.EQ.2) THEN
4508  CALL dam4pi(jnpi,pt,pn,pim1,pim2,pipl,piz,amplit,hv)
4509  ENDIF
4510 #endif
4511  dgamt=1/(2.*amtau)*amplit*phspac
4512 C PHASE SPACE CHECK
4513 C DGAMT=PHSPAC
4514  DO 77 k=1,4
4515  pmult(k,1)=pim1(k)
4516  pmult(k,2)=pim2(k)
4517 #if defined (ALEPH)
4518  pmult(k,3)=piz(k)
4519  pmult(k,4)=pipl(k)
4520 #else
4521  pmult(k,3)=pipl(k)
4522  pmult(k,4)=piz(k)
4523 #endif
4524  77 CONTINUE
4525  END
4526  SUBROUTINE dam4pi(MNUM,PT,PN,PIM1,PIM2,PIM3,PIM4,AMPLIT,HV)
4527 C ----------------------------------------------------------------------
4528 * CALCULATES DIFFERENTIAL CROSS SECTION AND POLARIMETER VECTOR
4529 * FOR TAU DECAY INTO 4 PI MODES
4530 * ALL SPIN EFFECTS IN THE FULL DECAY CHAIN ARE TAKEN INTO ACCOUNT.
4531 * CALCULATIONS DONE IN TAU REST FRAME WITH Z-AXIS ALONG NEUTRINO MOMENT
4532 C MNUM DECAY MODE IDENTIFIER.
4533 C
4534 #if defined (ALEPH)
4535 C called by : DPH4PI
4536 #else
4537 C called by : DPHSAA
4538 #endif
4539 C ----------------------------------------------------------------------
4540  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
4541  * ,ampiz,ampi,amro,gamro,ama1,gama1
4542  * ,amk,amkz,amkst,gamkst
4543 C
4544  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
4545  * ,ampiz,ampi,amro,gamro,ama1,gama1
4546  * ,amk,amkz,amkst,gamkst
4547  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
4548  REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
4549  REAL HV(4),PT(4),PN(4),PIM1(4),PIM2(4),PIM3(4),PIM4(4)
4550  REAL PIVEC(4),PIAKS(4),HVM(4)
4551  COMPLEX HADCUR(4),FORM1,FORM2,FORM3,FORM4,FORM5
4552  EXTERNAL form1,form2,form3,form4,form5
4553  DATA pi /3.141592653589793238462643/
4554  DATA icont /0/
4555 C
4556 #if defined (CLEO)
4557  CALL curr_cleo(mnum,pim1,pim2,pim3,pim4,hadcur)
4558 #else
4559  CALL curr(mnum,pim1,pim2,pim3,pim4,hadcur)
4560 #endif
4561 C
4562 * CALCULATE PI-VECTORS: VECTOR AND AXIAL
4563  CALL clvec(hadcur,pn,pivec)
4564  CALL claxi(hadcur,pn,piaks)
4565  CALL clnut(hadcur,brakm,hvm)
4566 * SPIN INDEPENDENT PART OF DECAY DIFF-CROSS-SECT. IN TAU REST FRAME
4567  brak= (gv**2+ga**2)*pt(4)*pivec(4) +2.*gv*ga*pt(4)*piaks(4)
4568  & +2.*(gv**2-ga**2)*amnuta*amtau*brakm
4569  amplit=(ccabib*gfermi)**2*brak/2.
4570 C POLARIMETER VECTOR IN TAU REST FRAME
4571  DO 90 i=1,3
4572  hv(i)=-(amtau*((gv**2+ga**2)*piaks(i)+2.*gv*ga*pivec(i)))
4573  & +(gv**2-ga**2)*amnuta*amtau*hvm(i)
4574 C HV IS DEFINED FOR TAU- WITH GAMMA=B+HV*POL
4575  IF (brak.NE.0.0)
4576  &hv(i)=-hv(i)/brak
4577  90 CONTINUE
4578  END
4579  SUBROUTINE dph5pi(DGAMT,HV,PN,PAA,PMULT,JNPI)
4580 C ----------------------------------------------------------------------
4581 * IT SIMULATES 5pi DECAY IN TAU REST FRAME WITH
4582 * Z-AXIS ALONG 5pi MOMENTUM
4583 C ----------------------------------------------------------------------
4584  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
4585  * ,ampiz,ampi,amro,gamro,ama1,gama1
4586  * ,amk,amkz,amkst,gamkst
4587 C
4588  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
4589  * ,ampiz,ampi,amro,gamro,ama1,gama1
4590 
4591 
4592  * ,amk,amkz,amkst,gamkst
4593  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
4594  REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
4595  parameter(nmode=15,nm1=0,nm2=1,nm3=8,nm4=2,nm5=1,nm6=3)
4596 #if defined (ALEPH)
4597  COMMON / taudcd /idffin(9,nmode),mulpik(nmode)
4598 #else
4599  COMMON / taudcd /idffin(9,nmode),mulpik(nmode)
4600 #endif
4601  & ,names
4602  CHARACTER NAMES(NMODE)*31
4603  REAL HV(4),PT(4),PN(4),PAA(4),PMULT(4,9)
4604  REAL*4 PR(4),PI1(4),PI2(4),PI3(4),PI4(4),PI5(4)
4605  REAL*8 AMP1,AMP2,AMP3,AMP4,AMP5,ams1,ams2,amom,gamom
4606  REAL*8 AM5SQ,AM4SQ,AM3SQ,AM2SQ,AM5,AM4,AM3
4607  REAL*4 RRR(10)
4608  REAL*8 gg1,gg2,gg3,ff1,ff2,ff3,ff4,alp,alp1,alp2
4609 #if defined (ALEPH)
4610  REAL*8 XM,AM,GAMMAB
4611 #else
4612  REAL*8 XM,AM,GAMMA
4613 ccM.S.>>>>>>
4614  real*8 phspac
4615 ccM.S.<<<<<<
4616 #endif
4617  DATA pi /3.141592653589793238462643/
4618  DATA icont /0/
4619  data fpi /93.3e-3/
4620 c
4621  COMPLEX BWIGN
4622 C
4623 #if defined (ALEPH)
4624  bwign(xm,am,gammab)=xm**2/cmplx(xm**2-am**2,gammab*am)
4625 #else
4626  bwign(xm,am,gamma)=xm**2/cmplx(xm**2-am**2,gamma*am)
4627 #endif
4628 
4629 C
4630  amom=.782
4631  gamom=0.0085
4632 c
4633 C 6 BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
4634 C D**3 P /2E/(2PI)**3 (2PI)**4 DELTA4(SUM P)
4635  phspac=1./2**29/pi**14
4636 c PHSPAC=1./2**5/PI**2
4637 C init 5pi decay mode (JNPI)
4638  amp1=dcdmas(idffin(1,jnpi))
4639  amp2=dcdmas(idffin(2,jnpi))
4640  amp3=dcdmas(idffin(3,jnpi))
4641  amp4=dcdmas(idffin(4,jnpi))
4642  amp5=dcdmas(idffin(5,jnpi))
4643 c
4644 C TAU MOMENTUM
4645  pt(1)=0.
4646  pt(2)=0.
4647  pt(3)=0.
4648  pt(4)=amtau
4649 C
4650  CALL ranmar(rrr,10)
4651 C
4652 c masses of 5, 4, 3 and 2 pi systems
4653 c 3 pi with sampling for omega resonance
4654 cam
4655 c mass of 5 (12345)
4656  rr1=rrr(10)
4657  ams1=(amp1+amp2+amp3+amp4+amp5)**2
4658  ams2=(amtau-amnuta)**2
4659  am5sq=ams1+ rr1*(ams2-ams1)
4660  am5 =sqrt(am5sq)
4661  phspac=phspac*(ams2-ams1)
4662 c
4663 c mass of 4 (2345)
4664 c flat phase space
4665  rr1=rrr(9)
4666  ams1=(amp2+amp3+amp4+amp5)**2
4667  ams2=(am5-amp1)**2
4668  am4sq=ams1+ rr1*(ams2-ams1)
4669  am4 =sqrt(am4sq)
4670  gg1=ams2-ams1
4671 c
4672 c mass of 3 (234)
4673 C phase space with sampling for omega resonance
4674  rr1=rrr(1)
4675  ams1=(amp2+amp3+amp4)**2
4676  ams2=(am4-amp5)**2
4677  alp1=atan((ams1-amom**2)/amom/gamom)
4678  alp2=atan((ams2-amom**2)/amom/gamom)
4679  alp=alp1+rr1*(alp2-alp1)
4680  am3sq =amom**2+amom*gamom*tan(alp)
4681  am3 =sqrt(am3sq)
4682 c --- this part of the jacobian will be recovered later ---------------
4683  gg2=((am3sq-amom**2)**2+(amom*gamom)**2)/(amom*gamom)
4684  gg2=gg2*(alp2-alp1)
4685 c flat phase space;
4686 C am3sq=ams1+ rr1*(ams2-ams1)
4687 C am3 =sqrt(am3sq)
4688 c --- this part of jacobian will be recovered later
4689 C gg2=ams2-ams1
4690 c
4691 C mass of 2 (34)
4692  rr2=rrr(2)
4693  ams1=(amp3+amp4)**2
4694  ams2=(am3-amp2)**2
4695 c flat phase space;
4696  am2sq=ams1+ rr2*(ams2-ams1)
4697  am2 =sqrt(am2sq)
4698 c --- this part of jacobian will be recovered later
4699  gg3=ams2-ams1
4700 c
4701 c (34) restframe, define pi3 and pi4
4702  enq1=(am2sq+amp3**2-amp4**2)/(2*am2)
4703  enq2=(am2sq-amp3**2+amp4**2)/(2*am2)
4704  ppi= enq1**2-amp3**2
4705  pppi=sqrt(abs(enq1**2-amp3**2))
4706  ff1=(4*pi)*(2*pppi/am2)
4707 c pi3 momentum in (34) rest frame
4708  call sphera(pppi,pi3)
4709  pi3(4)=enq1
4710 c pi4 momentum in (34) rest frame
4711  do 30 i=1,3
4712  30 pi4(i)=-pi3(i)
4713  pi4(4)=enq2
4714 c
4715 c (234) rest frame, define pi2
4716 c pr momentum
4717  pr(1)=0
4718  pr(2)=0
4719  pr(4)=1./(2*am3)*(am3**2+am2**2-amp2**2)
4720  pr(3)= sqrt(abs(pr(4)**2-am2**2))
4721  ppi = pr(4)**2-am2**2
4722 c pi2 momentum
4723  pi2(1)=0
4724  pi2(2)=0
4725  pi2(4)=1./(2*am3)*(am3**2-am2**2+amp2**2)
4726  pi2(3)=-pr(3)
4727 c --- this part of jacobian will be recovered later
4728  ff2=(4*pi)*(2*pr(3)/am3)
4729 c old pions boosted from 2 rest frame to 3 rest frame
4730  exe=(pr(4)+pr(3))/am2
4731  call bostr3(exe,pi3,pi3)
4732  call bostr3(exe,pi4,pi4)
4733  rr3=rrr(3)
4734  rr4=rrr(4)
4735  thet =acos(-1.+2*rr3)
4736  phi = 2*pi*rr4
4737  call rotpol(thet,phi,pi2)
4738  call rotpol(thet,phi,pi3)
4739  call rotpol(thet,phi,pi4)
4740 C
4741 C (2345) rest frame, define pi5
4742 c pr momentum
4743  pr(1)=0
4744  pr(2)=0
4745  pr(4)=1./(2*am4)*(am4**2+am3**2-amp5**2)
4746  pr(3)= sqrt(abs(pr(4)**2-am3**2))
4747  ppi = pr(4)**2-am3**2
4748 c pi5 momentum
4749  pi5(1)=0
4750  pi5(2)=0
4751  pi5(4)=1./(2*am4)*(am4**2-am3**2+amp5**2)
4752  pi5(3)=-pr(3)
4753 c --- this part of jacobian will be recovered later
4754  ff3=(4*pi)*(2*pr(3)/am4)
4755 c old pions boosted from 3 rest frame to 4 rest frame
4756  exe=(pr(4)+pr(3))/am3
4757  call bostr3(exe,pi2,pi2)
4758  call bostr3(exe,pi3,pi3)
4759  call bostr3(exe,pi4,pi4)
4760  rr3=rrr(5)
4761  rr4=rrr(6)
4762  thet =acos(-1.+2*rr3)
4763  phi = 2*pi*rr4
4764  call rotpol(thet,phi,pi2)
4765  call rotpol(thet,phi,pi3)
4766  call rotpol(thet,phi,pi4)
4767  call rotpol(thet,phi,pi5)
4768 C
4769 C (12345) rest frame, define pi1
4770 c pr momentum
4771  pr(1)=0
4772  pr(2)=0
4773  pr(4)=1./(2*am5)*(am5**2+am4**2-amp1**2)
4774  pr(3)= sqrt(abs(pr(4)**2-am4**2))
4775  ppi = pr(4)**2-am4**2
4776 c pi1 momentum
4777  pi1(1)=0
4778  pi1(2)=0
4779  pi1(4)=1./(2*am5)*(am5**2-am4**2+amp1**2)
4780  pi1(3)=-pr(3)
4781 c --- this part of jacobian will be recovered later
4782  ff4=(4*pi)*(2*pr(3)/am5)
4783 c old pions boosted from 4 rest frame to 5 rest frame
4784  exe=(pr(4)+pr(3))/am4
4785  call bostr3(exe,pi2,pi2)
4786  call bostr3(exe,pi3,pi3)
4787  call bostr3(exe,pi4,pi4)
4788  call bostr3(exe,pi5,pi5)
4789  rr3=rrr(7)
4790  rr4=rrr(8)
4791  thet =acos(-1.+2*rr3)
4792  phi = 2*pi*rr4
4793  call rotpol(thet,phi,pi1)
4794  call rotpol(thet,phi,pi2)
4795  call rotpol(thet,phi,pi3)
4796  call rotpol(thet,phi,pi4)
4797  call rotpol(thet,phi,pi5)
4798 c
4799 * now to the tau rest frame, define paa and neutrino momenta
4800 * paa momentum
4801  paa(1)=0
4802  paa(2)=0
4803 c paa(4)=1./(2*amtau)*(amtau**2-amnuta**2+am5**2)
4804 c paa(3)= sqrt(abs(paa(4)**2-am5**2))
4805 c ppi = paa(4)**2-am5**2
4806  paa(4)=1./(2*amtau)*(amtau**2-amnuta**2+am5sq)
4807  paa(3)= sqrt(abs(paa(4)**2-am5sq))
4808  ppi = paa(4)**2-am5sq
4809  phspac=phspac*(4*pi)*(2*paa(3)/amtau)
4810 * tau-neutrino momentum
4811  pn(1)=0
4812  pn(2)=0
4813  pn(4)=1./(2*amtau)*(amtau**2+amnuta**2-am5**2)
4814  pn(3)=-paa(3)
4815 c
4816  phspac=phspac * gg1*gg2*gg3*ff1*ff2*ff3*ff4
4817 c
4818 C all pions boosted from 5 rest frame to tau rest frame
4819 C z-axis antiparallel to neutrino momentum
4820  exe=(paa(4)+paa(3))/am5
4821  call bostr3(exe,pi1,pi1)
4822  call bostr3(exe,pi2,pi2)
4823  call bostr3(exe,pi3,pi3)
4824  call bostr3(exe,pi4,pi4)
4825  call bostr3(exe,pi5,pi5)
4826 c
4827 C partial width consists of phase space and amplitude
4828 C AMPLITUDE (cf YS.Tsai Phys.Rev.D4,2821(1971)
4829 C or F.Gilman SH.Rhie Phys.Rev.D31,1066(1985)
4830 C
4831  pxq=amtau*paa(4)
4832  pxn=amtau*pn(4)
4833  qxn=paa(4)*pn(4)-paa(1)*pn(1)-paa(2)*pn(2)-paa(3)*pn(3)
4834  brak=2*(gv**2+ga**2)*(2*pxq*qxn+am5sq*pxn)
4835  & -6*(gv**2-ga**2)*amtau*amnuta*am5sq
4836  fompp = cabs(bwign(am3,amom,gamom))**2
4837 c normalisation factor (to some numerical undimensioned factor;
4838 c cf R.Fischer et al ZPhys C3, 313 (1980))
4839  fnorm = 1/fpi**6
4840 c AMPLIT=CCABIB**2*GFERMI**2/2. * BRAK * AM5SQ*SIGEE(AM5SQ,JNPI)
4841  amplit=ccabib**2*gfermi**2/2. * brak
4842  amplit = amplit * fompp * fnorm
4843 c phase space test
4844 c amplit = amplit * fnorm
4845  dgamt=1/(2.*amtau)*amplit*phspac
4846 c ignore spin terms
4847  DO 40 i=1,3
4848  40 hv(i)=0.
4849 c
4850  do 77 k=1,4
4851  pmult(k,1)=pi1(k)
4852  pmult(k,2)=pi2(k)
4853  pmult(k,3)=pi3(k)
4854  pmult(k,4)=pi4(k)
4855  pmult(k,5)=pi5(k)
4856  77 continue
4857  return
4858 #if defined (ALEPH)
4859 C missing: transposition of identical particles, statistical factors
4860 C for identical matrices, polarimetric vector. Matrix element rather nai
4861 #else
4862 C missing: transposition of identical particles, startistical factors
4863 C for identical matrices, polarimetric vector. Matrix element rather naive.
4864 #endif
4865 C flat phase space in pion system + with breit wigner for omega
4866 C anyway it is better than nothing, and code is improvable.
4867  end
4868  SUBROUTINE dphsrk(DGAMT,HV,PN,PR,PMULT,INUM)
4869 C ----------------------------------------------------------------------
4870 C IT SIMULATES RHO DECAY IN TAU REST FRAME WITH
4871 C Z-AXIS ALONG RHO MOMENTUM
4872 C Rho decays to K Kbar
4873 C ----------------------------------------------------------------------
4874  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
4875  * ,ampiz,ampi,amro,gamro,ama1,gama1
4876  * ,amk,amkz,amkst,gamkst
4877 C
4878  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
4879  * ,ampiz,ampi,amro,gamro,ama1,gama1
4880  * ,amk,amkz,amkst,gamkst
4881  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
4882  REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
4883  REAL HV(4),PT(4),PN(4),PR(4),PKC(4),PKZ(4),QQ(4),PMULT(4,9)
4884 #if defined (ALEPH)
4885  REAL*4 RR1(1)
4886 #else
4887  REAL RR1(1)
4888 #endif
4889  DATA pi /3.141592653589793238462643/
4890  DATA icont /0/
4891 C
4892 C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
4893  phspac=1./2**11/pi**5
4894 C TAU MOMENTUM
4895  pt(1)=0.
4896  pt(2)=0.
4897  pt(3)=0.
4898  pt(4)=amtau
4899 C MASS OF (REAL/VIRTUAL) RHO
4900  ams1=(amk+amkz)**2
4901  ams2=(amtau-amnuta)**2
4902 C FLAT PHASE SPACE
4903  CALL ranmar(rr1,1)
4904  amx2=ams1+ rr1(1)*(ams2-ams1)
4905  amx=sqrt(amx2)
4906  phspac=phspac*(ams2-ams1)
4907 C PHASE SPACE WITH SAMPLING FOR RHO RESONANCE
4908 c ALP1=ATAN((AMS1-AMRO**2)/AMRO/GAMRO)
4909 c ALP2=ATAN((AMS2-AMRO**2)/AMRO/GAMRO)
4910 CAM
4911  100 CONTINUE
4912 c CALL RANMAR(RR1,1)
4913 c ALP=ALP1+RR1(1)*(ALP2-ALP1)
4914 c AMX2=AMRO**2+AMRO*GAMRO*TAN(ALP)
4915 c AMX=SQRT(AMX2)
4916 c IF(AMX.LT.(AMK+AMKZ)) GO TO 100
4917 CAM
4918 c PHSPAC=PHSPAC*((AMX2-AMRO**2)**2+(AMRO*GAMRO)**2)/(AMRO*GAMRO)
4919 c PHSPAC=PHSPAC*(ALP2-ALP1)
4920 C
4921 C TAU-NEUTRINO MOMENTUM
4922  pn(1)=0
4923  pn(2)=0
4924  pn(4)=1./(2*amtau)*(amtau**2+amnuta**2-amx**2)
4925  pn(3)=-sqrt((pn(4)-amnuta)*(pn(4)+amnuta))
4926 C RHO MOMENTUM
4927  pr(1)=0
4928  pr(2)=0
4929  pr(4)=1./(2*amtau)*(amtau**2-amnuta**2+amx**2)
4930  pr(3)=-pn(3)
4931  phspac=phspac*(4*pi)*(2*pr(3)/amtau)
4932 C
4933 CAM
4934  enq1=(amx2+amk**2-amkz**2)/(2.*amx)
4935  enq2=(amx2-amk**2+amkz**2)/(2.*amx)
4936  pppi=sqrt((enq1-amk)*(enq1+amk))
4937  phspac=phspac*(4*pi)*(2*pppi/amx)
4938 C CHARGED PI MOMENTUM IN RHO REST FRAME
4939  CALL sphera(pppi,pkc)
4940  pkc(4)=enq1
4941 C NEUTRAL PI MOMENTUM IN RHO REST FRAME
4942  DO 20 i=1,3
4943 20 pkz(i)=-pkc(i)
4944  pkz(4)=enq2
4945  exe=(pr(4)+pr(3))/amx
4946 C PIONS BOOSTED FROM RHO REST FRAME TO TAU REST FRAME
4947  CALL bostr3(exe,pkc,pkc)
4948  CALL bostr3(exe,pkz,pkz)
4949  DO 30 i=1,4
4950  30 qq(i)=pkc(i)-pkz(i)
4951 C QQ transverse to PR
4952  pksd =pr(4)*pr(4)-pr(3)*pr(3)-pr(2)*pr(2)-pr(1)*pr(1)
4953  qqpks=pr(4)* qq(4)-pr(3)* qq(3)-pr(2)* qq(2)-pr(1)* qq(1)
4954  DO 31 i=1,4
4955 31 qq(i)=qq(i)-pr(i)*qqpks/pksd
4956 C AMPLITUDE
4957  prodpq=pt(4)*qq(4)
4958  prodnq=pn(4)*qq(4)-pn(1)*qq(1)-pn(2)*qq(2)-pn(3)*qq(3)
4959  prodpn=pt(4)*pn(4)
4960  qq2= qq(4)**2-qq(1)**2-qq(2)**2-qq(3)**2
4961  brak=(gv**2+ga**2)*(2*prodpq*prodnq-prodpn*qq2)
4962  & +(gv**2-ga**2)*amtau*amnuta*qq2
4963  amplit=(gfermi*ccabib)**2*brak*2*fpirk(amx)
4964  dgamt=1/(2.*amtau)*amplit*phspac
4965  DO 40 i=1,3
4966  40 hv(i)=2*gv*ga*amtau*(2*prodnq*qq(i)-qq2*pn(i))/brak
4967  do 77 k=1,4
4968  pmult(k,1)=pkc(k)
4969  pmult(k,2)=pkz(k)
4970  77 continue
4971  RETURN
4972  END
4973  FUNCTION fpirk(W)
4974 C ----------------------------------------------------------
4975 c square of pion form factor
4976 C ----------------------------------------------------------
4977  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
4978  * ,ampiz,ampi,amro,gamro,ama1,gama1
4979  * ,amk,amkz,amkst,gamkst
4980 C
4981  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
4982  * ,ampiz,ampi,amro,gamro,ama1,gama1
4983  * ,amk,amkz,amkst,gamkst
4984 c COMPLEX FPIKMK
4985  COMPLEX FPIKM
4986  fpirk=cabs(fpikm(w,amk,amkz))**2
4987 c FPIRK=CABS(FPIKMK(W,AMK,AMKZ))**2
4988  END
4989  COMPLEX FUNCTION fpikmk(W,XM1,XM2)
4990 C **********************************************************
4991 C Kaon form factor
4992 C **********************************************************
4993  COMPLEX BWIGM
4994  REAL ROM,ROG,ROM1,ROG1,BETA1,PI,PIM,S,W
4995  EXTERNAL bwig
4996  DATA init /0/
4997 C
4998 C ------------ PARAMETERS --------------------
4999  IF (init.EQ.0 ) THEN
5000  init=1
5001  pi=3.141592654
5002  pim=.140
5003  rom=0.773
5004  rog=0.145
5005  rom1=1.570
5006  rog1=0.510
5007 c BETA1=-0.111
5008  beta1=-0.221
5009  ENDIF
5010 C -----------------------------------------------
5011  s=w**2
5012  fpikmk=(bwigm(s,rom,rog,xm1,xm2)+beta1*bwigm(s,rom1,rog1,xm1,xm2))
5013  & /(1+beta1)
5014  RETURN
5015  END
5016  SUBROUTINE reslux
5017 C ****************
5018 C INITIALIZE LUND COMMON
5019 #if defined (CLEO)
5020 #else
5021  parameter(nmxhep=2000)
5022  common/hepevtx/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),
5023  &jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)
5024  SAVE /hepevtx/
5025 #endif
5026  nhep=0
5027  END
5028  SUBROUTINE dwrph(KTO,PHX)
5029 C
5030 C -------------------------
5031 C
5032  IMPLICIT REAL*8 (a-h,o-z)
5033  REAL*4 PHX(4)
5034  REAL*4 QHOT(4)
5035 C
5036  DO 9 k=1,4
5037  qhot(k) =0.0
5038  9 CONTINUE
5039 C CASE OF TAU RADIATIVE DECAYS.
5040 C FILLING OF THE LUND COMMON BLOCK.
5041  DO 1002 i=1,4
5042  1002 qhot(i)=phx(i)
5043  IF (qhot(4).GT.1.e-5) CALL dwluph(kto,qhot)
5044  RETURN
5045  END
5046  SUBROUTINE dwluph(KTO,PHOT)
5047 C---------------------------------------------------------------------
5048 C Lorentz transformation to CMsystem and
5049 C Updating of HEPEVT record
5050 C
5051 C called by : DEXAY1,(DEKAY1,DEKAY2)
5052 C
5053 C used when radiative corrections in decays are generated
5054 C---------------------------------------------------------------------
5055 C
5056 #if defined (ALEPH)
5057  COMMON /taupos/ np1,np2
5058 #else
5059 #endif
5060  REAL PHOT(4)
5061 #if defined (ALEPH)
5062 #else
5063  COMMON /taupos/ np1,np2
5064 #endif
5065 C
5066 C check energy
5067  IF (phot(4).LE.0.0) RETURN
5068 C
5069 C position of decaying particle:
5070  IF((kto.EQ. 1).OR.(kto.EQ.11)) THEN
5071  nps=np1
5072  ELSE
5073  nps=np2
5074  ENDIF
5075 C
5076  ktos=kto
5077  IF(ktos.GT.10) ktos=ktos-10
5078 C boost and append photon (gamma is 22)
5079  CALL tralo4(ktos,phot,phot,am)
5080  CALL filhep(0,1,22,nps,nps,0,0,phot,0.0,.true.)
5081 C
5082  RETURN
5083  END
5084 
5085  SUBROUTINE dwluel(KTO,ISGN,PNU,PWB,PEL,PNE)
5086 C ----------------------------------------------------------------------
5087 C Lorentz transformation to CMsystem and
5088 C Updating of HEPEVT record
5089 C
5090 C ISGN = 1/-1 for tau-/tau+
5091 C
5092 C called by : DEXAY,(DEKAY1,DEKAY2)
5093 C ----------------------------------------------------------------------
5094 C
5095 #if defined (ALEPH)
5096  COMMON /taupos/ np1,np2
5097 #else
5098 #endif
5099  REAL PNU(4),PWB(4),PEL(4),PNE(4)
5100 #if defined (ALEPH)
5101 #else
5102  COMMON /taupos/ np1,np2
5103 #endif
5104 C
5105 C position of decaying particle:
5106  IF(kto.EQ. 1) THEN
5107  nps=np1
5108  ELSE
5109  nps=np2
5110  ENDIF
5111 C
5112 C tau neutrino (nu_tau is 16)
5113  CALL tralo4(kto,pnu,pnu,am)
5114  CALL filhep(0,1,16*isgn,nps,nps,0,0,pnu,am,.true.)
5115 C
5116 C W boson (W+ is 24)
5117  CALL tralo4(kto,pwb,pwb,am)
5118 C CALL FILHEP(0,2,-24*ISGN,NPS,NPS,0,0,PWB,AM,.TRUE.)
5119 C
5120 C electron (e- is 11)
5121  CALL tralo4(kto,pel,pel,am)
5122  CALL filhep(0,1,11*isgn,nps,nps,0,0,pel,am,.false.)
5123 C
5124 C anti electron neutrino (nu_e is 12)
5125  CALL tralo4(kto,pne,pne,am)
5126  CALL filhep(0,1,-12*isgn,nps,nps,0,0,pne,am,.true.)
5127 C
5128  RETURN
5129  END
5130  SUBROUTINE dwlumu(KTO,ISGN,PNU,PWB,PMU,PNM)
5131 C ----------------------------------------------------------------------
5132 C Lorentz transformation to CMsystem and
5133 C Updating of HEPEVT record
5134 C
5135 C ISGN = 1/-1 for tau-/tau+
5136 C
5137 C called by : DEXAY,(DEKAY1,DEKAY2)
5138 C ----------------------------------------------------------------------
5139 C
5140 #if defined (ALEPH)
5141  COMMON /taupos/ np1,np2
5142 #else
5143 #endif
5144  REAL PNU(4),PWB(4),PMU(4),PNM(4)
5145 #if defined (ALEPH)
5146 #else
5147  COMMON /taupos/ np1,np2
5148 #endif
5149 C
5150 C position of decaying particle:
5151  IF(kto.EQ. 1) THEN
5152  nps=np1
5153  ELSE
5154  nps=np2
5155  ENDIF
5156 C
5157 C tau neutrino (nu_tau is 16)
5158  CALL tralo4(kto,pnu,pnu,am)
5159  CALL filhep(0,1,16*isgn,nps,nps,0,0,pnu,am,.true.)
5160 C
5161 C W boson (W+ is 24)
5162  CALL tralo4(kto,pwb,pwb,am)
5163 C CALL FILHEP(0,2,-24*ISGN,NPS,NPS,0,0,PWB,AM,.TRUE.)
5164 C
5165 C muon (mu- is 13)
5166  CALL tralo4(kto,pmu,pmu,am)
5167  CALL filhep(0,1,13*isgn,nps,nps,0,0,pmu,am,.false.)
5168 C
5169 C anti muon neutrino (nu_mu is 14)
5170  CALL tralo4(kto,pnm,pnm,am)
5171  CALL filhep(0,1,-14*isgn,nps,nps,0,0,pnm,am,.true.)
5172 C
5173  RETURN
5174  END
5175  SUBROUTINE dwlupi(KTO,ISGN,PPI,PNU)
5176 C ----------------------------------------------------------------------
5177 C Lorentz transformation to CMsystem and
5178 C Updating of HEPEVT record
5179 C
5180 C ISGN = 1/-1 for tau-/tau+
5181 C
5182 C called by : DEXAY,(DEKAY1,DEKAY2)
5183 C ----------------------------------------------------------------------
5184 C
5185  REAL PNU(4),PPI(4)
5186  COMMON /taupos/ np1,np2
5187 C
5188 C position of decaying particle:
5189  IF(kto.EQ. 1) THEN
5190  nps=np1
5191  ELSE
5192  nps=np2
5193  ENDIF
5194 C
5195 C tau neutrino (nu_tau is 16)
5196  CALL tralo4(kto,pnu,pnu,am)
5197  CALL filhep(0,1,16*isgn,nps,nps,0,0,pnu,am,.true.)
5198 C
5199 C charged pi meson (pi+ is 211)
5200  CALL tralo4(kto,ppi,ppi,am)
5201  CALL filhep(0,1,-211*isgn,nps,nps,0,0,ppi,am,.true.)
5202 C
5203  RETURN
5204  END
5205  SUBROUTINE dwluro(KTO,ISGN,PNU,PRHO,PIC,PIZ)
5206 C ----------------------------------------------------------------------
5207 C Lorentz transformation to CMsystem and
5208 C Updating of HEPEVT record
5209 C
5210 C ISGN = 1/-1 for tau-/tau+
5211 C
5212 C called by : DEXAY,(DEKAY1,DEKAY2)
5213 C ----------------------------------------------------------------------
5214 C
5215 #if defined (ALEPH)
5216  COMMON /taupos/ np1,np2
5217 #else
5218 #endif
5219  REAL PNU(4),PRHO(4),PIC(4),PIZ(4)
5220 #if defined (ALEPH)
5221 #else
5222  COMMON /taupos/ np1,np2
5223 #endif
5224 C
5225 C position of decaying particle:
5226  IF(kto.EQ. 1) THEN
5227  nps=np1
5228  ELSE
5229  nps=np2
5230  ENDIF
5231 C
5232 C tau neutrino (nu_tau is 16)
5233  CALL tralo4(kto,pnu,pnu,am)
5234  CALL filhep(0,1,16*isgn,nps,nps,0,0,pnu,am,.true.)
5235 C
5236 C charged rho meson (rho+ is 213)
5237  CALL tralo4(kto,prho,prho,am)
5238  CALL filhep(0,2,-213*isgn,nps,nps,0,0,prho,am,.true.)
5239 C
5240 C charged pi meson (pi+ is 211)
5241  CALL tralo4(kto,pic,pic,am)
5242  CALL filhep(0,1,-211*isgn,-1,-1,0,0,pic,am,.true.)
5243 C
5244 C pi0 meson (pi0 is 111)
5245  CALL tralo4(kto,piz,piz,am)
5246  CALL filhep(0,1,111,-2,-2,0,0,piz,am,.true.)
5247 C
5248  RETURN
5249  END
5250  SUBROUTINE dwluaa(KTO,ISGN,PNU,PAA,PIM1,PIM2,PIPL,JAA)
5251 C ----------------------------------------------------------------------
5252 C Lorentz transformation to CMsystem and
5253 C Updating of HEPEVT record
5254 C
5255 C ISGN = 1/-1 for tau-/tau+
5256 C JAA = 1 (2) FOR A_1- DECAY TO PI+ 2PI- (PI- 2PI0)
5257 C
5258 C called by : DEXAY,(DEKAY1,DEKAY2)
5259 C ----------------------------------------------------------------------
5260 C
5261 #if defined (ALEPH)
5262  COMMON /taupos/ np1,np2
5263 #else
5264 #endif
5265  REAL PNU(4),PAA(4),PIM1(4),PIM2(4),PIPL(4)
5266 #if defined (ALEPH)
5267 #else
5268  COMMON /taupos/ np1,np2
5269 #endif
5270 C
5271 C position of decaying particle:
5272  IF(kto.EQ. 1) THEN
5273  nps=np1
5274  ELSE
5275  nps=np2
5276  ENDIF
5277 C
5278 C tau neutrino (nu_tau is 16)
5279  CALL tralo4(kto,pnu,pnu,am)
5280  CALL filhep(0,1,16*isgn,nps,nps,0,0,pnu,am,.true.)
5281 C
5282 C charged a_1 meson (a_1+ is 20213)
5283  CALL tralo4(kto,paa,paa,am)
5284  CALL filhep(0,1,-20213*isgn,nps,nps,0,0,paa,am,.true.)
5285 C
5286 C two possible decays of the charged a1 meson
5287  IF(jaa.EQ.1) THEN
5288 C
5289 C A1 --> PI+ PI- PI- (or charged conjugate)
5290 C
5291 C pi minus (or c.c.) (pi+ is 211)
5292  CALL tralo4(kto,pim2,pim2,am)
5293  CALL filhep(0,1,-211*isgn,-1,-1,0,0,pim2,am,.true.)
5294 C
5295 C pi minus (or c.c.) (pi+ is 211)
5296  CALL tralo4(kto,pim1,pim1,am)
5297  CALL filhep(0,1,-211*isgn,-2,-2,0,0,pim1,am,.true.)
5298 C
5299 C pi plus (or c.c.) (pi+ is 211)
5300  CALL tralo4(kto,pipl,pipl,am)
5301  CALL filhep(0,1, 211*isgn,-3,-3,0,0,pipl,am,.true.)
5302 C
5303  ELSE IF (jaa.EQ.2) THEN
5304 C
5305 C A1 --> PI- PI0 PI0 (or charged conjugate)
5306 C
5307 C pi zero (pi0 is 111)
5308  CALL tralo4(kto,pim2,pim2,am)
5309  CALL filhep(0,1,111,-1,-1,0,0,pim2,am,.true.)
5310 C
5311 C pi zero (pi0 is 111)
5312  CALL tralo4(kto,pim1,pim1,am)
5313  CALL filhep(0,1,111,-2,-2,0,0,pim1,am,.true.)
5314 C
5315 C pi minus (or c.c.) (pi+ is 211)
5316  CALL tralo4(kto,pipl,pipl,am)
5317  CALL filhep(0,1,-211*isgn,-3,-3,0,0,pipl,am,.true.)
5318 C
5319  ENDIF
5320 C
5321  RETURN
5322  END
5323  SUBROUTINE dwlukk (KTO,ISGN,PKK,PNU)
5324 C ----------------------------------------------------------------------
5325 C Lorentz transformation to CMsystem and
5326 C Updating of HEPEVT record
5327 C
5328 C ISGN = 1/-1 for tau-/tau+
5329 C
5330 C ----------------------------------------------------------------------
5331 C
5332  REAL PKK(4),PNU(4)
5333  COMMON /taupos/ np1,np2
5334 C
5335 C position of decaying particle
5336 #if defined (ALEPH)
5337  IF(kto.EQ. 1) THEN
5338 #else
5339  IF (kto.EQ.1) THEN
5340 #endif
5341  nps=np1
5342  ELSE
5343  nps=np2
5344  ENDIF
5345 C
5346 C tau neutrino (nu_tau is 16)
5347  CALL tralo4 (kto,pnu,pnu,am)
5348  CALL filhep(0,1,16*isgn,nps,nps,0,0,pnu,am,.true.)
5349 C
5350 C K meson (K+ is 321)
5351  CALL tralo4 (kto,pkk,pkk,am)
5352  CALL filhep(0,1,-321*isgn,nps,nps,0,0,pkk,am,.true.)
5353 C
5354  RETURN
5355  END
5356  SUBROUTINE dwluks(KTO,ISGN,PNU,PKS,PKK,PPI,JKST)
5357  COMMON / taukle / bra1,brk0,brk0b,brks
5358  REAL*4 BRA1,BRK0,BRK0B,BRKS
5359 #if defined (ALEPH)
5360  COMMON /taupos/ np1,np2
5361  REAL*4 XIO(1)
5362 #endif
5363 C ----------------------------------------------------------------------
5364 C Lorentz transformation to CMsystem and
5365 C Updating of HEPEVT record
5366 C
5367 C ISGN = 1/-1 for tau-/tau+
5368 C JKST=10 (20) corresponds to K0B pi- (K- pi0) decay
5369 C
5370 C ----------------------------------------------------------------------
5371 C
5372 #if defined (ALEPH)
5373  REAL PNU(4),PKS(4),PKK(4),PPI(4)
5374 #else
5375  REAL PNU(4),PKS(4),PKK(4),PPI(4),XIO(1)
5376  COMMON /taupos/ np1,np2
5377 #endif
5378 C
5379 C position of decaying particle
5380  IF(kto.EQ. 1) THEN
5381  nps=np1
5382  ELSE
5383  nps=np2
5384  ENDIF
5385 C
5386 C tau neutrino (nu_tau is 16)
5387  CALL tralo4(kto,pnu,pnu,am)
5388  CALL filhep(0,1,16*isgn,nps,nps,0,0,pnu,am,.true.)
5389 C
5390 C charged K* meson (K*+ is 323)
5391  CALL tralo4(kto,pks,pks,am)
5392  CALL filhep(0,1,-323*isgn,nps,nps,0,0,pks,am,.true.)
5393 C
5394 C two possible decay modes of charged K*
5395  IF(jkst.EQ.10) THEN
5396 C
5397 C K*- --> pi- K0B (or charged conjugate)
5398 C
5399 C charged pi meson (pi+ is 211)
5400  CALL tralo4(kto,ppi,ppi,am)
5401  CALL filhep(0,1,-211*isgn,-1,-1,0,0,ppi,am,.true.)
5402 C
5403  bran=brk0b
5404  IF (isgn.EQ.-1) bran=brk0
5405 C K0 --> K0_long (is 130) / K0_short (is 310) = 1/1
5406  CALL ranmar(xio,1)
5407  IF(xio(1).GT.bran) THEN
5408  k0type = 130
5409  ELSE
5410  k0type = 310
5411  ENDIF
5412 C
5413  CALL tralo4(kto,pkk,pkk,am)
5414  CALL filhep(0,1,k0type,-2,-2,0,0,pkk,am,.true.)
5415 C
5416  ELSE IF(jkst.EQ.20) THEN
5417 C
5418 C K*- --> pi0 K-
5419 C
5420 C pi zero (pi0 is 111)
5421  CALL tralo4(kto,ppi,ppi,am)
5422  CALL filhep(0,1,111,-1,-1,0,0,ppi,am,.true.)
5423 C
5424 C charged K meson (K+ is 321)
5425  CALL tralo4(kto,pkk,pkk,am)
5426  CALL filhep(0,1,-321*isgn,-2,-2,0,0,pkk,am,.true.)
5427 C
5428  ENDIF
5429 C
5430  RETURN
5431  END
5432  SUBROUTINE dwlnew(KTO,ISGN,PNU,PWB,PNPI,MODE)
5433 C ----------------------------------------------------------------------
5434 C Lorentz transformation to CMsystem and
5435 C Updating of HEPEVT record
5436 C
5437 C ISGN = 1/-1 for tau-/tau+
5438 C
5439 C called by : DEXAY,(DEKAY1,DEKAY2)
5440 C ----------------------------------------------------------------------
5441 C
5442  parameter(nmode=15,nm1=0,nm2=1,nm3=8,nm4=2,nm5=1,nm6=3)
5443 #if defined (ALEPH)
5444  COMMON / taudcd /idffin(9,nmode),mulpik(nmode)
5445 #else
5446  COMMON / taudcd /idffin(9,nmode),mulpik(nmode)
5447 #endif
5448  & ,names
5449  COMMON /taupos/ np1,np2
5450  CHARACTER NAMES(NMODE)*31
5451  REAL PNU(4),PWB(4),PNPI(4,9)
5452  REAL PPI(4)
5453 C
5454  jnpi=mode-7
5455 C position of decaying particle
5456  IF(kto.EQ. 1) THEN
5457  nps=np1
5458  ELSE
5459  nps=np2
5460  ENDIF
5461 C
5462 C tau neutrino (nu_tau is 16)
5463  CALL tralo4(kto,pnu,pnu,am)
5464  CALL filhep(0,1,16*isgn,nps,nps,0,0,pnu,am,.true.)
5465 C
5466 C W boson (W+ is 24)
5467  CALL tralo4(kto,pwb,pwb,am)
5468  CALL filhep(0,1,-24*isgn,nps,nps,0,0,pwb,am,.true.)
5469 C
5470 C multi pi mode JNPI
5471 C
5472 C get multiplicity of mode JNPI
5473  nd=mulpik(jnpi)
5474  DO i=1,nd
5475 #if defined (ALEPH)
5476 cam KFPI=LUNPIK(IDFFIN(I,JNPI),-ISGN)
5477  kfpi=lunpik(idffin(i,jnpi), isgn)
5478 #else
5479  kfpi=lunpik(idffin(i,jnpi),-isgn)
5480 #endif
5481 C for charged conjugate case, change charged pions only
5482 C IF(KFPI.NE.111)KFPI=KFPI*ISGN
5483  DO j=1,4
5484  ppi(j)=pnpi(j,i)
5485  END DO
5486  CALL tralo4(kto,ppi,ppi,am)
5487  CALL filhep(0,1,kfpi,-i,-i,0,0,ppi,am,.true.)
5488  END DO
5489 C
5490  RETURN
5491  END
5492 #if defined (CePeCe)
5493 #else
5494 #endif
5495  FUNCTION amast(PP)
5496 C ----------------------------------------------------------------------
5497 C CALCULATES MASS OF PP (DOUBLE PRECISION)
5498 C
5499 C USED BY : RADKOR
5500 C ----------------------------------------------------------------------
5501  IMPLICIT REAL*8 (a-h,o-z)
5502  REAL*8 PP(4)
5503  aaa=pp(4)**2-pp(3)**2-pp(2)**2-pp(1)**2
5504 C
5505  IF(aaa.NE.0.0) aaa=aaa/sqrt(abs(aaa))
5506  amast=aaa
5507  RETURN
5508  END
5509  FUNCTION amas4(PP)
5510 C ******************
5511 C ----------------------------------------------------------------------
5512 C CALCULATES MASS OF PP
5513 C
5514 C USED BY :
5515 C ----------------------------------------------------------------------
5516  REAL PP(4)
5517  aaa=pp(4)**2-pp(3)**2-pp(2)**2-pp(1)**2
5518  IF(aaa.NE.0.0) aaa=aaa/sqrt(abs(aaa))
5519  amas4=aaa
5520  RETURN
5521  END
5522  FUNCTION angxy(X,Y)
5523 C ----------------------------------------------------------------------
5524 C
5525 C USED BY : KORALZ RADKOR
5526 C ----------------------------------------------------------------------
5527  IMPLICIT DOUBLE PRECISION (a-h,o-z)
5528  DATA pi /3.141592653589793238462643d0/
5529 C
5530  IF(abs(y).LT.abs(x)) THEN
5531  the=atan(abs(y/x))
5532  IF(x.LE.0d0) the=pi-the
5533  ELSE
5534  the=acos(x/sqrt(x**2+y**2))
5535  ENDIF
5536  angxy=the
5537  RETURN
5538  END
5539  FUNCTION angfi(X,Y)
5540 C ----------------------------------------------------------------------
5541 * CALCULATES ANGLE IN (0,2*PI) RANGE OUT OF X-Y
5542 C
5543 C USED BY : KORALZ RADKOR
5544 C ----------------------------------------------------------------------
5545  IMPLICIT DOUBLE PRECISION (a-h,o-z)
5546  DATA pi /3.141592653589793238462643d0/
5547 C
5548  IF(abs(y).LT.abs(x)) THEN
5549  the=atan(abs(y/x))
5550  IF(x.LE.0d0) the=pi-the
5551  ELSE
5552  the=acos(x/sqrt(x**2+y**2))
5553  ENDIF
5554  IF(y.LT.0d0) the=2d0*pi-the
5555  angfi=the
5556  END
5557  SUBROUTINE rotod1(PH1,PVEC,QVEC)
5558 C ----------------------------------------------------------------------
5559 C
5560 C USED BY : KORALZ
5561 C ----------------------------------------------------------------------
5562  IMPLICIT DOUBLE PRECISION (a-h,o-z)
5563  dimension pvec(4),qvec(4),rvec(4)
5564 C
5565  phi=ph1
5566  cs=cos(phi)
5567  sn=sin(phi)
5568  DO 10 i=1,4
5569  10 rvec(i)=pvec(i)
5570  qvec(1)=rvec(1)
5571  qvec(2)= cs*rvec(2)-sn*rvec(3)
5572  qvec(3)= sn*rvec(2)+cs*rvec(3)
5573  qvec(4)=rvec(4)
5574  RETURN
5575  END
5576  SUBROUTINE rotod2(PH1,PVEC,QVEC)
5577 C ----------------------------------------------------------------------
5578 C
5579 C USED BY : KORALZ RADKOR
5580 C ----------------------------------------------------------------------
5581  IMPLICIT DOUBLE PRECISION (a-h,o-z)
5582  dimension pvec(4),qvec(4),rvec(4)
5583 C
5584  phi=ph1
5585  cs=cos(phi)
5586  sn=sin(phi)
5587  DO 10 i=1,4
5588  10 rvec(i)=pvec(i)
5589  qvec(1)= cs*rvec(1)+sn*rvec(3)
5590  qvec(2)=rvec(2)
5591  qvec(3)=-sn*rvec(1)+cs*rvec(3)
5592  qvec(4)=rvec(4)
5593  RETURN
5594  END
5595  SUBROUTINE rotod3(PH1,PVEC,QVEC)
5596 C ----------------------------------------------------------------------
5597 C
5598 C USED BY : KORALZ RADKOR
5599 C ----------------------------------------------------------------------
5600  IMPLICIT DOUBLE PRECISION (a-h,o-z)
5601 C
5602  dimension pvec(4),qvec(4),rvec(4)
5603  phi=ph1
5604  cs=cos(phi)
5605  sn=sin(phi)
5606  DO 10 i=1,4
5607  10 rvec(i)=pvec(i)
5608  qvec(1)= cs*rvec(1)-sn*rvec(2)
5609  qvec(2)= sn*rvec(1)+cs*rvec(2)
5610  qvec(3)=rvec(3)
5611  qvec(4)=rvec(4)
5612  END
5613  SUBROUTINE bostr3(EXE,PVEC,QVEC)
5614 C ----------------------------------------------------------------------
5615 C BOOST ALONG Z AXIS, EXE=EXP(ETA), ETA= HIPERBOLIC VELOCITY.
5616 C
5617 C USED BY : TAUOLA KORALZ (?)
5618 C ----------------------------------------------------------------------
5619  REAL*4 PVEC(4),QVEC(4),RVEC(4)
5620 C
5621  DO 10 i=1,4
5622  10 rvec(i)=pvec(i)
5623  rpl=rvec(4)+rvec(3)
5624  rmi=rvec(4)-rvec(3)
5625  qpl=rpl*exe
5626  qmi=rmi/exe
5627  qvec(1)=rvec(1)
5628  qvec(2)=rvec(2)
5629  qvec(3)=(qpl-qmi)/2
5630  qvec(4)=(qpl+qmi)/2
5631  END
5632  SUBROUTINE bostd3(EXE,PVEC,QVEC)
5633 C ----------------------------------------------------------------------
5634 C BOOST ALONG Z AXIS, EXE=EXP(ETA), ETA= HIPERBOLIC VELOCITY.
5635 C
5636 C USED BY : KORALZ RADKOR
5637 C ----------------------------------------------------------------------
5638  IMPLICIT DOUBLE PRECISION (a-h,o-z)
5639  dimension pvec(4),qvec(4),rvec(4)
5640 C
5641  DO 10 i=1,4
5642  10 rvec(i)=pvec(i)
5643  rpl=rvec(4)+rvec(3)
5644  rmi=rvec(4)-rvec(3)
5645  qpl=rpl*exe
5646  qmi=rmi/exe
5647  qvec(1)=rvec(1)
5648  qvec(2)=rvec(2)
5649  qvec(3)=(qpl-qmi)/2
5650  qvec(4)=(qpl+qmi)/2
5651  RETURN
5652  END
5653  SUBROUTINE rotor1(PH1,PVEC,QVEC)
5654 C ----------------------------------------------------------------------
5655 C
5656 C called by :
5657 C ----------------------------------------------------------------------
5658  REAL*4 PVEC(4),QVEC(4),RVEC(4)
5659 C
5660  phi=ph1
5661  cs=cos(phi)
5662  sn=sin(phi)
5663  DO 10 i=1,4
5664  10 rvec(i)=pvec(i)
5665  qvec(1)=rvec(1)
5666  qvec(2)= cs*rvec(2)-sn*rvec(3)
5667  qvec(3)= sn*rvec(2)+cs*rvec(3)
5668  qvec(4)=rvec(4)
5669  END
5670  SUBROUTINE rotor2(PH1,PVEC,QVEC)
5671 C ----------------------------------------------------------------------
5672 C
5673 C USED BY : TAUOLA
5674 C ----------------------------------------------------------------------
5675  IMPLICIT REAL*4(a-h,o-z)
5676  REAL*4 PVEC(4),QVEC(4),RVEC(4)
5677 C
5678  phi=ph1
5679  cs=cos(phi)
5680  sn=sin(phi)
5681  DO 10 i=1,4
5682  10 rvec(i)=pvec(i)
5683  qvec(1)= cs*rvec(1)+sn*rvec(3)
5684  qvec(2)=rvec(2)
5685  qvec(3)=-sn*rvec(1)+cs*rvec(3)
5686  qvec(4)=rvec(4)
5687  END
5688  SUBROUTINE rotor3(PHI,PVEC,QVEC)
5689 C ----------------------------------------------------------------------
5690 C
5691 C USED BY : TAUOLA
5692 C ----------------------------------------------------------------------
5693  REAL*4 PVEC(4),QVEC(4),RVEC(4)
5694 C
5695  cs=cos(phi)
5696  sn=sin(phi)
5697  DO 10 i=1,4
5698  10 rvec(i)=pvec(i)
5699  qvec(1)= cs*rvec(1)-sn*rvec(2)
5700  qvec(2)= sn*rvec(1)+cs*rvec(2)
5701  qvec(3)=rvec(3)
5702  qvec(4)=rvec(4)
5703  END
5704  SUBROUTINE spherd(R,X)
5705 C ----------------------------------------------------------------------
5706 C GENERATES UNIFORMLY THREE-VECTOR X ON SPHERE OF RADIUS R
5707 C DOUBLE PRECISON VERSION OF SPHERA
5708 C ----------------------------------------------------------------------
5709  REAL*8 R,X(4),PI,COSTH,SINTH
5710  REAL*4 RRR(2)
5711  DATA pi /3.141592653589793238462643d0/
5712 C
5713  CALL ranmar(rrr,2)
5714  costh=-1+2*rrr(1)
5715  sinth=sqrt(1 -costh**2)
5716  x(1)=r*sinth*cos(2*pi*rrr(2))
5717  x(2)=r*sinth*sin(2*pi*rrr(2))
5718  x(3)=r*costh
5719  RETURN
5720  END
5721  SUBROUTINE rotpox(THET,PHI,PP)
5722  IMPLICIT REAL*8 (a-h,o-z)
5723 C ----------------------------------------------------------------------
5724 #if defined (ALEPH)
5725 C double precison version of ROTPOL
5726 #else
5727 C
5728 #endif
5729 C ----------------------------------------------------------------------
5730  dimension pp(4)
5731 C
5732  CALL rotod2(thet,pp,pp)
5733  CALL rotod3( phi,pp,pp)
5734  RETURN
5735  END
5736  SUBROUTINE sphera(R,X)
5737 C ----------------------------------------------------------------------
5738 C GENERATES UNIFORMLY THREE-VECTOR X ON SPHERE OF RADIUS R
5739 C
5740 C called by : DPHSxx,DADMPI,DADMKK
5741 C ----------------------------------------------------------------------
5742  REAL X(4)
5743  REAL*4 RRR(2)
5744  DATA pi /3.141592653589793238462643/
5745 C
5746  CALL ranmar(rrr,2)
5747  costh=-1.+2.*rrr(1)
5748  sinth=sqrt(1.-costh**2)
5749  x(1)=r*sinth*cos(2*pi*rrr(2))
5750  x(2)=r*sinth*sin(2*pi*rrr(2))
5751  x(3)=r*costh
5752  RETURN
5753  END
5754  SUBROUTINE rotpol(THET,PHI,PP)
5755 C ----------------------------------------------------------------------
5756 C
5757 C called by : DADMAA,DPHSAA
5758 C ----------------------------------------------------------------------
5759  REAL PP(4)
5760 C
5761  CALL rotor2(thet,pp,pp)
5762  CALL rotor3( phi,pp,pp)
5763  RETURN
5764  END
5765 #include "../randg/tauola-random.h"
5766  FUNCTION dilogt(X)
5767 C *****************
5768  IMPLICIT REAL*8(a-h,o-z)
5769 CERN C304 VERSION 29/07/71 DILOG 59 C
5770  z=-1.64493406684822
5771  IF(x .LT.-1.0) GO TO 1
5772  IF(x .LE. 0.5) GO TO 2
5773  IF(x .EQ. 1.0) GO TO 3
5774  IF(x .LE. 2.0) GO TO 4
5775  z=3.2898681336964
5776  1 t=1.0/x
5777  s=-0.5
5778  z=z-0.5* log(abs(x))**2
5779  GO TO 5
5780  2 t=x
5781  s=0.5
5782  z=0.
5783  GO TO 5
5784  3 dilogt=1.64493406684822
5785  RETURN
5786  4 t=1.0-x
5787  s=-0.5
5788  z=1.64493406684822 - log(x)* log(abs(t))
5789  5 y=2.66666666666666 *t+0.66666666666666
5790  b= 0.00000 00000 00001
5791  a=y*b +0.00000 00000 00004
5792  b=y*a-b+0.00000 00000 00011
5793  a=y*b-a+0.00000 00000 00037
5794  b=y*a-b+0.00000 00000 00121
5795  a=y*b-a+0.00000 00000 00398
5796  b=y*a-b+0.00000 00000 01312
5797  a=y*b-a+0.00000 00000 04342
5798  b=y*a-b+0.00000 00000 14437
5799  a=y*b-a+0.00000 00000 48274
5800  b=y*a-b+0.00000 00001 62421
5801  a=y*b-a+0.00000 00005 50291
5802  b=y*a-b+0.00000 00018 79117
5803  a=y*b-a+0.00000 00064 74338
5804  b=y*a-b+0.00000 00225 36705
5805  a=y*b-a+0.00000 00793 87055
5806  b=y*a-b+0.00000 02835 75385
5807  a=y*b-a+0.00000 10299 04264
5808  b=y*a-b+0.00000 38163 29463
5809  a=y*b-a+0.00001 44963 00557
5810  b=y*a-b+0.00005 68178 22718
5811  a=y*b-a+0.00023 20021 96094
5812  b=y*a-b+0.00100 16274 96164
5813  a=y*b-a+0.00468 63619 59447
5814  b=y*a-b+0.02487 93229 24228
5815  a=y*b-a+0.16607 30329 27855
5816  a=y*a-b+1.93506 43008 6996
5817  dilogt=s*t*(a-b)+z
5818  RETURN
5819 C=======================================================================
5820 C===================END OF CPC PART ====================================
5821 C=======================================================================
5822  END
5823