Geant4.10
 All Data Structures Namespaces Files Functions Variables Typedefs Enumerations Enumerator Friends Macros Groups Pages
leptonew.f
Go to the documentation of this file.
1 
2 *CMZ : 16/04/97 11.35.54 by Unknown
3 *CMZ : 1.02/12 15/01/97 23.18.19 by P. Zucchelli
4 *CMZ : 1.02/10 14/01/97 16.20.11 by P. Zucchelli
5 *CMZ : 1.02/09 14/01/97 16.02.14 by P. Zucchelli
6 *CMZ : 1.02/06 13/01/97 17.29.17 by P. Zucchelli
7 *CMZ : 1.02/04 13/01/97 14.53.16 by P. Zucchelli
8 *CMZ : 1.02/01 12/01/97 16.45.28 by J. Brunner
9 *CMZ : 1.02/00 12/01/97 16.24.18 by J. Brunner
10 *CMZ : 1.01/51 04/07/96 10.22.19 by Piero Zucchelli
11 *CMZ : 1.01/50 23/05/96 12.34.50 by Piero Zucchelli
12 *CMZ : 1.01/49 29/01/96 15.55.13 by Piero Zucchelli
13 *CMZ : 1.01/48 15/01/96 15.30.50 by Piero Zucchelli
14 *CMZ : 1.01/47 11/01/96 09.41.56 by Piero Zucchelli
15 *CMZ : 1.01/46 09/01/96 11.43.51 by Piero Zucchelli
16 *CMZ : 1.01/45 08/01/96 14.21.12 by Piero Zucchelli
17 *CMZ : 1.01/44 05/01/96 18.02.33 by Piero Zucchelli
18 *CMZ : 1.01/42 15/12/95 BA 14.58.49 by Piero Zucchelli
19 *CMZ : 1.01/41 15/12/95 09.27.14 by Piero Zucchelli
20 *CMZ : 1.01/40 12/12/95 15.36.35 by Piero Zucchelli
21 *CMZ : 1.01/39 02/11/95 18.49.42 by Piero Zucchelli
22 *CMZ : 1.01/38 18/10/95 18.46.18 by Piero Zucchelli
23 *CMZ : 1.01/37 18/10/95 18.17.36 BY PIERO ZUCCHELLI
24 *CMZ : 1.01/36 31/07/95 18.02.18 BY PIERO ZUCCHELLI
25 *CMZ : 1.01/35 26/07/95 14.56.50 BY PIERO ZUCCHELLI
26 *CMZ : 1.01/34 25/07/95 11.29.30 BY PIERO ZUCCHELLI
27 *CMZ : 1.01/33 12/07/95 09.40.26 BY PIERO ZUCCHELLI
28 *CMZ : 1.01/32 02/06/95 20.27.59 BY PIERO ZUCCHELLI
29 *CMZ : 1.01/31 02/06/95 20.17.58 BY PIERO ZUCCHELLI
30 *CMZ : 1.01/29 02/06/95 19.47.43 BY PIERO ZUCCHELLI
31 *CMZ : 1.01/27 02/06/95 15.00.58 BY PIERO ZUCCHELLI
32 *CMZ : 1.01/24 29/05/95 15.39.50 BY PIERO ZUCCHELLI
33 *CMZ : 1.01/23 29/05/95 15.31.35 BY PIERO ZUCCHELLI
34 *CMZ : 1.01/22 27/05/95 16.17.50 BY PIERO ZUCCHELLI
35 *CMZ : 1.01/21 27/05/95 15.46.09 BY PIERO ZUCCHELLI
36 *CMZ : 1.01/20 27/05/95 15.12.35 BY PIERO ZUCCHELLI
37 *CMZ : 1.01/18 14/05/95 12.43.38 BY PIERO ZUCCHELLI
38 *CMZ : 1.01/15 14/05/95 11.39.34 BY PIERO ZUCCHELLI
39 *CMZ : 1.01/14 14/05/95 11.26.28 BY PIERO ZUCCHELLI
40 *CMZ : 1.01/13 14/05/95 11.21.51 BY PIERO ZUCCHELLI
41 *CMZ : 1.01/11 13/05/95 18.30.15 BY PIERO ZUCCHELLI
42 *CMZ : 1.01/10 28/04/95 14.19.28 BY PIERO ZUCCHELLI
43 *CMZ : 1.01/08 05/03/95 19.33.11 BY PIERO ZUCCHELLI
44 *CMZ : 1.01/06 05/03/95 10.42.02 BY PIERO ZUCCHELLI
45 *CMZ : 1.01/05 05/03/95 01.15.37 BY PIERO ZUCCHELLI
46 *CMZ : 1.01/04 05/03/95 01.00.25 BY PIERO ZUCCHELLI
47 *CMZ : 1.01/03 05/03/95 00.09.33 BY PIERO ZUCCHELLI
48 *CMZ : 1.01/01 23/09/94 13.01.24 BY PIERO ZUCCHELLI
49 *CMZ : 1.01/00 08/09/94 09.46.35 BY PIERO ZUCCHELLI
50 *CMZ : 1.00/00 22/08/94 14.08.45 BY PIERO ZUCCHELLI
51 *CMZ : 1.00/00 20/07/94 12.28.44 BY PIERO ZUCCHELLI
52 *-- AUTHOR :
53 C PROGRAM MAIN
54  SUBROUTINE jettarun
55 * IMPLICIT NONE
56  parameter(memor=8000000)
57  parameter(nmxhep=2000)
58  parameter(lunbeam=10)
59 
60 * INTEGER*4 MEMOR
61  INTEGER*4 ibadev,lepin,interaction,maxievt
62  REAL*4 ppxyz(3),ci,vdecy(4),bb(3),brf(3),xm(3),pm(3),ph(3)
63  COMMON /taupos / npa,npb
64  common/beri/jally,jein
65  COMMON /slate/isl(40)
66  common/runcom/imode
67  common/sbeam/ pnumber,neutype,vect(3),gkin(3),mestype,g4mes(4)
68  INTEGER jally(30),jarry(30),irawhead(11),keylist(50)
69  DOUBLE PRECISION hh(4)
70  INTEGER*4 daluaef(200),iprot
71  common/dalua/daluaef
72 *KEEP,LUDAT3.
73  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
74  SAVE /ludat3/
75 *KEEP,POLAR.
76 C--
77  COMMON /polariz/pol(4000,3)
78  REAL polarx(4)
79 *KEEP,LUDAT1.
80  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
81  SAVE /ludat1/
82 *KEEP,JETTA.
83 C--
84  parameter(icento=100)
85  parameter(isiz=93)
86  parameter(iof1=32)
87  parameter(iof2=83)
88  parameter(lux_level=4)
89  INTEGER*4 jtau(100),jpri(100),jstro(100)
90  REAL*4 ftuple(isiz)
91  common/jettagl/jtau,jpri,jstro
92  common/ntupla/ftuple,isfirst
93  common/beam/spec(icento)
94  COMMON /maxspec/rmaxspec,rintspec
95  common/sav/xminsav(icento),xmaxsav(icento),yminsav(icento),
96  & ymaxsav(icento),q2minsav(icento),q2maxsav(icento),
97  & w2minsav(icento),w2maxsav(icento),parimax(icento),
98  & ppsave(icento,3,4,5),paricor(icento),index,sigmasav(icento),
99  & xmsigma,xsect
100 
101 *KEEP,FOREFI.
102 C--
103  INTEGER*4 ievt
104  common/foreficass/ievt
105 
106 
107 *KEEP,HEPEVT.
108  DOUBLE PRECISION phep,vhep
109  common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),
110  &jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)
111  SAVE /hepevt/
112 
113 *KEEP,KEYS.
114  common/cfread/space(5000)
115  common/mykeys/ievar,if5cc,ineut,iinte,iferm,iflat,icoun,
116  & refix,imudo,ikat1,ikat2,ikat3,ikat4,ikat5,ikat6,
117  & inevt,ijak1,ijak2,iitdk,rptau,rxk0d,ntgr,idimuon,iglu,
118  & iqden,lome(2),ifiles,iccha,iseed,idsubs,ionem,ehac,ipsel,
119  & ihist
120 
121 
122 *KEEP,PERROR.
123 *-- AUTHOR : PIERO ZUCCHELLI 01/09/94
124  parameter(charmsens=10000)
125  common/myerr/icrack
126 
127 
128 *KEEP,zebra.
129 
130  parameter(nnq=1000000)
131 *
132  dimension lq(nnq),iq(nnq),q(nnq)
133  equivalence(q(1),iq(1),lq(9),jstruc(8))
134  COMMON /quest/iquest(100)
135  COMMON /xqstor/ixevt,ifence(16),jgeev,jstruc(99),jrefer(100),
136  +div12(nnq)
137  COMMON /fzlun/lunfz
138  common/mzioall/iogenf
139 
140 *KEND.
141 
142 
143 
144  common/wlist/ww1,ww2,ww3,ww5
145  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
146  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
147 
148  REAL*4 vnpalife(1000)
149  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
150  common/pawc/h(memor)
151  CHARACTER *8 ftags(isiz)
152 
153 
154  CALL readffky
155 
156 
157 * GRV HO/LO SET
158  lst(15)=iqden
159  lst(17)=ievar
160  lst(32)=if5cc
161  interaction=iinte
162  lst(33)=iferm
163  lst(37)=iflat
164  maxievt=icoun
165  energy_fix=refix
166  lst(38)=imudo
167  lepin =ineut
168  lst(10)=ntgr
169  lst(3)=3
170 
171 * random number initialization
172  CALL rluxgo(lux_level,iseed,0,0)
173 
174 * muon generation by charm and nu_e/anu_e
175  IF (abs(lepin).EQ.14) THEN
176  imureq=1
177  ELSE
178  imureq=0
179  ENDIF
180 
181  IF (idsubs.EQ.0) THEN
182  IF (idimuon.EQ.2) THEN
183 * Dplus
184  r1=0
185  r1m=0
186  DO io=367,377
187  mdme(io,1)=0
188  r1=r1+brat(io)
189  ENDDO
190  DO io=378,388
191  mdme(io,1)=1
192  r1m=r1m+brat(io)
193  ENDDO
194  DO io=389,429
195  mdme(io,1)=0
196  r1=r1+brat(io)
197  ENDDO
198 
199 * D0
200  r2=0
201  r2m=0
202  DO io=430,437
203  mdme(io,1)=0
204  r2=r2+brat(io)
205  ENDDO
206  DO io=438,445
207  mdme(io,1)=1
208  r2m=r2m+brat(io)
209  ENDDO
210  DO io=446,490
211  mdme(io,1)=0
212  r2=r2+brat(io)
213  ENDDO
214 
215 * D+_s
216  r3=0
217  r3m=0
218  DO io=491,496
219  r3=r3+brat(io)
220  mdme(io,1)=0
221  ENDDO
222  DO io=497,501
223  r3m=r3m+brat(io)
224  mdme(io,1)=1
225  ENDDO
226  DO io=502,523
227  r3=r3+brat(io)
228  mdme(io,1)=0
229  ENDDO
230 
231 * Lambda_c
232  r4=0
233  r4m=0
234  DO io=997,1003
235  r4=r4+brat(io)
236  mdme(io,1)=0
237  ENDDO
238  DO io=1004,1010
239  r4m=r4m+brat(io)
240  mdme(io,1)=1
241  ENDDO
242  DO io=1011,1072
243  r4=r4+brat(io)
244  mdme(io,1)=0
245  ENDDO
246 * now R* contain the branching ratios
247 
248  ra=r1m/(r1m+r1)
249  rb=r2m/(r2m+r2)
250  rc=r3m/(r3m+r3)
251  rd=r4m/(r4m+r4)
252 
253  rma=max(ra,rb,rc,rd)
254 
255  ra=ra/rma
256  rb=rb/rma
257  rc=rc/rma
258  rd=rd/rma
259 
260 * restore Dplus
261  brat(377)=1-ra
262  mdme(377,1)=1
263  DO io=378,388
264  brat(io)=brat(io)*ra/r1m
265  ENDDO
266 * restore D0
267  brat(437)=1-rb
268  mdme(437,1)=1
269  DO io=438,445
270  brat(io)=brat(io)*rb/r2m
271  ENDDO
272 * restore Ds
273  brat(496)=1-rc
274  mdme(496,1)=1
275  DO io=497,501
276  brat(io)=brat(io)*rc/r3m
277  ENDDO
278 * restore lambda
279  brat(1003)=1-rd
280  mdme(1003,1)=1
281  DO io=1004,1010
282  brat(io)=brat(io)*rd/r4m
283  ENDDO
284 
285  ENDIF
286  ELSE
287 * D+_s forced to tau and then...
288  mdme(491,1)=1
289  DO io=492,523
290  mdme(io,1)=0
291  ENDDO
292 * so tau to chosen channel ...
293  DO io=83,123
294  mdme(io,1)=0
295  ENDDO
296  IF (idsubs.EQ.1) THEN
297  mdme(84,1)=1
298  ELSEIF (idsubs.EQ.2) THEN
299  mdme(85,1)=1
300  ENDIF
301 
302 
303  ENDIF
304 
305 ********TAUOLA SECTION START
306 
307  CALL tauinit
308 
309 *******TAUOLA SECTION END
310 
311 
312 * PARTIAL DECAY RULES:
313 
314  mstj(22)=2
315 * 2 MM
316  parj(71)=2.0
317 *******INITIALIZE ZEBRA*****
318  CALL fzini
319  CALL mzini
320 
321  CALL hlimit(-memor)
322  CALL hropen(1,'histos','jetta.paw','N',1024,istat)
323  CALL hcdir('//histos',' ')
324  IF (istat.NE.0) THEN
325  WRITE(*,*)'+++MAIN: WARNING, HROPEN FAILED'
326  ENDIF
327 
328 * Differential cross section dsigma/dx/dy/de in pb
329  ftags(1) ='SIGMA'
330 * Bjorken X
331  ftags(2) ='X'
332 * Bjorken Y
333  ftags(3) ='Y'
334 * Interacting neutrino energy (GeV)
335  ftags(4) ='E'
336 * W**2 distribution (GeV**2)
337  ftags(5) ='W2'
338 * Q**2 distribution (GeV**2)
339  ftags(6) ='Q2'
340 * \nu distribution (GeV)
341  ftags(7) ='U'
342 * Fermi motion of nucleon (X-Y-Z) cohordinates
343  ftags(8) ='PFERX'
344  ftags(9) ='PFERY'
345  ftags(10)='PFERZ'
346 * Tau polarization vector
347  ftags(11)='POLX'
348  ftags(12)='POLY'
349  ftags(13)='POLZ'
350 * Primary Charged lepton LAB momentum (i.e. Tau for nutau, mu for numu)
351  ftags(14)='PLEPX'
352  ftags(15)='PLEPY'
353  ftags(16)='PLEPZ'
354 * Hadronic string momentum
355  ftags(17)='PSTRX'
356  ftags(18)='PSTRY'
357  ftags(19)='PSTRZ'
358 * Number of Charged particles in tau decay
359  ftags(20)='ICHGTAU'
360 * Number of Neutral particles in tau decay
361  ftags(21)='INEUTAU'
362 * Number of Charged particles in Hadronic shower
363  ftags(22)='ICHGPRI'
364 * Number of Neutral particles in Hadronic shower
365  ftags(23)='INEUPRI'
366 * Energy of Charged particles in tau decay*
367  ftags(24)='ECHGTAU'
368 * Energy of Neutral particles in tau decay
369  ftags(25)='ENEUTAU'
370 * Energy of Charged particles in Hadronic shower
371  ftags(26)='ECHGPRI'
372 * Energy of Neutral particles in Hadronic shower
373  ftags(27)='ENEUPRI'
374 * 2*P*k relativistic invariant
375  ftags(28)='TWOPK'
376 * 2*P*Q relativistic invariant
377  ftags(29)='TWOPQ'
378 * Type of nucleon hit
379  ftags(30)='NUCL'
380 * String energy
381  ftags(31)='ESTR'
382 * Invariant mass of the string
383  ftags(32)='WSTR'
384 * Primary Charged lepton Lab Energy (i.e. Tau for nutau, mu for numu)
385  ftags(iof1+1)='ELEP'
386 * Longitudinal polarization of tau
387  ftags(iof1+2)='LPOL'
388 * Momentum in tau rest frame of the Outgoing Charged particles (mu, pi-)
389 * summed over in 3 prong decays
390  ftags(iof1+3)='PVXRF'
391  ftags(iof1+4)='PVYRF'
392  ftags(iof1+5)='PVZRF'
393 * Event number
394  ftags(iof1+6)='EVT'
395 * Eventual Charm particle flag
396  ftags(iof1+7)='CHARM'
397 * mu minus momentum
398  ftags(iof1+8)='PMUM'
399 * mu plus momentum
400  ftags(iof1+9)='PMUP'
401 * charm decay length (lab frame)
402  ftags(iof1+10)='CHARLEN'
403 * charm type (Lund ID)
404  ftags(iof1+11)='CHARTYP'
405 * charm momentum, energy
406  ftags(iof1+12)='CHARP'
407  ftags(iof1+13)='CHARE'
408 * proton number (event-by-event beamfiles)
409  ftags(iof1+14)='PNUMB'
410 * charm three-momentum
411  ftags(iof1+15)='CHARPX'
412  ftags(iof1+16)='CHARPY'
413  ftags(iof1+17)='CHARPZ'
414 
415 * Energy in tau rest frame of the Outgoing Charged particles (mu, pi-)
416 * Polarization Intensity
417  ftags(51)='MPOL'
418 * Center of Mass Primary Lepton momentum, plus modulo
419  ftags(52)='PLEPXCMS'
420  ftags(53)='PLEPYCMS'
421  ftags(54)='PLEPZCMS'
422  ftags(55)='PLEPCMS'
423 * Center of mass Cos(theta) of the primary lepton
424  ftags(56)='CSLEPCMS'
425 * Helicity, i.e. projection of Polarization vector on tau momentum
426  ftags(57)='HELIX'
427 * visible momentum/energy from tau decay (neutrino excluded)
428  ftags(58)='PVXTAU'
429  ftags(59)='PVYTAU'
430  ftags(60)='PVZTAU'
431  ftags(61)='EVTAU'
432 * muon from tau decay: momentum
433  ftags(62)='PMUX'
434  ftags(63)='PMUY'
435  ftags(64)='PMUZ'
436 * Total visible energy
437  ftags(65)='ECAL'
438 * Total Electromagnetic energy
439  ftags(66)='EEM'
440 * Total hadronic energy
441  ftags(67)='EHAD'
442 * Total track multiplicity
443  ftags(68)='NE'
444 * Total electromagnetic track multiplicity
445  ftags(69)='NEEM'
446 * Total hadronic track multiplicity (ch+neutrals)
447  ftags(70)='NEHAD'
448 * Total Neutral multiplicity
449  ftags(71)='NEN'
450 * Total Neutral electromagnetic multiplicity
451  ftags(72)='NENEM'
452 * Total Neutral hadronic multiplicity
453  ftags(73)='NENHAD'
454 * Muon impact parater (distance from vertex)
455  ftags(74)='BMU'
456 * Pion impact parameter (distance from vertex)
457  ftags(75)='BPI'
458 * nucleon daughters, momentum and energy
459  ftags(76)='PXNUC'
460  ftags(77)='PYNUC'
461  ftags(78)='PZNUC'
462  ftags(79)='ENUC'
463 * tau decay pathlength (LAB frame)
464  ftags(80)='TAULEN'
465 * electron in tau decay:momentum
466  ftags(81)='PELECX'
467  ftags(82)='PELECY'
468  ftags(83)='PELECZ'
469 * random transverse position of events
470  ftags(iof2+1)='XEMU'
471  ftags(iof2+2)='YEMU'
472 * muon momentum OUT of shower plane
473  ftags(iof2+3)='PTMOP'
474 * shower momentum OUT of muon plane
475  ftags(iof2+4)='PTHOP'
476 * muon angle w.r.t. hadron plane
477  ftags(iof2+5)='THEMOP'
478 * hadron angle w.r.t. muon plane
479  ftags(iof2+6)='THEHOP'
480 * integrated cross section dsigma/de
481  ftags(iof2+7)='SIGMAPB'
482 * transverse position of events as from input-neutrino files
483  ftags(iof2+8)='EMUX'
484  ftags(iof2+9)='EMUY'
485 
486 
487 
488 
489  CALL hbookn(11,'X-sect',isiz,'//histos',50000,ftags)
490 
491 
492 C...................... READ DATACARD AND INITIALIZE LEPTO
493 * INACTIVE LEPTON EVOLUTION IN ORDER TO STUDY THE PRIMARY HADRON SHOWER
494 * LST(4)=0
495 * TEMPORARY: NO PHI ROTATION
496 * LST(6)=0
497 * HADRONIZATION AND GENERATION OF SHOWER
498  lst(8)=iglu
499 * LST(8)=2
500 * W**2 SCALE AS SUGGESTED FOR NOT SO LOW X INTERACTIONS
501 * LST(9)=2
502 * ISOSCALAR/EMULSIONS TARGET
503 * PARL(1)=2.
504 * PARL(2)=1.
505  parl(1)=30.4
506  parl(2)=15.2
507 *INITIAL ENERGIES FROM P IN LUJETS
508 * LST(17)=1
509 
510 * INCREASE NUMBER OF ERRORS TO AVOID STOP
511  mstu(21)=1
512  mstu(22)=10
513  CALL cats
514 
515 * TARGET REMNANTS ....WHO CARE? BUT WE PREFER A BARYON....
516  lst(14)=1
517 * GRID SUITABLE FOR FIXED TARGET < 300 GEV
518  lst(19)=1
519 * ADDED TAU LEPTON MASS EFFECTS
520 * THIS IS TAU CC
521 * LST(32)=1
522 * LEPIN=16
523 * THIS IS MU CC
524 * LST(32)=0
525 * LEPIN=14
526 * ADD FERMI MOMENTUM SMEARING ON THE NUCLEON
527 * LST(33)=1
528 * LST(34)=1 INHIBITS THE TAU DECAY
529  lst(34)=0
530 * LST(35) CONTAINS THE LOWER W2 LIMIT FOR PARTON SHOWER EVOLUTION
531 *~ 0.938+1 **2
532  lst(35)=2.0
533 * LST(35)=0.01
534 * TAUOLA TAU DECAY
535  lst(36)=1
536 * FLAT ENERGY DISTRIBUTION
537 * LST(37)=1
538 * GENERAL RUN PARAMETERS
539 * INTERACTION=2
540 * MAXIEVT=10000
541 * TO SET A MUON TAU SELECTION: 1=ONLY MU,2=NO MU,0=EVERYTHING
542 * LST(38)=0
543  IF (lst(36).EQ.1) lst(34)=1
544 
545 
546  CALL gentable(0,lepin,energy_fix,0.,interaction)
547 
548 
549  IF (lome(1).LT.lome(2)) THEN
550  CALL lulist(12)
551  ENDIF
552  iprot=0
553 C...................... START OF EVENT
554 
555  istatus=2
556  10 CONTINUE
557  CALL vzero(ftuple,isiz)
558  CALL mzwipe(ixevt)
559  IF (lepin.EQ.16) neuforce=51
560  IF (lepin.EQ.14) neuforce=51
561  IF (lepin.EQ.-14) neuforce=52
562  IF (lepin.EQ.12) neuforce=49
563  IF (lepin.EQ.-12) neuforce=50
564 C........................... CALL LEPTO
565 
566  ibadev=0
567  20 CONTINUE
568  icrack=0
569 
570 * take next neutrino
571 
572  IF (lst(17).GT.0) THEN
573 
574  39 CONTINUE
575  IF (ihist.EQ.0) THEN
576 *single neutrino operations
577  CALL getneu(ipnumber,neutype,vect,gkin, mestype,g4mes,
578  + neuforce,istatus)
579  IF (istatus.NE.4) THEN
580  pnumber=ipnumber
581  ELSE
582  WRITE(*,*)' END OF NEUTRINO BEAMDATA:RELOOP'
583  istatus=2
584  goto 39
585  ENDIF
586  ELSE
587 *simulate a real neutrino using histogram file
588 
589  CALL gethneu(ipnumber,neutype,vect,gkin, mestype,g4mes,
590  + neuforce,istatus)
591  ENDIF
592 
593 C PNUMBER = current proton number
594 C NEUTYPE = type of neutrino;
595 C 51= muon neutrino
596 C 52= muon antineutrino
597 C 49= electron neutrino
598 C 50= electron antineutrino
599 C VECT(3) = coordinates of neutrino origin
600 C GKIN(3) = momentum components of the neutrino
601 
602 
603 * to be changed when nu_E oscillations become of interest
604  IF (lepin.EQ.16.AND.neutype.NE.51) goto 39
605  IF (lepin.EQ.14.AND.neutype.NE.51) goto 39
606  IF (lepin.EQ.-14.AND.neutype.NE.52) goto 39
607  IF (lepin.EQ.12.AND.neutype.NE.49) goto 39
608  IF (lepin.EQ.-12.AND.neutype.NE.50) goto 39
609 
610  ptest=sqrt(gkin(1)**2+gkin(2)**2+gkin(3)**2)
611  IF (ptest.LE.3.5.AND.lepin.EQ.16) goto 39
612  pfin=distrr(ptest)
613 
614  IF (pfin.EQ.0) goto 39
615 
616  CALL btocho2(vect,gkin,emux,emuy)
617 
618  ftuple(iof2+8)=emux
619  ftuple(iof2+9)=emuy
620 
621  p(1,1)=0.
622  p(1,2)=0.
623  p(1,3)=pfin
624 * P(1,3)=100.
625  p(1,4)=p(1,3)
626  p(1,5)=0.
627  ENDIF
628 
629  CALL vzero(ppxyz,3)
630 
631 c IF (LST(33).EQ.1.AND.LST(17).NE.0) CALL FERMII(PPXYZ)
632  IF( lst(33).EQ.1) CALL fermii(ppxyz)
633  DO i=1,3
634  ftuple(7+i)=ppxyz(i)
635  END DO
636 
637  p(2,1)=ppxyz(1)
638  p(2,2)=ppxyz(2)
639  p(2,3)=ppxyz(3)
640  rnuckin2=p(2,1)**2+p(2,2)**2+p(2,3)**2
641  p(2,4)=sqrt( rnuckin2 +p(2,4)**2)
642  p(2,5)=0.938
643 
644 
645  ibadev=ibadev+1
646 * WRITE(*,*)' NU_TAU ENERGY=',P(1,4)
647 * WRITE(*,*)' NUCLEON ENERGY=',P(2,4)
648 
649 
650  CALL cats
651  CALL lepto
652 * CALL LULIST(3)
653 
654  IF (icrack.NE.0) THEN
655  WRITE(*,*)'+++MAIN: ICRACK SAFETY TRAPPED'
656  goto 20
657  ENDIF
658 
659  IF (lst(21).NE.0) THEN
660  IF (lst(21).NE.3131) WRITE (*,10100) lst(21),ibadev
661 10100 FORMAT (/,10x,'!!!!!! LST(21)=',i10,' AFTER ',i2,' CALL TO LEPTO')
662  goto 20
663  ENDIF
664 *
665 
666  CALL parupd
667 
668  IF (abs(p(2,3)+p(1,3)).LT.0.01) THEN
669  WRITE(*,*)'ERROR CMS FRAME!! 28,29=',lst(28),lst(29)
670  goto 20
671  ENDIF
672 
673  IF (lst(32).EQ.1) THEN
674 * TRANSFORM TO THE LEPTON CMS TO CALCULATE ITS POLARIZATION
675  DO i=1,3
676  bb(i)=-p(4,i)/p(4,4)
677  END DO
678 * WRITE(*,*)'BB=',BB
679  CALL lurobo(0.0,0.0,bb(1),bb(2),bb(3))
680 * NOW PARTICLES ARE IN THE SCATTERED LEPTON CMS
681 
682 
683  rml=p(4,5)
684  rmm=p(2,5)
685  ee=parl(21)/2./rmm
686  qq2=+q2
687  qm2=qq2+rml**2
688 
689  nu=u*rmm
690 
691  frac=qm2*ww1 + (2.*ee*(ee-u) - 0.5*qm2)*ww2 - 0.5/rmm**2*(2.*
692  + rmm*ee*qq2 - nu*qm2)*ww3 - rml**2/rmm*ee*ww5
693 
694  factk=2.*ww1 -ww2 - ee/rmm*ww3 +(ee-u)/rmm*ww5
695  factp=2.*ee/rmm*ww2 - qm2/2./rmm**2*(ww3+ww5)
696 
697  DO i=1,3
698  pol(4,i)=rml*(factk*p(1,i)+factp*p(2,i))/frac
699  polarx(i)=pol(4,i)
700  END DO
701 
702  pmodul=0.
703  DO i=1,3
704  pmodul=pmodul+pol(4,i)**2
705  END DO
706  IF(pmodul.GT.1.05) WRITE(*,*)'PMODUL>1 ',sqrt(pmodul)
707 
708 * CALL LUROBO(0.,0.,-BB(1),-BB(2),-BB(3))
709  CALL ludbrb(1,4,0.,0.,dble(-bb(1)),dble(-bb(2)),dble(-bb(3)))
710 
711  ENDIF
712 
713  IF (lst(32).EQ.2) THEN
714  DO i=1,3
715  polarx(i)=0.
716  END DO
717  ENDIF
718 
719 
720 C DECAY....
721  IF (lst(36).EQ.1.AND.lepin.EQ.16) THEN
722 * REMEMEBER, NEEDS TAU POSITION AND TAU POLARIZATION:NPA,NPB
723  npb=0
724  npa=0
725  DO i=1,n
726  IF(abs(k(i,2)).EQ.15) THEN
727  npa=i
728  goto 30
729  ENDIF
730  END DO
731 
732  30 CONTINUE
733 
734  IF (npa.NE.0) THEN
735 C...CHOOSE LIFETIME AND DETERMINE DECAY VERTEX.
736  kfa=iabs(k(npa,2))
737  kc=lucomp(kfa)
738  IF(k(npa,1).EQ.5) THEN
739  v(npa,5)=0.
740  ELSEIF(k(npa,1).NE.4) THEN
741  v(npa,5)=-pmas(kc,4)*log(rlu(0))
742  ENDIF
743  DO 40 j=1,4
744  vdecy(j)=v(npa,j)+v(npa,5)*p(npa,j)/p(npa,5)
745  40 CONTINUE
746 
747  nbak=n
748 
749 
750 * CALL LULIST(3)
751  DO i=1,3
752  bb(i)=-p(4,i)/p(4,4)
753  END DO
754 * WRITE(*,*)'BB=',BB
755 * CALL LUROBO(0.0,0.0,BB(1),BB(2),BB(3))
756  CALL ludbrb(1,4,0.,0.,dble(bb(1)),dble(bb(2)),dble(bb(3)))
757 
758 * PATCH TO RECOVER FROM LUHEPC BUG
759  DO ii=1,n
760  vnpalife(ii)=v(ii,5)
761  END DO
762  CALL luhepc(1)
763  CALL dexay(2,polarx)
764 * CALL DEKAY(2,HH)
765 * CALL DEKAY(12,HH)
766  CALL luhepc(2)
767 *
768  DO ik=1,4
769  ftuple(iof1+2+ik)=0.
770  END DO
771  DO ii=nbak+1,n
772  IF(abs(k(ii,2)).NE.16.AND.abs(k(ii,2)).NE.14.AND. abs(k(ii,
773  + 2)).NE.12) THEN
774  DO ik=1,4
775  ftuple(iof1+2+ik)=ftuple(iof1+2+ik)+p(ii,ik)
776  END DO
777  ENDIF
778  END DO
779 
780 
781 * CALL LULIST(3)
782 * APPARENT BUG IN LUHEPC
783  CALL lurobo(0.0,0.0,-bb(1),-bb(2),-bb(3))
784 
785  ftuple(58)=0.
786  ftuple(59)=0.
787  ftuple(60)=0.
788  ftuple(61)=0.
789 
790 
791  DO ii=1,nbak
792  v(ii,5)=vnpalife(ii)
793  END DO
794  DO ii=nbak+1,n
795  DO jj=1,4
796  v(ii,jj)=vdecy(jj)
797  END DO
798  END DO
799 * CALL LULIST(3)
800 * NEW STRATEGY: NO DECAYS EXCEPT TAU AND CHARM
801  CALL luexec
802  DO ii=nbak+1,n
803  IF (k(ii,2).EQ.13) THEN
804  DO ik=1,3
805  ftuple(61+ik)=p(ii,ik)
806  END DO
807  ELSEIF (k(ii,2).EQ.11) THEN
808  DO ik=1,3
809  ftuple(80+ik)=p(ii,ik)
810  END DO
811  ENDIF
812 
813  IF(abs(k(ii,2)).NE.16.AND.abs(k(ii,2)).NE.14.AND. abs(k(ii,
814  + 2)).NE.12) THEN
815  DO ik=1,4
816  ftuple(57+ik)=ftuple(57+ik)+p(ii,ik)
817  END DO
818  ENDIF
819  END DO
820 
821  ENDIF
822  ENDIF
823 
824  imu=0
825  ichm=0
826  ipselfound=0
827  DO ii=1,n
828  iaki=abs(k(ii,2))
829  IF (iaki.EQ.92.OR.iaki.EQ.91) THEN
830  estr=p(ii,4)
831  IF (ehac.NE.0) THEN
832  IF (estr.GT.ehac) THEN
833  iehac=iehac+1
834  goto 10
835  ENDIF
836  ENDIF
837  IF (estr.EQ.0) THEN
838  WRITE(*,*)'+++MAIN: STRING ENERGY=0,EVT=',ievt
839  goto 10
840  ENDIF
841  ENDIF
842 
843  IF (iaki.GE.400
844  + .AND.iaki.LE.500
845  + .OR.iaki.EQ.4122) THEN
846  IF (idsubs.EQ.0) THEN
847  IF (iccha.EQ.0) THEN
848  ichm=ichm+1
849  ELSE
850  IF (iaki.EQ.411.OR.iaki.EQ.431.OR.iaki.EQ.4122) THEN
851  ichm=ichm+1
852  ENDIF
853  ENDIF
854  ELSE
855  IF (iaki.EQ.431) ichm=ichm+1
856  ENDIF
857  ENDIF
858 
859  IF (iaki.EQ.abs(ipsel)) THEN
860  ipselfound=1
861  ENDIF
862 
863 
864  IF (iaki.EQ.13) THEN
865  imu=imu+1
866  IF (k(ii,2).EQ.13) THEN
867  ihm=ii
868  ELSE
869  ihmp=ii
870  ENDIF
871  ENDIF
872  END DO
873  50 CONTINUE
874 
875 
876  ipi=0
877  DO ii=nbak+1,n
878  IF (k(ii,2).EQ.-211) THEN
879  ipi=1
880  ihp=ii
881  goto 60
882  ENDIF
883  END DO
884  60 CONTINUE
885 
886  IF (ipselfound.EQ.0..AND.ipsel.NE.0) THEN
887  ipselthrow=ipselthrow+1
888  goto 20
889  ENDIF
890 
891  IF (idimuon.GE.1.AND.ichm.LT.1) THEN
892  goto 20
893  ENDIF
894 
895  IF (idimuon.GE.2.AND.imu.LE.imureq) THEN
896 * WRITE(*,*)' TOO FEW MUONS DETECTED W.R.T. REQUIRED'
897 * CALL LULIST(3)
898  mumiss=mumiss+1
899  goto 20
900  ENDIF
901 
902 
903  IF ((imu.GE.1.AND.lst(38).EQ.2).OR.
904  + (imu.EQ.0.AND.lst(38).EQ.1)) THEN
905  goto 20
906  ENDIF
907 
908 
909 * FUNDAMENTAL HELICITY CROSS_CHECK
910 
911 
912  DO jij=1,3
913  brf(jij)=(p(1,jij)+p(2,jij))/(p(1,4)+p(2,4))
914  END DO
915 
916  CALL ludbrb(1,4,0.,0.,dble(-brf(1)),dble(-brf(2)),dble(-brf(3)))
917 * CALL LUROBO(0.0,0.0,-BRF(1),-BRF(2),-BRF(3))
918 * CALL LULIST(1)
919 
920  ftuple(55)=0.
921  DO jij=1,3
922  ftuple(51+jij)=p(4,jij)
923  ftuple(55)=ftuple(55)+p(4,jij)**2
924  END DO
925  ftuple(55)=sqrt(ftuple(55))
926  ftuple(51)=sqrt(polarx(1)**2+polarx(2)**2+polarx(3)**2)
927 
928  ftuple(56)=(p(1,1)*p(4,1)+p(1,2)*p(4,2)+p(1,3)*p(4,3)) /p(1,4)/
929  +ftuple(55)
930 
931  IF (if5cc.EQ.1) THEN
932  ftuple(57)=(polarx(1)*ftuple(52)+polarx(2)*ftuple(53)+
933  + polarx(3)* ftuple(54))/ftuple(55)/ftuple(51)
934  ENDIF
935 
936  CALL ludbrb(1,4,0.,0.,dble(brf(1)),dble(brf(2)),dble(brf(3)))
937 * CALL LUROBO(0.0,0.0,BRF(1),BRF(2),BRF(3))
938 
939  IF (imu.EQ.1) THEN
940  popi=p(ihm,1)**2+p(ihm,2)**2+p(ihm,3)**2
941  tvar=-(v(ihm,1)*p(ihm,1)+v(ihm,2)*p(ihm,2)+
942  + v(ihm,3)*p(ihm,3))/popi
943 
944  ftuple(74)=sqrt(
945  + (v(ihm,1)+p(ihm,1)*tvar)**2+
946  + (v(ihm,2)+p(ihm,2)*tvar)**2+
947  + (v(ihm,3)+p(ihm,3)*tvar)**2 )
948  ENDIF
949 
950  IF (imu.EQ.2) THEN
951  ftuple(iof1+8)=sqrt(p(ihm,1)**2+p(ihm,2)**2+p(ihm,3)**2)
952  ftuple(iof1+9)=sqrt(p(ihmp,1)**2+p(ihmp,2)**2+p(ihmp,3)**2)
953  ENDIF
954 
955 
956  IF (ipi.EQ.1) THEN
957  popi=p(ihp,1)**2+p(ihp,2)**2+p(ihp,3)**2
958  tvar=-(v(ihp,1)*p(ihp,1)+v(ihp,2)*p(ihp,2)+
959  + v(ihp,3)*p(ihp,3))/popi
960 
961  ftuple(75)=sqrt(
962  + (v(ihp,1)+p(ihp,1)*tvar)**2+
963  + (v(ihp,2)+p(ihp,2)*tvar)**2+
964  + (v(ihp,3)+p(ihp,3)*tvar)**2 )
965  ENDIF
966 
967 
968  temp=sqrt(p(4,1)**2+p(4,2)**2+p(4,3)**2)
969  ftuple(iof1+1)=p(4,4)
970  ftuple(iof1+2)=(polarx(1)*p(4,1)+polarx(2)*p(4,2)+
971  +polarx(3)*p(4,3))
972  +/temp
973  ftuple(4)=p(1,4)
974  CALL hfill(1000,p(1,4),0.,1.)
975  CALL hfill(1001,sqrt(rnuckin2),0.,1.)
976  CALL hfill(1002,sqrt(w2),0.,1.)
977  CALL hfill(1003,sqrt(q2),0.,1.)
978  CALL hfill(1006,p(1,4),0.,ftuple(1))
979  ftuple(5)=w2
980  ftuple(6)=q2
981  ftuple(7)=u
982  ftuple(28)=parl(21)
983  ftuple(29)=parl(22)
984  ftuple(30)=k(2,2)
985  DO i=1,3
986  ftuple(13+i)=p(4,i)
987  END DO
988  DO i=1,3
989  ftuple(i+10)=pol(4,i)
990  END DO
991 
992  chk1=0
993  chk2=0
994  rfact=1
995  DO i=1,n
996 
997  IF ((i.EQ.4.AND.v(i,5).EQ.0).OR.(k(i,1).LE.10.AND.i.GT.4)) THEN
998  chk1=chk1+p(i,1)
999  chk2=chk2+p(i,2)
1000  ENDIF
1001 
1002  IF (k(i,3).EQ.2) THEN
1003 * NUCLEON REMNANTS
1004  DO ij=1,4
1005  ftuple(75+ij)=p(i,ij)
1006  END DO
1007  ENDIF
1008 
1009  IF (k(i,2).EQ.91) THEN
1010 * this takes into account, at the checking level,
1011 * that clustering requires some "forced" momentum conservation
1012 * arising from the initial transverse momenta of the quarks
1013 * inside the nucleon
1014  rfact=10
1015  ENDIF
1016 
1017  IF (k(i,2).EQ.92.OR.k(i,2).EQ.91) THEN
1018  DO ij=1,3
1019  ftuple(16+ij)=p(i,ij)
1020  ph(ij)=p(i,ij)
1021  END DO
1022  ENDIF
1023 
1024  IF (k(i,2).EQ.13) THEN
1025  DO ij=1,3
1026  pm(ij)=p(i,ij)
1027  END DO
1028  ENDIF
1029 
1030 
1031  IF (k(i,2).EQ.15) THEN
1032 * THIS IS THE TAU
1033  CALL hfill(1004,p(i,4),0.,1.)
1034  ENDIF
1035 
1036  IF ((k(i,2).LT.10).AND.k(i,3).EQ.0) THEN
1037 * THIS IS THE FIRST PRIMARY PARTON TAKING AWAY ALL THE ENERGY
1038  CALL hfill(1005,p(i,4),0.,1.)
1039  ENDIF
1040 
1041  END DO
1042 
1043 
1044  chk1=chk1-p(2,1)
1045  chk2=chk2-p(2,2)
1046  relerr=0.03*rfact
1047  IF (abs(chk1).GT.relerr.OR.abs(chk2).GT.relerr) THEN
1048  CALL lulist(3)
1049  WRITE(*,*)'ERROR IN CHK',chk1,chk2
1050  goto 10
1051  ENDIF
1052 
1053  70 CONTINUE
1054 
1055 
1056 
1057  ievt=ievt+1
1058 
1059  CALL jetmc
1060 * NOW WE HAVE A MONTECARLO SEPRATION OF THE TWO JETS...
1061  CALL jetta
1062 * WRITE(*,*)'W2,U,Q2,X,Y=',W2,U,Q2,X,Y
1063 
1064 
1065  IF(ievt.GE.lome(1).AND.ievt.LE.lome(2)) THEN
1066  WRITE(*,*)'**********************************'
1067  WRITE(*,*)'********LOOK AT ME****************'
1068  WRITE(*,*)'EVENT NUMBER:',ievt
1069  WRITE(*,*)'**********************************'
1070  CALL lulist(3)
1071  ENDIF
1072 
1073 C...................... END OF EVENT
1074  IF (mod(ievt,100).EQ.0) THEN
1075  WRITE(*,*)'EVENTS=',ievt,'SIGMA=',parl(24)
1076  ENDIF
1077 
1078 
1079  test=p(1,4)+p(2,4)-ftuple(31)-p(4,4)
1080 
1081  IF(test.LT.-0.2) THEN
1082  WRITE(*,*)'...HERE BOZZO:EVENT/LST(24)',ievt,lst(24)
1083 * WRITE(*,*)'BEGIN BOZZO EVENT,EVT=',IEVT,' ISFIRST=',ISFIRST
1084 * CALL LULIST(3)
1085 * WRITE(*,*)'END BOZZO EVENT,EVT=',IEVT
1086  ELSE
1087 * WRITE(*,*)'GOOD EVENT,EVT=',IEVT,' ISFIRST=',ISFIRST
1088 * this IS an event, book banks
1089  IF (jgeev.NE.0) CALL mzdrop(ixstor,jgeev,'.')
1090  CALL mzbook(ixevt,jgeev,jgeev,2,'GEEV',4,4,0,2,0)
1091  CALL evtinfo
1092  CALL jettout
1093  CALL mzbook(ixevt,jgelu,jgeev,-2,'GELU',n,n,0,2,0)
1094  DO ias=1,n
1095  jgelu=lq(jgeev-2)
1096  CALL mzbook(ixevt,jgeln,jgelu,-ias,'GELN',0,0,16,3,0)
1097  DO iat=1,5
1098  q(jgeln+iat)=k(ias,iat)
1099  q(jgeln+iat+5)=p(ias,iat)
1100  q(jgeln+iat+10)=v(ias,iat)
1101  q(jgeln+16)=daluaef(ias)
1102  ENDDO
1103  ENDDO
1104  CALL zverif(ixevt,iflrtn,'Verification')
1105  keylist(1)=121
1106  keylist(2)=1990
1107  keylist(3)=-ievt
1108  keylist(4)=-99999
1109 * CALL DZSHOW('GEEV Bank:',0,JGEEV,'BLV',0,0,0,0)
1110  CALL fzout(lunfz,ixevt,0,1,'Z',2,4,keylist)
1111  CALL fzout(lunfz,ixevt,jgeev,0,' ',2,1,1990)
1112  CALL fzout(lunfz,ixevt,0,0,'Z',2,1,-1)
1113  IF(ievt.GE.lome(1).AND.ievt.LE.lome(2)) THEN
1114  WRITE(*,*)'**********************************'
1115  ENDIF
1116  ENDIF
1117 
1118 
1119 * OUT OF PLANE ANALYSIS
1120 
1121  phl=sqrt(ph(1)**2+ph(2)**2+ph(3)**2)
1122  pml=sqrt(pm(1)**2+pm(2)**2+pm(3)**2)
1123 
1124  CALL orth(po,pm,ph)
1125  IF (phl.GT.0.AND.pml.GT.0) THEN
1126  ftuple(iof2+3)=po
1127  ENDIF
1128  IF (pml.GT.0) THEN
1129  ftuple(iof2+5)=acos(pm(3)/pml)
1130  ENDIF
1131 
1132  CALL orth(po,ph,pm)
1133  ftuple(iof2+4)=po
1134  IF (phl.GT.0) THEN
1135  ftuple(iof2+6)=acos(ph(3)/phl)
1136  ENDIF
1137 
1138  ftuple(iof2+7)=xsect
1139  ftuple(iof1+14)=pnumber
1140 
1141  IF(ievt.LE.10000) THEN
1142  ftuple(iof1+6)=ievt
1143 c WRITE(*,5341) ievt
1144 c WRITE(*,5342) ineut,interaction,lst(22),ftuple(4)
1145  WRITE(88,5341) ievt,n
1146  WRITE(88,5342) ineut,interaction,lst(22),ftuple(4)
1147  do ms=1,n
1148  write(88,5343) ms,k(ms,1),k(ms,2),k(ms,3),k(ms,4),
1149  +k(ms,5),p(ms,1),p(ms,2),p(ms,3),p(ms,4)
1150  end do
1151 5341 FORMAT(1x,i6,1x,i6)
1152 5342 FORMAT(1x,3i6,e15.7)
1153 5343 format(1x,i3,5i6,4e15.7)
1154  CALL hfn(11,ftuple)
1155  ENDIF
1156 * CALL LUEDIT(13)
1157 * CALL LULIST(3)
1158  jarry(jein)=jarry(jein)+1
1159  IF (ievt.LT.maxievt) goto 10
1160 
1161  3131 CONTINUE
1162  IF (lst(36).EQ.1) THEN
1163  CALL dexay(100,polarx)
1164  DO iji=1,30
1165  ijeje=ijeje+jarry(iji)
1166  ijaja=ijaja+jally(iji)
1167  END DO
1168  DO iji=1,30
1169  WRITE(*,*)'JARRY-JALLY JAKER SAYS',float(jarry(iji))/ijeje,
1170  + float(jally(iji))/ijaja,'FOR JAK',iji
1171  END DO
1172  ENDIF
1173  CALL fzrun(lunfz,-99999,0,0)
1174  CALL fzclos
1175  CALL hcdir('//histos',' ')
1176  CALL hldir('//histos','T')
1177  CALL hrout(11,icycle,' ')
1178  CALL hrend('histos')
1179  WRITE(*,*)' MISSED MUONS in DIMUON GENERATION:',mumiss,' IN ',
1180  + ievt,' EVENTS (',float(mumiss)/float(ievt),'%)'
1181  WRITE(*,*)' REJECTED EVENTS FOR EHAD CUT:',iehac,' IN ',
1182  + ievt,' EVENTS (',float(iehac)/float(ievt),'%)'
1183  WRITE(*,*)' REJECTED EVENTS FOR PARTICLE ID=',ipsel,
1184  +':KEPT ',
1185  + ievt,' REJECTED',ipselthrow
1186 
1187  stop
1188  END
1189 *CMZ : 04/03/97 13.03.17 by Unknown
1190 *CMZ : 1.01/51 24/05/96 11.17.19 by Piero Zucchelli
1191 *CMZ : 1.01/40 11/12/95 19.22.51 by Piero Zucchelli
1192 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
1193 *CMZ : 1.01/08 05/03/95 19.28.31 BY PIERO ZUCCHELLI
1194 *CMZ : 1.01/04 05/03/95 00.45.11 BY PIERO ZUCCHELLI
1195 *CMZ : 1.01/03 05/03/95 00.22.25 BY PIERO ZUCCHELLI
1196 *CMZ : 1.00/00 15/08/94 03.58.02 BY UNKNOWN
1197 *CMZ : 1.00/00 20/07/94 12.12.32 BY PIERO ZUCCHELLI
1198 *-- AUTHOR :
1199 C **********************************************************************
1200 
1201  SUBROUTINE lepto
1202 
1203 
1204 
1205 C...ADMINISTER THE GENERATION OF AN EVENT.
1206 C...NOTE: IF ERROR FLAG LST(21) IS NON-ZERO, NO PROPER EVENT GENERATED.
1207 
1208  COMMON /lintrl/ psave(3,4,5),ksave(4),xmin,xmax,ymin,ymax,
1209  +q2min,q2max,w2min,w2max,ilep,inu,ig,iz
1210  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
1211  COMMON /linter/ pari(40),ewqc(2,2,8),qc(8),zl(2,4),zq(2,8),pq(17)
1212  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
1213  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
1214  COMMON /lboost/ dbeta(2,3),stheta(2),sphi(2),pb(5),phir
1215  COMMON /ardat1/ para(40),msta(40)
1216  common/wlist/ww1,ww2,ww3,ww5
1217 *KEEP,POLAR.
1218 C--
1219  COMMON /polariz/pol(4000,3)
1220  REAL polarx(4)
1221 *KEEP,JETTA.
1222 C--
1223  parameter(icento=100)
1224  parameter(isiz=93)
1225  parameter(iof1=32)
1226  parameter(iof2=83)
1227  parameter(lux_level=4)
1228  INTEGER*4 jtau(100),jpri(100),jstro(100)
1229  REAL*4 ftuple(isiz)
1230  common/jettagl/jtau,jpri,jstro
1231  common/ntupla/ftuple,isfirst
1232  common/beam/spec(icento)
1233  COMMON /maxspec/rmaxspec,rintspec
1234  common/sav/xminsav(icento),xmaxsav(icento),yminsav(icento),
1235  & ymaxsav(icento),q2minsav(icento),q2maxsav(icento),
1236  & w2minsav(icento),w2maxsav(icento),parimax(icento),
1237  & ppsave(icento,3,4,5),paricor(icento),index,sigmasav(icento),
1238  & xmsigma,xsect
1239 
1240 *KEND.
1241  DOUBLE PRECISION dbetatmp(3)
1242  DOUBLE PRECISION dtheta,dphi,dbeta,detot,dari29,dari30
1243  REAL*4 bb(3)
1244  dimension spq(17)
1245  DATA nummis,nwarn/0,10/,dari29,dari30/2*0.d0/
1246 
1247  isfirst=1
1248 
1249  10 lst(21)=0
1250  DO 20 i=1,10
1251  DO 20 j=1,5
1252  k(i,j)=0
1253  20 v(i,j)=0.
1254  DO 30 i=1,4
1255  k(i,1)=21
1256  30 k(i,2)=ksave(i)
1257  k(4,1)=1
1258  n=2
1259  IF(lst(17).NE.0.AND.lst(2).GT.0) THEN
1260 C...LEPTON AND/OR NUCLEON ENERGY MAY VARY FROM EVENT TO EVENT,
1261 C...MOMENTUM VECTORS TAKEN FROM P(I,1), P(I,2) AND P(I,3), I=1,2
1262  DO 50 i=1,2
1263  DO 40 j=1,5
1264  IF(isfirst.EQ.1) THEN
1265  psave(3,i,j)=p(i,j)
1266  ELSE
1267  p(i,j)=psave(3,i,j)
1268  ENDIF
1269  40 CONTINUE
1270  p(i,5)=ulmass(k(i,2))
1271  p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
1272 C...Momentum vectors from PSAVE if new try, i.e. jump back to 1
1273  DO 25 ii=1,2
1274  DO 25 j=1,5
1275  25 p(ii,j)=psave(3,ii,j)
1276  50 CONTINUE
1277 C...TRANSFORM TO CMS OF INCOMING PARTICLES, LEPTON ALONG +Z AXIS.
1278  DO 60 j=1,3
1279  60 dbeta(1,j)=(dble(p(1,j))+dble(p(2,j)))/
1280  + (dble(p(1,4))+dble(p(2,4)))
1281  IF (isfirst.EQ.1) THEN
1282  isfirst=0
1283  DO 70 j=1,3
1284  70 dbetatmp(j)=dbeta(1,j)
1285  ENDIF
1286 
1287  CALL ludbrb(0,0,0.,0.,-dbeta(1,1),-dbeta(1,2),-dbeta(1,3))
1288  sphi(1)=ulangl(p(1,1),p(1,2))
1289  CALL ludbrb(0,0,0.,-sphi(1),0.d0,0.d0,0.d0)
1290  stheta(1)=ulangl(p(1,3),p(1,1))
1291  CALL ludbrb(0,0,-stheta(1),0.,0.d0,0.d0,0.d0)
1292  lst(28)=2
1293  parl(21)=2.*(p(1,4)*p(2,4)-p(1,3)*p(2,3))
1294  ELSE
1295 C...INITIAL STATE MOMENTA FIXED FROM LINIT CALL.
1296  DO 90 i=1,2
1297  DO 80 j=1,5
1298  80 p(i,j)=psave(3,i,j)
1299  90 IF(psave(3,1,3).LT.0.) p(i,3)=-psave(3,i,3)
1300  lst(28)=3
1301  ENDIF
1302 
1303  CALL leptox
1304  IF (w2.LT.lst(35)) THEN
1305 * CALL RESONANCES REGION
1306 * ...FOR THE MOMENT,
1307  lst(21)=3131
1308 * WRITE(*,*)' ERROR 21- GOTO 1=',LST(21)
1309  ierr31=ierr31+1
1310  IF(mod(ierr31,5000).EQ.0) WRITE(*,*)'STATUS 21: CASE 3131',ierr31
1311 * GOTO 1
1312  ENDIF
1313 
1314 C...RETURN IF ERROR OR IF NO EVENT TO BE GENERATED.
1315 c print*,'lst(21),lst(2),lst(7)'
1316 c write(*,*) lst(21),lst(2),lst(7)
1317  IF(lst(21).NE.0.OR.lst(2).LE.0.OR.lst(7).EQ.-1) THEN
1318  RETURN
1319  ENDIF
1320 
1321  IF(pari(29).LT.0.5) THEN
1322 C...FOR FIRST CALL, RESET DOUBLE PRECISION COUNTERS.
1323  dari29=0.d0
1324  dari30=0.d0
1325  ENDIF
1326  dari29=dari29+1.d0
1327  pari(29)=dari29
1328 
1329 
1330 C CALL GULIST(-3,2)
1331 C...SCATTERED LEPTON AND EXCHANGED BOSON ADDED TO EVENT RECORD IN LKINEM
1332 C...TRANSFORM TO LEPTON-NUCLEON CMS IF NOT MADE EARLIER
1333  IF(lst(17).EQ.0) THEN
1334  DO 110 i=3,4
1335  DO 100 j=1,5
1336  100 psave(3,i,j)=p(i,j)
1337  110 IF(psave(3,1,3).LT.0.) psave(3,i,3)=-p(i,3)
1338  CALL ludbrb(0,0,0.,0.,0.d0,0.d0,-dbeta(1,3))
1339  lst(28)=2
1340  ENDIF
1341  DO 120 i=1,4
1342  DO 120 j=1,5
1343  120 psave(2,i,j)=p(i,j)
1344 C CALL GULIST(-2,2)
1345 
1346 C...PREPARE FOR PARTON CASCADE.
1347  IF(lst(8).GE.2.AND.mod(lst(8),10).NE.9) CALL lshowr(0)
1348 
1349 C...TRANSFORM TO HADRONIC CMS, BOOST PARAMETERS IN DOUBLE PRECISION.
1350  detot=dble(p(1,4))-dble(p(4,4))+dble(p(2,4))
1351  dbeta(2,1)=-dble(p(4,1))/detot
1352  dbeta(2,2)=-dble(p(4,2))/detot
1353  dbeta(2,3)=(dble(p(1,3))-dble(p(4,3))+dble(p(2,3)))/detot
1354  CALL ludbrb(0,0,0.,0.,-dbeta(2,1),-dbeta(2,2),-dbeta(2,3))
1355  sphi(2)=0.
1356  stheta(2)=ulangl(p(3,3),p(3,1))
1357  CALL ludbrb(0,0,-stheta(2),0.,0.d0,0.d0,0.d0)
1358  lst(28)=1
1359  DO 130 i=1,4
1360  DO 130 j=1,5
1361  130 psave(1,i,j)=p(i,j)
1362 C...SAVE MOMENTUM OF EXCHANGED BOSON (USED IN SUBROUTINE LFRAME).
1363  DO 140 j=1,5
1364  140 pb(j)=p(3,j)
1365 * WRITE(*,*)'HADRONIC CMS....'
1366 * CALL LULIST(1)
1367 
1368 
1369 
1370 
1371  150 n=4
1372  mstu(1)=n+1
1373  lst(26)=n+1
1374  lst(27)=0
1375  parl(25)=ulalps(q2)
1376  IF(lst(8).EQ.1.OR.lst(8)/10.EQ.1.OR.mod(lst(8),10).EQ.9) THEN
1377 C...PROBABILITIES FOR HARD, FIRST ORDER QCD EVENTS.
1378  CALL lqcdpr(qg,qqb)
1379  DO 160 i=1,17
1380  160 spq(i)=pq(i)
1381  170 srlu=rlu(0)
1382  IF(srlu.GT.qqb+qg) THEN
1383  DO 180 i=1,17
1384  180 pq(i)=spq(i)
1385  CALL lqev
1386  ELSEIF(srlu.GT.qqb) THEN
1387  IF(lst(8).EQ.9) THEN
1388  DO 190 i=1,17
1389  190 pq(i)=spq(i)
1390  CALL lqev
1391  ELSE
1392  CALL lqgev
1393  ENDIF
1394  ELSE
1395  CALL lqqbev
1396  IF(lst(8).EQ.9.AND.lst(21).EQ.0) THEN
1397  IF(plu(5,11).LT.q2*para(20)) THEN
1398  DO 200 i=1,17
1399  200 pq(i)=spq(i)
1400  CALL lqevar(k(5,2),k(7,2))
1401  ENDIF
1402  ENDIF
1403  ENDIF
1404  IF(lst(21).NE.0) goto 170
1405  ELSE
1406 C...QPM MODEL WITHOUT QCD CORRECTIONS (CASCADE APPLIED LATER).
1407  210 CALL lqev
1408 * WRITE(*,*)'AFTER QPM CALL TO LQEV'
1409  IF(lst(21).NE.0) goto 210
1410  ENDIF
1411 
1412  ns=mstu(1)
1413  mstu(1)=0
1414 * WRITE(*,*)' AFTER QPM:'
1415 * CALL LULIST(1)
1416 
1417 
1418  IF(lst(8).LE.1.OR.mod(lst(8),10).EQ.9) THEN
1419 C...NO PARTON CASCADE, INTRODUCE PRIMORDIAL KT.
1420  IF(parl(3).GT.1.e-03) THEN
1421  CALL lprikt(parl(3),pt,phi)
1422  CALL ludbrb(ns,n,0.,-phi,0.d0,0.d0,0.d0)
1423  CALL ludbrb(ns,n,atan(2.*pt/sqrt(w2)),phi,0.d0,0.d0,0.d0)
1424  ENDIF
1425 C...CHECK SYSTEM AGAINST FRAGMENTATION CUTS.
1426  mstu(24)=0
1427  CALL luprep(0)
1428  IF(mstu(24).NE.0) THEN
1429  IF(lst(3).GE.1) WRITE(6,*) ' LUPREP ERROR MSTU(24)= ',mstu(24)
1430  lst(21)=11
1431  ENDIF
1432  ELSEIF(lst(24).EQ.1) THEN
1433 C...INCLUDE PARTON CASCADES (+ REMNANT & KT) ON Q-EVENT
1434 * WRITE(*,*)'AND NOW GO INTO Q SHOWERING!'
1435  IF(lst(21).NE.0) THEN
1436 * WRITE(*,*)' ERROR 21- PRE LSHOWR(1)'
1437  ENDIF
1438 
1439 * CUT ON SHOWER SIMULATION
1440  CALL lshowr(1)
1441 
1442 * WRITE(*,*)' AFTER SHOWER THE STATUS IS:'
1443 * CALL LULIST(1)
1444  ELSE
1445 C...INCLUDE PARTON CASCADES (+ REMNANT & KT) ON QG- OR QQBAR-EVENT
1446 * WRITE(*,*)'AND NOW GO INTO QG-QQBAR SHOWERING!'
1447  CALL lmeps
1448  ENDIF
1449 
1450  220 CONTINUE
1451 
1452 
1453 
1454 
1455  IF(lst(21).NE.0) THEN
1456 * WRITE(*,*)' ERROR 21- GOTO 1=',LST(21)
1457  ierr21=ierr21+1
1458  IF(mod(ierr21,100).EQ.0) WRITE(*,*)'ERROR 21:',ierr21
1459  goto 10
1460  ENDIF
1461 
1462  DO 230 i=1,n
1463 C...CORRECT ENERGY-MOMENTUM-MASS MISMATCH FOR REAL PARTICLE
1464  IF(p(i,5).LT.0.) goto 230
1465  energy=sqrt(dble(p(i,5))**2+dble(p(i,1))**2+dble(p(i,2))**2+
1466  + dble(p(i,3))**2)
1467  p2=dble(p(i,4))**2-dble(p(i,1))**2-dble(p(i,2))**2-dble(p(i,3))
1468  + **2
1469  IF(abs(energy-p(i,4))/(psave(3,1,4)+psave(3,2,4)).GT.paru(11))
1470  + THEN
1471  nummis=nummis+1
1472 C...FOR TESTING PURPOSES
1473 C IF(LST(3).GE.1.AND.NUMMIS.LE.NWARN) THEN
1474 C WRITE(6,1000) I,(K(I,J),J=1,2),(P(I,J),J=1,5),
1475 C & SIGN(SQRT(ABS(P2)),P2),ENERGY,INT(DARI29),NWARN
1476 C IF(ABS(P2-P(I,5)**2).GT.400.) CALL LULIST(2)
1477 C ENDIF
1478  goto 150
1479  ENDIF
1480  p(i,4)=energy
1481  230 CONTINUE
1482 
1483  dari30=dari30+1.d0
1484  pari(30)=dari30
1485  IF(lst(23).EQ.2) parl(24)=parl(24)*dari30/dari29
1486 
1487  DO 240 i=1,n
1488  DO 240 j=1,5
1489  240 v(i,j)=0.
1490  IF(lst(7).EQ.1) THEN
1491  IF(lst(34).EQ.1) THEN
1492  k(4,1)=21
1493  ENDIF
1494 * NEW PHYILOSOPHY:ONLY TAU AND CHARM DECAYS
1495  CALL luexec
1496 * CALL LUSTRF(IP)
1497  IF(mstu(24).NE.0) THEN
1498  WRITE(*,*) ' ERROR FROM JETSET, NEW EVENT MADE'
1499  goto 150
1500  ENDIF
1501  ENDIF
1502 
1503 C CALL GULIST(-1,2)
1504 C...TRANSFORM TO DESIRED FRAME
1505 C LST(28)=1
1506  lst(29)=0
1507  phir=6.2832*rlu(0)
1508 * WRITE(*,*)'SYNC...',PHIR
1509  IF(lst(17).EQ.0) THEN
1510  IF(lst(5).GE.2) CALL lframe(lst(5),0)
1511 C...RESTORE MOMENTA (E,P,BOSON,L) DUE TO NUMERICAL ERRORS FROM BOOSTS
1512  DO 250 i=1,4
1513  DO 250 j=1,5
1514  250 p(i,j)=psave(lst(28),i,j)
1515  IF(lst(6).EQ.1.AND.lst(28).GE.2) THEN
1516 C...RANDOM ROTATION IN AZIMUTHAL ANGLE
1517  CALL ludbrb(0,0,0.,phir,0.d0,0.d0,0.d0)
1518  lst(29)=1
1519  ENDIF
1520  ELSE
1521  IF(lst(5).GE.2) THEN
1522 * WRITE(*,*)'DBETA,28,5',DBETA,LST(28),LST(5)
1523  IF (dbeta(1,3).NE.0) THEN
1524  CALL lframe(lst(5),lst(6))
1525  ELSE
1526  WRITE(*,*)'0 DBETA!!!'
1527  DO j=1,3
1528  dbeta(1,j)=dbetatmp(j)
1529  END DO
1530  CALL lframe(lst(5),lst(6))
1531  WRITE(*,*)'1ST ATTEMPT RECOVERY',phir
1532  CALL lulist(1)
1533  WRITE(*,*)'1ST ATTEMPT RECOVERY ENDED',phir
1534  ENDIF
1535 * WRITE(*,*)'CALLED LFRAME',LST(5),LST(6),PHIR
1536  IF (abs(p(2,3)+p(1,3)).LT.0.2) THEN
1537  WRITE(*,*)'LEPTO ERROR CMS FRAME!!',phir
1538 * CALL LULIST(1)
1539  DO j=1,3
1540  dbeta(1,j)=dbetatmp(j)
1541  END DO
1542  WRITE(*,*)' TRY RECOVERY...',dbetatmp
1543  lst(28)=2
1544  CALL lframe(lst(5),lst(6))
1545 * CALL LULIST(1)
1546  ENDIF
1547  ENDIF
1548  ENDIF
1549 C...DEACTIVATE SCATTERED LEPTON
1550  IF(mod(lst(4),10).EQ.0) k(4,1)=21
1551 C CALL GULIST(0,2)
1552 
1553  RETURN
1554 10000 FORMAT(' WARNING: TOO LARGE NUMERICAL MISMATCH IN ',
1555  +'PARTICLE ENERGY-MOMENTUM-MASS',
1556  +/,3x,'I K(I,1) ..2) P(I,1) P(I,2) P(I,3)',
1557  +' P(I,4) P(I,5) MASS ENERGY',/,i4,2i6,7f8.3,/,
1558  +' EVENT NO.',i8,' REGENERATED. ONLY FIRST',i5,' WARNINGS PRINTED')
1559  END
1560 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
1561 *-- AUTHOR :
1562  FUNCTION amas4(PP)
1563 C ******************
1564 C ----------------------------------------------------------------------
1565 C CALCULATES MASS OF PP
1566 C
1567 C USED BY :
1568 C ----------------------------------------------------------------------
1569  REAL pp(4)
1570  aaa=pp(4)**2-pp(3)**2-pp(2)**2-pp(1)**2
1571  IF(aaa.NE.0.0) aaa=aaa/sqrt(abs(aaa))
1572  amas4=aaa
1573  RETURN
1574  END
1575 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
1576 *-- AUTHOR :
1577  FUNCTION amast(PP)
1578 C ----------------------------------------------------------------------
1579 C CALCULATES MASS OF PP (DOUBLE PRECISION)
1580 C
1581 C USED BY : RADKOR
1582 C ----------------------------------------------------------------------
1583  IMPLICIT REAL*8 (a-h,o-z)
1584  REAL*8 pp(4)
1585  aaa=pp(4)**2-pp(3)**2-pp(2)**2-pp(1)**2
1586 C
1587  IF(aaa.NE.0.0) aaa=aaa/sqrt(abs(aaa))
1588  amast=aaa
1589  RETURN
1590  END
1591 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
1592 *-- AUTHOR :
1593  FUNCTION angfi(X,Y)
1594 C ----------------------------------------------------------------------
1595 * CALCULATES ANGLE IN (0,2*PI) RANGE OUT OF X-Y
1596 C
1597 C USED BY : KORALZ RADKOR
1598 C ----------------------------------------------------------------------
1599  IMPLICIT DOUBLE PRECISION (a-h,o-z)
1600  DATA pi /3.141592653589793238462643d0/
1601 C
1602  IF(abs(y).LT.abs(x)) THEN
1603  the=atan(abs(y/x))
1604  IF(x.LE.0d0) the=pi-the
1605  ELSE
1606  the=acos(x/sqrt(x**2+y**2))
1607  ENDIF
1608  IF(y.LT.0d0) the=2d0*pi-the
1609  angfi=the
1610  END
1611 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
1612 *-- AUTHOR :
1613  FUNCTION angxy(X,Y)
1614 C ----------------------------------------------------------------------
1615 C
1616 C USED BY : KORALZ RADKOR
1617 C ----------------------------------------------------------------------
1618  IMPLICIT DOUBLE PRECISION (a-h,o-z)
1619  DATA pi /3.141592653589793238462643d0/
1620 C
1621  IF(abs(y).LT.abs(x)) THEN
1622  the=atan(abs(y/x))
1623  IF(x.LE.0d0) the=pi-the
1624  ELSE
1625  the=acos(x/sqrt(x**2+y**2))
1626  ENDIF
1627  angxy=the
1628  RETURN
1629  END
1630 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
1631 *-- AUTHOR :
1632  SUBROUTINE bostd3(EXE,PVEC,QVEC)
1633 C ----------------------------------------------------------------------
1634 C BOOST ALONG Z AXIS, EXE=EXP(ETA), ETA= HIPERBOLIC VELOCITY.
1635 C
1636 C USED BY : KORALZ RADKOR
1637 C ----------------------------------------------------------------------
1638  IMPLICIT DOUBLE PRECISION (a-h,o-z)
1639  dimension pvec(4),qvec(4),rvec(4)
1640 C
1641  DO 10 i=1,4
1642  10 rvec(i)=pvec(i)
1643  rpl=rvec(4)+rvec(3)
1644  rmi=rvec(4)-rvec(3)
1645  qpl=rpl*exe
1646  qmi=rmi/exe
1647  qvec(1)=rvec(1)
1648  qvec(2)=rvec(2)
1649  qvec(3)=(qpl-qmi)/2
1650  qvec(4)=(qpl+qmi)/2
1651  RETURN
1652  END
1653 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
1654 *-- AUTHOR :
1655  SUBROUTINE bostr3(EXE,PVEC,QVEC)
1656 C ----------------------------------------------------------------------
1657 C BOOST ALONG Z AXIS, EXE=EXP(ETA), ETA= HIPERBOLIC VELOCITY.
1658 C
1659 C USED BY : TAUOLA KORALZ (?)
1660 C ----------------------------------------------------------------------
1661  REAL*4 pvec(4),qvec(4),rvec(4)
1662 C
1663  DO 10 i=1,4
1664  10 rvec(i)=pvec(i)
1665  rpl=rvec(4)+rvec(3)
1666  rmi=rvec(4)-rvec(3)
1667  qpl=rpl*exe
1668  qmi=rmi/exe
1669  qvec(1)=rvec(1)
1670  qvec(2)=rvec(2)
1671  qvec(3)=(qpl-qmi)/2
1672  qvec(4)=(qpl+qmi)/2
1673  END
1674 *CMZ : 1.01/39 03/11/95 16.36.14 by Piero Zucchelli
1675 *CMZ : 1.01/04 15/08/95 16.55.04 by Stefania RICCIARDI
1676 *CMZ : 1.01/02 02/08/95 12.14.00 by Stefania RICCIARDI
1677 *CMZ : 1.00/03 01/07/95 16.21.55 by Stefania RICCIARDI
1678 *-- Author : Stefania RICCIARDI 26/06/95
1679  SUBROUTINE btocho2(VIN,PIN,PTX,PTY)
1680 
1681  REAL vin(3),pin(3)
1682  DATA zbeam/82342/
1683 
1684  dz = zbeam-vin(3)
1685  pty = vin(2)+pin(2)/pin(3)*dz
1686  ptx = vin(1)+pin(1)/pin(3)*dz
1687  END
1688 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
1689 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
1690 *-- AUTHOR :
1691  COMPLEX FUNCTION bwig(S,M,G)
1692 C **********************************************************
1693 C P-WAVE BREIT-WIGNER FOR RHO
1694 C **********************************************************
1695  REAL s,m,g
1696  REAL pi,pim,qs,qm,w,gs
1697  DATA init /0/
1698 C ------------ PARAMETERS --------------------
1699  IF (init.EQ.0) THEN
1700  init=1
1701  pi=3.141592654
1702  pim=.139
1703 C ------- BREIT-WIGNER -----------------------
1704  ENDIF
1705  IF (s.GT.4.*pim**2) THEN
1706  qs=sqrt(abs(abs(s/4.-pim**2)+(s/4.-pim**2))/2.0)
1707  qm=sqrt(m**2/4.-pim**2)
1708  w=sqrt(s)
1709  gs=g*(m/w)*(qs/qm)**3
1710  ELSE
1711  gs=0.0
1712  ENDIF
1713  bwig=m**2/cmplx(m**2-s,-m*gs)
1714  RETURN
1715  END
1716 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
1717 *CMZ : 1.00/00 10/08/94 16.29.32 BY PIERO ZUCCHELLI
1718 *-- AUTHOR :
1719  COMPLEX FUNCTION bwigm(S,M,G,XM1,XM2)
1720 C **********************************************************
1721 C P-WAVE BREIT-WIGNER FOR RHO
1722 C **********************************************************
1723  REAL s,m,g,xm1,xm2
1724  REAL pi,qs,qm,w,gs
1725  DATA init /0/
1726 C ------------ PARAMETERS --------------------
1727  IF (init.EQ.0) THEN
1728  init=1
1729  pi=3.141592654
1730 C ------- BREIT-WIGNER -----------------------
1731  ENDIF
1732  IF (s.GT.(xm1+xm2)**2) THEN
1733  qs=sqrt(abs((s -(xm1+xm2)**2)*(s -(xm1-xm2)**2)))/sqrt(s)
1734  qm=sqrt(abs((m**2-(xm1+xm2)**2)*(m**2-(xm1-xm2)**2)))/m
1735  w=sqrt(s)
1736  gs=g*(m/w)**2*(qs/qm)**3
1737  ELSE
1738  gs=0.0
1739  ENDIF
1740  bwigm=m**2/cmplx(m**2-s,-sqrt(s)*gs)
1741  RETURN
1742  END
1743 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
1744 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
1745 *-- AUTHOR :
1746  COMPLEX FUNCTION bwigs(S,M,G)
1747 C **********************************************************
1748 C P-WAVE BREIT-WIGNER FOR K*
1749 C **********************************************************
1750  REAL s,m,g
1751  REAL pi,pim,qs,qm,w,gs,mk
1752  DATA init /0/
1753  p(a,b,c)=sqrt(abs(abs(((a+b-c)**2-4.*a*b)/4./a)
1754  + +(((a+b-c)**2-4.*a*b)/4./a))/2.0)
1755 C ------------ PARAMETERS --------------------
1756  IF (init.EQ.0) THEN
1757  init=1
1758  pi=3.141592654
1759  pim=.139
1760  mk=.493667
1761 C ------- BREIT-WIGNER -----------------------
1762  ENDIF
1763  qs=p(s,pim**2,mk**2)
1764  qm=p(m**2,pim**2,mk**2)
1765  w=sqrt(s)
1766  gs=g*(m/w)*(qs/qm)**3
1767  bwigs=m**2/cmplx(m**2-s,-m*gs)
1768  RETURN
1769  END
1770 *CMZ : 1.01/24 29/05/95 15.40.09 BY PIERO ZUCCHELLI
1771 *CMZ : 1.01/22 27/05/95 16.39.05 BY PIERO ZUCCHELLI
1772 *CMZ : 1.01/08 05/03/95 11.40.52 BY PIERO ZUCCHELLI
1773 *CMZ : 1.01/01 20/09/94 14.44.05 BY PIERO ZUCCHELLI
1774 *-- AUTHOR : PIERO ZUCCHELLI 20/09/94
1775 
1776  SUBROUTINE cats
1777  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
1778  COMMON /lminui/ xkin(4),ukin(4),wkin(4),ain(4),bin(4), maxfin,
1779  +relup,relerr,reler2,fcnmax
1780 * DO ESPLICITELY WWHAT IS DONE IN LEPTOD AND USER CUTS
1781  common/linpatch/ncalls,ncall
1782  REAL*4 savecut(14)
1783 
1784  IF (imyfirst.EQ.0) THEN
1785  imyfirst=1
1786 
1787  DO i=1,14
1788  savecut(i)=cut(i)
1789  END DO
1790  ENDIF
1791 
1792  DO i=1,14
1793  cut(i)=savecut(i)
1794  END DO
1795  DO i=1,4
1796  xkin(i)=i
1797  ukin(i)=0
1798  wkin(i)=0
1799  ain(i)=0
1800  bin(i)=0
1801  END DO
1802 
1803  fcnmax=0
1804  ncalls=0
1805  ncall=0
1806 
1807 * USER CATS
1808 
1809  cut(7)=0
1810  cut(5)=0
1811 
1812  RETURN
1813  END
1814 *CMZ : 1.01/08 05/03/95 11.39.27 BY PIERO ZUCCHELLI
1815 *CMZ : 1.00/00 09/08/94 17.43.59 BY PIERO ZUCCHELLI
1816 *-- AUTHOR :
1817  SUBROUTINE choice(MNUM,RR,ICHAN,PROB1,PROB2,PROB3,
1818  + amrx,gamrx,amra,gamra,amrb,gamrb)
1819  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
1820  + ,ampiz,ampi,amro,gamro,ama1,gama1
1821  + ,amk,amkz,amkst,gamkst
1822 C
1823  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
1824  + ,ampiz,ampi,amro,gamro,ama1,gama1
1825  + ,amk,amkz,amkst,gamkst
1826 C
1827  amrop=1.1
1828  gamrop=0.36
1829  amom=.782
1830  gamom=0.0084
1831 C XXXXA CORRESPOND TO S2 CHANNEL !
1832  IF(mnum.EQ.0) THEN
1833  prob1=0.5
1834  prob2=0.5
1835  amrx =ama1
1836  gamrx=gama1
1837  amra =amro
1838  gamra=gamro
1839  amrb =amro
1840  gamrb=gamro
1841  ELSEIF(mnum.EQ.1) THEN
1842  prob1=0.5
1843  prob2=0.5
1844  amrx =1.57
1845  gamrx=0.9
1846  amrb =amkst
1847  gamrb=gamkst
1848  amra =amro
1849  gamra=gamro
1850  ELSEIF(mnum.EQ.2) THEN
1851  prob1=0.5
1852  prob2=0.5
1853  amrx =1.57
1854  gamrx=0.9
1855  amrb =amkst
1856  gamrb=gamkst
1857  amra =amro
1858  gamra=gamro
1859  ELSEIF(mnum.EQ.3) THEN
1860  prob1=0.5
1861  prob2=0.5
1862  amrx =1.27
1863  gamrx=0.3
1864  amra =amkst
1865  gamra=gamkst
1866  amrb =amkst
1867  gamrb=gamkst
1868  ELSEIF(mnum.EQ.4) THEN
1869  prob1=0.5
1870  prob2=0.5
1871  amrx =1.27
1872  gamrx=0.3
1873  amra =amkst
1874  gamra=gamkst
1875  amrb =amkst
1876  gamrb=gamkst
1877  ELSEIF(mnum.EQ.5) THEN
1878  prob1=0.5
1879  prob2=0.5
1880  amrx =1.27
1881  gamrx=0.3
1882  amra =amkst
1883  gamra=gamkst
1884  amrb =amro
1885  gamrb=gamro
1886  ELSEIF(mnum.EQ.6) THEN
1887  prob1=0.4
1888  prob2=0.4
1889  amrx =1.27
1890  gamrx=0.3
1891  amra =amro
1892  gamra=gamro
1893  amrb =amkst
1894  gamrb=gamkst
1895  ELSEIF(mnum.EQ.7) THEN
1896  prob1=0.0
1897  prob2=1.0
1898  amrx =1.27
1899  gamrx=0.9
1900  amra =amro
1901  gamra=gamro
1902  amrb =amro
1903  gamrb=gamro
1904  ELSEIF(mnum.EQ.8) THEN
1905  prob1=0.0
1906  prob2=1.0
1907  amrx =amrop
1908  gamrx=gamrop
1909  amrb =amom
1910  gamrb=gamom
1911  amra =amro
1912  gamra=gamro
1913  ELSEIF(mnum.EQ.101) THEN
1914  prob1=.35
1915  prob2=.35
1916  amrx =1.2
1917  gamrx=.46
1918  amrb =amom
1919  gamrb=gamom
1920  amra =amom
1921  gamra=gamom
1922  ELSEIF(mnum.EQ.102) THEN
1923  prob1=0.0
1924  prob2=0.0
1925  amrx =1.4
1926  gamrx=.6
1927  amrb =amom
1928  gamrb=gamom
1929  amra =amom
1930  gamra=gamom
1931  ELSE
1932  prob1=0.0
1933  prob2=0.0
1934  amrx =ama1
1935  gamrx=gama1
1936  amra =amro
1937  gamra=gamro
1938  amrb =amro
1939  gamrb=gamro
1940  ENDIF
1941 C
1942  IF (rr.LE.prob1) THEN
1943  ichan=1
1944  ELSEIF(rr.LE.(prob1+prob2)) THEN
1945  ichan=2
1946  ax =amra
1947  gx =gamra
1948  amra =amrb
1949  gamra=gamrb
1950  amrb =ax
1951  gamrb=gx
1952  px =prob1
1953  prob1=prob2
1954  prob2=px
1955  ELSE
1956  ichan=3
1957  ENDIF
1958 C
1959  prob3=1.0-prob1-prob2
1960  END
1961 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
1962 *-- AUTHOR :
1963  SUBROUTINE claxi(HJ,PN,PIA)
1964 C ----------------------------------------------------------------------
1965 * CALCULATES THE "AXIAL TYPE" PI-VECTOR PIA
1966 * NOTE THAT THE NEUTRINO MOM. PN IS ASSUMED TO BE ALONG Z-AXIS
1967 C SIGN IS CHOSEN +/- FOR DECAY OF TAU +/- RESPECTIVELY
1968 C CALLED BY : DAMPAA, CLNUT
1969 C ----------------------------------------------------------------------
1970  COMMON / jaki / jak1,jak2,jakp,jakm,ktom
1971  COMMON / idfc / idff
1972  REAL pia(4),pn(4)
1973  COMPLEX hj(4),hjc(4)
1974 C DET2(I,J)=AIMAG(HJ(I)*HJC(J)-HJ(J)*HJC(I))
1975 C -- HERE WAS AN ERROR (ZW, 21.11.1991)
1976  det2(i,j)=aimag(hjc(i)*hj(j)-hjc(j)*hj(i))
1977 C -- IT WAS AFFECTING SIGN OF A_LR ASYMMETRY IN A1 DECAY.
1978 C -- NOTE ALSO COLLISION OF NOTATION OF GAMMA_VA AS DEFINED IN
1979 C -- TAUOLA PAPER AND J.H. KUHN AND SANTAMARIA Z. PHYS C 48 (1990) 445
1980 * -----------------------------------
1981  IF (ktom.EQ.1.OR.ktom.EQ.-1) THEN
1982  sign= idff/abs(idff)
1983  ELSEIF (ktom.EQ.2) THEN
1984  sign=-idff/abs(idff)
1985  ELSE
1986  print *, 'STOP IN CLAXI: KTOM=',ktom
1987  stop
1988  ENDIF
1989 C
1990  DO 10 i=1,4
1991  10 hjc(i)=conjg(hj(i))
1992  pia(1)= -2.*pn(3)*det2(2,4)+2.*pn(4)*det2(2,3)
1993  pia(2)= -2.*pn(4)*det2(1,3)+2.*pn(3)*det2(1,4)
1994  pia(3)= 2.*pn(4)*det2(1,2)
1995  pia(4)= 2.*pn(3)*det2(1,2)
1996 C ALL FOUR INDICES ARE UP SO PIA(3) AND PIA(4) HAVE SAME SIGN
1997  DO 20 i=1,4
1998  20 pia(i)=pia(i)*sign
1999  END
2000 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
2001 *-- AUTHOR :
2002  SUBROUTINE clnut(HJ,B,HV)
2003 C ----------------------------------------------------------------------
2004 * CALCULATES THE CONTRIBUTION BY NEUTRINO MASS
2005 * NOTE THE TAU IS ASSUMED TO BE AT REST
2006 C
2007 C CALLED BY : DAMPAA
2008 C ----------------------------------------------------------------------
2009  COMPLEX hj(4)
2010  REAL hv(4),p(4)
2011  DATA p /3*0.,1.0/
2012 C
2013  CALL claxi(hj,p,hv)
2014  b=REAL( HJ(4)*AIMAG(HJ(4)) - HJ(3)*AIMAG(HJ(3)) & - HJ(2)*AIMAG(HJ(2)) - HJ(1)*AIMAG(HJ(1)) )
2015  RETURN
2016  END
2017 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
2018 *-- AUTHOR :
2019  SUBROUTINE clvec(HJ,PN,PIV)
2020 C ----------------------------------------------------------------------
2021 * CALCULATES THE "VECTOR TYPE" PI-VECTOR PIV
2022 * NOTE THAT THE NEUTRINO MOM. PN IS ASSUMED TO BE ALONG Z-AXIS
2023 C
2024 C CALLED BY : DAMPAA
2025 C ----------------------------------------------------------------------
2026  REAL piv(4),pn(4)
2027  COMPLEX hj(4),hn
2028 C
2029  hn= hj(4)*cmplx(pn(4))-hj(3)*cmplx(pn(3))
2030  hh= REAL(hj(4)*conjg(hj(4))-hj(3)*conjg(hj(3))
2031  $ -hj(2)*conjg(hj(2))-hj(1)*conjg(hj(1)))
2032  DO 10 i=1,4
2033  10 piv(i)=4.*REAL(hn*conjg(hj(i)))-2.*hh*pn(i)
2034  RETURN
2035  END
2036 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
2037 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
2038 *CMZ : 1.00/00 10/08/94 16.29.32 BY PIERO ZUCCHELLI
2039 *-- AUTHOR :
2040  SUBROUTINE curr(MNUM,PIM1,PIM2,PIM3,PIM4,HADCUR)
2041 C ==================================================================
2042 C HADRONIC CURRENT FOR 4 PI FINAL STATE
2043 C R. FISHER, J. WESS AND F. WAGNER Z. PHYS C3 (1980) 313
2044 C R. DECKER Z. PHYS C36 (1987) 487.
2045 C M. GELL-MANN, D. SHARP, W. WAGNER PHYS. REV. LETT 8 (1962) 261.
2046 C ==================================================================
2047 
2048  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
2049  + ,ampiz,ampi,amro,gamro,ama1,gama1
2050  + ,amk,amkz,amkst,gamkst
2051 C
2052  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
2053  + ,ampiz,ampi,amro,gamro,ama1,gama1
2054  + ,amk,amkz,amkst,gamkst
2055  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
2056  REAL*4 gfermi,gv,ga,ccabib,scabib,gamel
2057 C ARBITRARY FIXING OF THE FOUR PI X-SECTION NORMALIZATION
2058  COMMON /arbit/ arflat,aromeg
2059  REAL pim1(4),pim2(4),pim3(4),pim4(4),paa(4)
2060  COMPLEX hadcur(4),form1,form2,form3,fpikm
2061  COMPLEX bwign
2062  REAL pa(4),pb(4)
2063  REAL aa(4,4),pp(4,4)
2064  DATA pi /3.141592653589793238462643/
2065  DATA fpi /93.3e-3/
2066  bwign(a,xm,xg)=1.0/cmplx(a-xm**2,xm*xg)
2067 C
2068 C --- MASSES AND CONSTANTS
2069  g1=12.924
2070  g2=1475.98
2071  g =g1*g2
2072  elpha=-.1
2073  amrop=1.7
2074  gamrop=0.26
2075  amom=.782
2076  gamom=0.0085
2077  arflat=1.0
2078  aromeg=1.0
2079 C
2080  fro=0.266*amro**2
2081  coef1=2.0*sqrt(3.0)/fpi**2*arflat
2082  coef2=fro*g*aromeg
2083 C --- INITIALIZATION OF FOUR VECTORS
2084  DO 20 k=1,4
2085  DO 10 l=1,4
2086  10 aa(k,l)=0.0
2087  hadcur(k)=cmplx(0.0)
2088  paa(k)=pim1(k)+pim2(k)+pim3(k)+pim4(k)
2089  pp(1,k)=pim1(k)
2090  pp(2,k)=pim2(k)
2091  pp(3,k)=pim3(k)
2092  20 pp(4,k)=pim4(k)
2093 C
2094  IF (mnum.EQ.1) THEN
2095 C ===================================================================
2096 C PI- PI- P0 PI+ CASE ====
2097 C ===================================================================
2098  qq=paa(4)**2-paa(3)**2-paa(2)**2-paa(1)**2
2099 C --- LOOP OVER THRE CONTRIBUTION OF THE NON-OMEGA CURRENT
2100  DO 80 k=1,3
2101  sk=(pp(k,4)+pim4(4))**2-(pp(k,3)+pim4(3))**2 -(pp(k,2)+
2102  + pim4(2))**2-(pp(k,1)+pim4(1))**2
2103 C -- DEFINITION OF AA MATRIX
2104 C -- CRONECKER DELTA
2105  DO 40 i=1,4
2106  DO 30 j=1,4
2107  30 aa(i,j)=0.0
2108  40 aa(i,i)=1.0
2109 C ... AND THE REST ...
2110  DO 60 l=1,3
2111  IF (l.NE.k) THEN
2112  denom=(paa(4)-pp(l,4))**2-(paa(3)-pp(l,3))**2 -(paa(2)-
2113  + pp(l,2))**2-(paa(1)-pp(l,1))**2
2114  DO 50 i=1,4
2115  DO 50 j=1,4
2116  sig= 1.0
2117  IF(j.NE.4) sig=-sig
2118  aa(i,j)=aa(i,j) -sig*(paa(i)-2.0*pp(l,i))*(paa(j)-
2119  + pp(l,j))/denom
2120  50 CONTINUE
2121  ENDIF
2122  60 CONTINUE
2123 C --- LET'S ADD SOMETHING TO HADCURR
2124  form1= fpikm(sqrt(sk),ampi,ampi) *fpikm(sqrt(qq),ampi,ampi)
2125 C FORM1= FPIKM(SQRT(SK),AMPI,AMPI) *FPIKMD(SQRT(QQ),AMPI,AMPI)
2126 CCCCCCCCCCCCCCCCC FORM1=WIGFOR(SK,AMRO,GAMRO) (TESTS)
2127 C
2128  fix=1.0
2129  IF (k.EQ.3) fix=-2.0
2130  DO 70 i=1,4
2131  DO 70 j=1,4
2132  hadcur(i)= hadcur(i)+cmplx(fix*coef1)*form1*aa(i,j)*
2133  + (pp(k,j)-pp(4,j))
2134  70 CONTINUE
2135 C --- END OF THE NON OMEGA CURRENT (3 POSSIBILITIES)
2136  80 CONTINUE
2137 C
2138 C
2139 C --- THERE ARE TWO POSSIBILITIES FOR OMEGA CURRENT
2140 C --- PA PB ARE CORRESPONDING FIRST AND SECOND PI-'S
2141  DO 120 kk=1,2
2142  DO 90 i=1,4
2143  pa(i)=pp(kk,i)
2144  pb(i)=pp(3-kk,i)
2145  90 CONTINUE
2146 C --- LORENTZ INVARIANTS
2147  qqa=0.0
2148  ss23=0.0
2149  ss24=0.0
2150  ss34=0.0
2151  qp1p2=0.0
2152  qp1p3=0.0
2153  qp1p4=0.0
2154  p1p2 =0.0
2155  p1p3 =0.0
2156  p1p4 =0.0
2157  DO 100 k=1,4
2158  sign=-1.0
2159  IF (k.EQ.4) sign= 1.0
2160  qqa=qqa+sign*(paa(k)-pa(k))**2
2161  ss23=ss23+sign*(pb(k) +pim3(k))**2
2162  ss24=ss24+sign*(pb(k) +pim4(k))**2
2163  ss34=ss34+sign*(pim3(k)+pim4(k))**2
2164  qp1p2=qp1p2+sign*(paa(k)-pa(k))*pb(k)
2165  qp1p3=qp1p3+sign*(paa(k)-pa(k))*pim3(k)
2166  qp1p4=qp1p4+sign*(paa(k)-pa(k))*pim4(k)
2167  p1p2=p1p2+sign*pa(k)*pb(k)
2168  p1p3=p1p3+sign*pa(k)*pim3(k)
2169  p1p4=p1p4+sign*pa(k)*pim4(k)
2170  100 CONTINUE
2171 C
2172  form2=coef2*(bwign(qq,amro,gamro)+elpha*bwign(qq,amrop,
2173  + gamrop))
2174 C FORM3=BWIGN(QQA,AMOM,GAMOM)*(BWIGN(SS23,AMRO,GAMRO)+
2175 C $ BWIGN(SS24,AMRO,GAMRO)+BWIGN(SS34,AMRO,GAMRO))
2176  form3=bwign(qqa,amom,gamom)
2177 C
2178  DO 110 k=1,4
2179  hadcur(k)=hadcur(k)+form2*form3*( pb(k)*(qp1p3*p1p4-qp1p4*
2180  + p1p3) +pim3(k)*(qp1p4*p1p2-qp1p2*p1p4) +pim4(k)*(qp1p2*
2181  + p1p3-qp1p3*p1p2) )
2182  110 CONTINUE
2183  120 CONTINUE
2184 C
2185  ELSE
2186 C ===================================================================
2187 C PI0 PI0 P0 PI- CASE ====
2188 C ===================================================================
2189  qq=paa(4)**2-paa(3)**2-paa(2)**2-paa(1)**2
2190  DO 180 k=1,3
2191 C --- LOOP OVER THRE CONTRIBUTION OF THE NON-OMEGA CURRENT
2192  sk=(pp(k,4)+pim4(4))**2-(pp(k,3)+pim4(3))**2 -(pp(k,2)+
2193  + pim4(2))**2-(pp(k,1)+pim4(1))**2
2194 C -- DEFINITION OF AA MATRIX
2195 C -- CRONECKER DELTA
2196  DO 140 i=1,4
2197  DO 130 j=1,4
2198  130 aa(i,j)=0.0
2199  140 aa(i,i)=1.0
2200 C
2201 C ... AND THE REST ...
2202  DO 160 l=1,3
2203  IF (l.NE.k) THEN
2204  denom=(paa(4)-pp(l,4))**2-(paa(3)-pp(l,3))**2 -(paa(2)-
2205  + pp(l,2))**2-(paa(1)-pp(l,1))**2
2206  DO 150 i=1,4
2207  DO 150 j=1,4
2208  sig=1.0
2209  IF(j.NE.4) sig=-sig
2210  aa(i,j)=aa(i,j) -sig*(paa(i)-2.0*pp(l,i))*(paa(j)-
2211  + pp(l,j))/denom
2212  150 CONTINUE
2213  ENDIF
2214  160 CONTINUE
2215 C --- LET'S ADD SOMETHING TO HADCURR
2216  form1= fpikm(sqrt(sk),ampi,ampi) *fpikm(sqrt(qq),ampi,ampi)
2217 C FORM1= FPIKM(SQRT(SK),AMPI,AMPI) *FPIKMD(SQRT(QQ),AMPI,AMPI)
2218 CCCCCCCCCCCCC FORM1=WIGFOR(SK,AMRO,GAMRO) (TESTS)
2219  DO 170 i=1,4
2220  DO 170 j=1,4
2221  hadcur(i)= hadcur(i)+cmplx(coef1)*form1*aa(i,j)*(pp(k,j)-
2222  + pp(4,j))
2223  170 CONTINUE
2224 C --- END OF THE NON OMEGA CURRENT (3 POSSIBILITIES)
2225  180 CONTINUE
2226  ENDIF
2227  END
2228 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
2229 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
2230 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
2231 *-- AUTHOR :
2232  SUBROUTINE dadmaa(MODE,ISGN,HHV,PNU,PAA,PIM1,PIM2,PIPL,JAA)
2233 C ----------------------------------------------------------------------
2234 * A1 DECAY UNWEIGHTED EVENTS
2235 C ----------------------------------------------------------------------
2236  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
2237  + ,ampiz,ampi,amro,gamro,ama1,gama1
2238  + ,amk,amkz,amkst,gamkst
2239 C
2240  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
2241  + ,ampiz,ampi,amro,gamro,ama1,gama1
2242  + ,amk,amkz,amkst,gamkst
2243  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
2244  REAL*4 gfermi,gv,ga,ccabib,scabib,gamel
2245  COMMON / taubmc / gampmc(30),gamper(30),nevdec(30)
2246  REAL*4 gampmc ,gamper
2247  COMMON / inout / inut,iout
2248  REAL hhv(4)
2249  REAL hv(4),paa(4),pnu(4),pim1(4),pim2(4),pipl(4)
2250  REAL pdum1(4),pdum2(4),pdum3(4),pdum4(4),pdum5(4)
2251  REAL*4 rrr(3)
2252  REAL*8 swt, sswt
2253  DATA pi /3.141592653589793238462643/
2254  DATA iwarm/0/
2255 C
2256  IF(mode.EQ.-1) THEN
2257 C ===================
2258  iwarm=1
2259  nevraw=0
2260  nevacc=0
2261  nevovr=0
2262  swt=0
2263  sswt=0
2264  wtmax=1e-20
2265  DO 10 i=1,500
2266  CALL dphsaa(wt,hv,pdum1,pdum2,pdum3,pdum4,pdum5,jaa)
2267  IF(wt.GT.wtmax/1.2) wtmax=wt*1.2
2268  10 CONTINUE
2269 CC CALL HBOOK1(801,'WEIGHT DISTRIBUTION DADMAA $',100,0,2)
2270 C
2271  ELSEIF(mode.EQ. 0) THEN
2272 C =======================
2273  20 CONTINUE
2274  IF(iwarm.EQ.0) goto 40
2275  CALL dphsaa(wt,hv,pnu,paa,pim1,pim2,pipl,jaa)
2276 CC CALL HFILL(801,WT/WTMAX)
2277  nevraw=nevraw+1
2278  swt=swt+wt
2279  sswt=sswt+wt**2
2280  CALL ranmar(rrr,3)
2281  rn=rrr(1)
2282  IF(wt.GT.wtmax) nevovr=nevovr+1
2283  IF(rn*wtmax.GT.wt) goto 20
2284 C ROTATIONS TO BASIC TAU REST FRAME
2285  costhe=-1.+2.*rrr(2)
2286  thet=acos(costhe)
2287  phi =2*pi*rrr(3)
2288  CALL rotpol(thet,phi,pnu)
2289  CALL rotpol(thet,phi,paa)
2290  CALL rotpol(thet,phi,pim1)
2291  CALL rotpol(thet,phi,pim2)
2292  CALL rotpol(thet,phi,pipl)
2293  CALL rotpol(thet,phi,hv)
2294  DO 30 i=1,3
2295  30 hhv(i)=-isgn*hv(i)
2296  nevacc=nevacc+1
2297 C
2298  ELSEIF(mode.EQ. 1) THEN
2299 C =======================
2300  IF(nevraw.EQ.0) RETURN
2301  pargam=swt/float(nevraw+1)
2302  error=0
2303  IF(nevraw.NE.0) error=sqrt(sswt/swt**2-1./float(nevraw))
2304  rat=pargam/gamel
2305  WRITE(iout, 10100) nevraw,nevacc,nevovr,pargam,rat,error
2306 CC CALL HPRINT(801)
2307  gampmc(5)=rat
2308  gamper(5)=error
2309 CAM NEVDEC(5)=NEVACC
2310  ENDIF
2311 C =====
2312  RETURN
2313 10000 FORMAT(///1x,15(5h*****)
2314  + /,' *', 25x,'******** DADMAA INITIALISATION ********',9x,1h*
2315  + /,' *',e20.5,5x,'WTMAX = MAXIMUM WEIGHT ',9x,1h*
2316  + /,1x,15(5h*****)/)
2317 10100 FORMAT(///1x,15(5h*****)
2318  + /,' *', 25x,'******** DADMAA FINAL REPORT ******** ',9x,1h*
2319  + /,' *',i20 ,5x,'NEVRAW = NO. OF A1 DECAYS TOTAL ',9x,1h*
2320  + /,' *',i20 ,5x,'NEVACC = NO. OF A1 DECS. ACCEPTED ',9x,1h*
2321  + /,' *',i20 ,5x,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9x,1h*
2322  + /,' *',e20.5,5x,'PARTIAL WTDTH (A1 DECAY) IN GEV UNITS ',9x,1h*
2323  + /,' *',f20.9,5x,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',9x,1h*
2324  + /,' *',f20.8,5x,'RELATIVE ERROR OF PARTIAL WIDTH ',9x,1h*
2325  + /,1x,15(5h*****)/)
2326  40 WRITE(iout, 10200)
2327 10200 FORMAT(' ----- DADMAA: LACK OF INITIALISATION')
2328  stop
2329  END
2330 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
2331 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
2332 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
2333 *-- AUTHOR :
2334  SUBROUTINE dadmel(MODE,ISGN,HHV,PNU,PWB,Q1,Q2,PHX)
2335 C ----------------------------------------------------------------------
2336 C
2337 C CALLED BY : DEXEL,(DEKAY,DEKAY1)
2338 C ----------------------------------------------------------------------
2339  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
2340  REAL*4 gfermi,gv,ga,ccabib,scabib,gamel
2341  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
2342  + ,ampiz,ampi,amro,gamro,ama1,gama1
2343  + ,amk,amkz,amkst,gamkst
2344 C
2345  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
2346  + ,ampiz,ampi,amro,gamro,ama1,gama1
2347  + ,amk,amkz,amkst,gamkst
2348  COMMON / taubmc / gampmc(30),gamper(30),nevdec(30)
2349  REAL*4 gampmc ,gamper
2350  REAL*4 phx(4)
2351  COMMON / inout / inut,iout
2352  REAL hhv(4),hv(4),pwb(4),pnu(4),q1(4),q2(4)
2353  REAL pdum1(4),pdum2(4),pdum3(4),pdum4(4),pdum5(4)
2354  REAL*4 rrr(3)
2355  REAL*8 swt, sswt
2356  DATA pi /3.141592653589793238462643/
2357  DATA iwarm/0/
2358 C
2359  IF(mode.EQ.-1) THEN
2360 C ===================
2361  iwarm=1
2362  nevraw=0
2363  nevacc=0
2364  nevovr=0
2365  swt=0
2366  sswt=0
2367  wtmax=1e-20
2368  DO 10 i=1,500
2369  CALL dphsel(wt,hv,pdum1,pdum2,pdum3,pdum4,pdum5)
2370  IF(wt.GT.wtmax/1.2) wtmax=wt*1.2
2371  10 CONTINUE
2372 CC CALL HBOOK1(803,'WEIGHT DISTRIBUTION DADMEL $',100,0,2)
2373 C
2374  ELSEIF(mode.EQ. 0) THEN
2375 C =======================
2376  20 CONTINUE
2377  IF(iwarm.EQ.0) goto 40
2378  nevraw=nevraw+1
2379  CALL dphsel(wt,hv,pnu,pwb,q1,q2,phx)
2380 CC CALL HFILL(803,WT/WTMAX)
2381  swt=swt+wt
2382  sswt=sswt+wt**2
2383  CALL ranmar(rrr,3)
2384  rn=rrr(1)
2385  IF(wt.GT.wtmax) nevovr=nevovr+1
2386  IF(rn*wtmax.GT.wt) goto 20
2387 C ROTATIONS TO BASIC TAU REST FRAME
2388  rr2=rrr(2)
2389  costhe=-1.+2.*rr2
2390  thet=acos(costhe)
2391  rr3=rrr(3)
2392  phi =2*pi*rr3
2393  CALL rotor2(thet,pnu,pnu)
2394  CALL rotor3( phi,pnu,pnu)
2395  CALL rotor2(thet,pwb,pwb)
2396  CALL rotor3( phi,pwb,pwb)
2397  CALL rotor2(thet,q1,q1)
2398  CALL rotor3( phi,q1,q1)
2399  CALL rotor2(thet,q2,q2)
2400  CALL rotor3( phi,q2,q2)
2401  CALL rotor2(thet,hv,hv)
2402  CALL rotor3( phi,hv,hv)
2403  CALL rotor2(thet,phx,phx)
2404  CALL rotor3( phi,phx,phx)
2405  DO 30 ,i=1,3
2406  30 hhv(i)=-isgn*hv(i)
2407  nevacc=nevacc+1
2408 C
2409  ELSEIF(mode.EQ. 1) THEN
2410 C =======================
2411  IF(nevraw.EQ.0) RETURN
2412  pargam=swt/float(nevraw+1)
2413  error=0
2414  IF(nevraw.NE.0) error=sqrt(sswt/swt**2-1./float(nevraw))
2415  rat=pargam/gamel
2416  WRITE(iout, 10000) nevraw,nevacc,nevovr,pargam,rat,error
2417 CC CALL HPRINT(803)
2418  gampmc(1)=rat
2419  gamper(1)=error
2420 CAM NEVDEC(1)=NEVACC
2421  ENDIF
2422 C =====
2423  RETURN
2424 10000 FORMAT(///1x,15(5h*****)
2425  + /,' *', 25x,'******** DADMEL FINAL REPORT ******** ',9x,1h*
2426  + /,' *',i20 ,5x,'NEVRAW = NO. OF EL DECAYS TOTAL ',9x,1h*
2427  + /,' *',i20 ,5x,'NEVACC = NO. OF EL DECS. ACCEPTED ',9x,1h*
2428  + /,' *',i20 ,5x,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9x,1h*
2429  + /,' *',e20.5,5x,'PARTIAL WTDTH ( ELECTRON) IN GEV UNITS ',9x,1h*
2430  + /,' *',f20.9,5x,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',9x,1h*
2431  + /,' *',f20.9,5x,'RELATIVE ERROR OF PARTIAL WIDTH ',9x,1h*
2432  + /,' *',25x, 'COMPLETE QED CORRECTIONS INCLUDED ',9x,1h*
2433  + /,' *',25x, 'BUT ONLY V-A CUPLINGS ',9x,1h*
2434  + /,1x,15(5h*****)/)
2435  40 WRITE(iout, 10100)
2436 10100 FORMAT(' ----- DADMEL: LACK OF INITIALISATION')
2437  stop
2438  END
2439 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
2440 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
2441 *-- AUTHOR :
2442  SUBROUTINE dadmkk(MODE,ISGN,HV,PKK,PNU)
2443 C ----------------------------------------------------------------------
2444 C FZ
2445  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
2446  REAL*4 gfermi,gv,ga,ccabib,scabib,gamel
2447  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
2448  * ,ampiz,ampi,amro,gamro,ama1,gama1
2449  * ,amk,amkz,amkst,gamkst
2450 C
2451  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
2452  * ,ampiz,ampi,amro,gamro,ama1,gama1
2453  * ,amk,amkz,amkst,gamkst
2454  COMMON / taubmc / gampmc(30),gamper(30),nevdec(30)
2455  REAL*4 gampmc ,gamper
2456  COMMON / inout / inut,iout
2457  REAL pkk(4),pnu(4),hv(4)
2458  DATA pi /3.141592653589793238462643/
2459 C
2460  IF(mode.EQ.-1) THEN
2461 C ===================
2462  nevtot=0
2463  ELSEIF(mode.EQ. 0) THEN
2464 C =======================
2465  nevtot=nevtot+1
2466  ekk= (amtau**2+amk**2-amnuta**2)/(2*amtau)
2467  enu= (amtau**2-amk**2+amnuta**2)/(2*amtau)
2468  xkk= sqrt(ekk**2-amk**2)
2469 C K MOMENTUM
2470  CALL sphera(xkk,pkk)
2471  pkk(4)=ekk
2472 C TAU-NEUTRINO MOMENTUM
2473  DO 10 i=1,3
2474  10 pnu(i)=-pkk(i)
2475  pnu(4)=enu
2476  pxq=amtau*ekk
2477  pxn=amtau*enu
2478  qxn=pkk(4)*pnu(4)-pkk(1)*pnu(1)-pkk(2)*pnu(2)-pkk(3)*pnu(3)
2479  brak=(gv**2+ga**2)*(2*pxq*qxn-amk**2*pxn)
2480  & +(gv**2-ga**2)*amtau*amnuta*amk**2
2481  DO 20 i=1,3
2482  20 hv(i)=-isgn*2*ga*gv*amtau*(2*pkk(i)*qxn-pnu(i)*amk**2)/brak
2483  hv(4)=1
2484 C
2485  ELSEIF(mode.EQ. 1) THEN
2486 C =======================
2487  IF(nevtot.EQ.0) RETURN
2488  fkk=0.0354
2489 CFZ THERE WAS BRAK/AMTAU**4 BEFORE
2490 C GAMM=(GFERMI*FKK)**2/(16.*PI)*AMTAU**3*
2491 C * (BRAK/AMTAU**4)**2
2492 CZW 7.02.93 HERE WAS AN ERROR AFFECTING NON STANDARD MODEL
2493 C CONFIGURATIONS ONLY
2494  gamm=(gfermi*fkk)**2/(16.*pi)*amtau**3*
2495  $ (brak/amtau**4)*
2496  $ sqrt((amtau**2-amk**2-amnuta**2)**2
2497  $ -4*amk**2*amnuta**2 )/amtau**2
2498  error=0
2499 
2500  error=0
2501  rat=gamm/gamel
2502  WRITE(iout, 10000) nevtot,gamm,rat,error
2503  gampmc(6)=rat
2504  gamper(6)=error
2505 CAM NEVDEC(6)=NEVTOT
2506  ENDIF
2507 C =====
2508  RETURN
2509 10000 FORMAT(///1x,15(5h*****)
2510  $ /,' *', 25x,'******** DADMKK FINAL REPORT ********',9x,1h*
2511  $ /,' *',i20 ,5x,'NEVTOT = NO. OF K DECAYS TOTAL ',9x,1h*,
2512  $ /,' *',e20.5,5x,'PARTIAL WTDTH ( K DECAY) IN GEV UNITS ',9x,1h*,
2513  $ /,' *',f20.9,5x,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',9x,1h*
2514  $ /,' *',f20.8,5x,'RELATIVE ERROR OF PARTIAL WIDTH (STAT.)',9x,1h*
2515  $ /,1x,15(5h*****)/)
2516  END
2517 *CMZ : 1.01/50 19/04/96 09.49.04 by Piero Zucchelli
2518 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
2519 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
2520 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
2521 *-- AUTHOR :
2522  SUBROUTINE dadmks(MODE,ISGN,HHV,PNU,PKS,PKK,PPI,JKST)
2523 C ----------------------------------------------------------------------
2524  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
2525  + ,ampiz,ampi,amro,gamro,ama1,gama1
2526  + ,amk,amkz,amkst,gamkst
2527 C
2528  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
2529  + ,ampiz,ampi,amro,gamro,ama1,gama1
2530  + ,amk,amkz,amkst,gamkst
2531  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
2532  REAL*4 gfermi,gv,ga,ccabib,scabib,gamel
2533  COMMON / taubmc / gampmc(30),gamper(30),nevdec(30)
2534  REAL*4 gampmc ,gamper
2535  COMMON / taukle / bra1,brk0,brk0b,brks
2536  REAL*4 bra1,brk0,brk0b,brks
2537  COMMON / inout / inut,iout
2538  REAL hhv(4)
2539  REAL hv(4),pks(4),pnu(4),pkk(4),ppi(4)
2540  REAL pdum1(4),pdum2(4),pdum3(4),pdum4(4)
2541  REAL*4 rrr(3),rtemp(1)
2542  REAL*8 swt, sswt
2543  DATA pi /3.141592653589793238462643/
2544  DATA iwarm/0/
2545 C
2546  IF(mode.EQ.-1) THEN
2547 C ===================
2548  iwarm=1
2549  nevraw=0
2550  nevacc=0
2551  nevovr=0
2552  swt=0
2553  sswt=0
2554  wtmax=1e-20
2555  DO 10 i=1,500
2556 C THE INITIALISATION IS DONE WITH THE 66.7% MODE
2557  jkst=10
2558  CALL dphsks(wt,hv,pdum1,pdum2,pdum3,pdum4,jkst)
2559  IF(wt.GT.wtmax/1.2) wtmax=wt*1.2
2560  10 CONTINUE
2561 CC CALL HBOOK1(801,'WEIGHT DISTRIBUTION DADMKS $',100,0,2)
2562 CC PRINT 7003,WTMAX
2563 CC CALL HBOOK1(112,'-------- K* MASS -------- $',100,0.,2.)
2564  ELSEIF(mode.EQ. 0) THEN
2565 C =====================================
2566  IF(iwarm.EQ.0) goto 40
2567 C HERE WE CHOOSE RANDOMLY BETWEEN K0 PI+_ (66.7%)
2568 C AND K+_ PI0 (33.3%)
2569  dec1=brks
2570  20 CONTINUE
2571  rtemp(1)=rmod
2572  CALL ranmar(rtemp,1)
2573  rmod=rtemp(1)
2574  IF(rmod.LT.dec1) THEN
2575  jkst=10
2576  ELSE
2577  jkst=20
2578  ENDIF
2579  CALL dphsks(wt,hv,pnu,pks,pkk,ppi,jkst)
2580  CALL ranmar(rrr,3)
2581  rn=rrr(1)
2582  IF(wt.GT.wtmax) nevovr=nevovr+1
2583  nevraw=nevraw+1
2584  swt=swt+wt
2585  sswt=sswt+wt**2
2586  IF(rn*wtmax.GT.wt) goto 20
2587 C ROTATIONS TO BASIC TAU REST FRAME
2588  costhe=-1.+2.*rrr(2)
2589  thet=acos(costhe)
2590  phi =2*pi*rrr(3)
2591  CALL rotor2(thet,pnu,pnu)
2592  CALL rotor3( phi,pnu,pnu)
2593  CALL rotor2(thet,pks,pks)
2594  CALL rotor3( phi,pks,pks)
2595  CALL rotor2(thet,pkk,pkk)
2596  CALL rotor3(phi,pkk,pkk)
2597  CALL rotor2(thet,ppi,ppi)
2598  CALL rotor3( phi,ppi,ppi)
2599  CALL rotor2(thet,hv,hv)
2600  CALL rotor3( phi,hv,hv)
2601  DO 30 i=1,3
2602  30 hhv(i)=-isgn*hv(i)
2603  nevacc=nevacc+1
2604 C
2605  ELSEIF(mode.EQ. 1) THEN
2606 C =======================
2607  IF(nevraw.EQ.0) RETURN
2608  pargam=swt/float(nevraw+1)
2609  error=0
2610  IF(nevraw.NE.0) error=sqrt(sswt/swt**2-1./float(nevraw))
2611  rat=pargam/gamel
2612  WRITE(iout, 10100) nevraw,nevacc,nevovr,pargam,rat,error
2613 CC CALL HPRINT(801)
2614  gampmc(7)=rat
2615  gamper(7)=error
2616 CAM NEVDEC(7)=NEVACC
2617  ENDIF
2618 C =====
2619  RETURN
2620 10000 FORMAT(///1x,15(5h*****)
2621  + /,' *', 25x,'******** DADMKS INITIALISATION ********',9x,1h*
2622  + /,' *',e20.5,5x,'WTMAX = MAXIMUM WEIGHT ',9x,1h*
2623  + /,1x,15(5h*****)/)
2624 10100 FORMAT(///1x,15(5h*****)
2625  + /,' *', 25x,'******** DADMKS FINAL REPORT ********',9x,1h*
2626  + /,' *',i20 ,5x,'NEVRAW = NO. OF K* DECAYS TOTAL ',9x,1h*,
2627  + /,' *',i20 ,5x,'NEVACC = NO. OF K* DECS. ACCEPTED ',9x,1h*,
2628  + /,' *',i20 ,5x,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9x,1h*
2629  + /,' *',e20.5,5x,'PARTIAL WTDTH (K* DECAY) IN GEV UNITS ',9x,1h*,
2630  + /,' *',f20.9,5x,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',9x,1h*
2631  + /,' *',f20.8,5x,'RELATIVE ERROR OF PARTIAL WIDTH ',9x,1h*
2632  + /,1x,15(5h*****)/)
2633  40 WRITE(iout, 10200)
2634 10200 FORMAT(' ----- DADMKS: LACK OF INITIALISATION')
2635  stop
2636  END
2637 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
2638 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
2639 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
2640 *-- AUTHOR :
2641  SUBROUTINE dadmmu(MODE,ISGN,HHV,PNU,PWB,Q1,Q2,PHX)
2642 C ----------------------------------------------------------------------
2643  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
2644  + ,ampiz,ampi,amro,gamro,ama1,gama1
2645  + ,amk,amkz,amkst,gamkst
2646 C
2647  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
2648  + ,ampiz,ampi,amro,gamro,ama1,gama1
2649  + ,amk,amkz,amkst,gamkst
2650  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
2651  REAL*4 gfermi,gv,ga,ccabib,scabib,gamel
2652  COMMON / taubmc / gampmc(30),gamper(30),nevdec(30)
2653  REAL*4 gampmc ,gamper
2654  COMMON / inout / inut,iout
2655  REAL*4 phx(4)
2656  REAL hhv(4),hv(4),pnu(4),pwb(4),q1(4),q2(4)
2657  REAL pdum1(4),pdum2(4),pdum3(4),pdum4(4),pdum5(4)
2658  REAL*4 rrr(3)
2659  REAL*8 swt, sswt
2660  DATA pi /3.141592653589793238462643/
2661  DATA iwarm /0/
2662 C
2663  IF(mode.EQ.-1) THEN
2664 C ===================
2665  iwarm=1
2666  nevraw=0
2667  nevacc=0
2668  nevovr=0
2669  swt=0
2670  sswt=0
2671  wtmax=1e-20
2672  DO 10 i=1,500
2673  CALL dphsmu(wt,hv,pdum1,pdum2,pdum3,pdum4,pdum5)
2674  IF(wt.GT.wtmax/1.2) wtmax=wt*1.2
2675  10 CONTINUE
2676 CC CALL HBOOK1(802,'WEIGHT DISTRIBUTION DADMMU $',100,0,2)
2677 C
2678  ELSEIF(mode.EQ. 0) THEN
2679 C =======================
2680  20 CONTINUE
2681  IF(iwarm.EQ.0) goto 40
2682  nevraw=nevraw+1
2683  CALL dphsmu(wt,hv,pnu,pwb,q1,q2,phx)
2684 CC CALL HFILL(802,WT/WTMAX)
2685  swt=swt+wt
2686  sswt=sswt+wt**2
2687  CALL ranmar(rrr,3)
2688  rn=rrr(1)
2689  IF(wt.GT.wtmax) nevovr=nevovr+1
2690  IF(rn*wtmax.GT.wt) goto 20
2691 C ROTATIONS TO BASIC TAU REST FRAME
2692  costhe=-1.+2.*rrr(2)
2693  thet=acos(costhe)
2694  phi =2*pi*rrr(3)
2695  CALL rotor2(thet,pnu,pnu)
2696  CALL rotor3( phi,pnu,pnu)
2697  CALL rotor2(thet,pwb,pwb)
2698  CALL rotor3( phi,pwb,pwb)
2699  CALL rotor2(thet,q1,q1)
2700  CALL rotor3( phi,q1,q1)
2701  CALL rotor2(thet,q2,q2)
2702  CALL rotor3( phi,q2,q2)
2703  CALL rotor2(thet,hv,hv)
2704  CALL rotor3( phi,hv,hv)
2705  CALL rotor2(thet,phx,phx)
2706  CALL rotor3( phi,phx,phx)
2707  DO 30 ,i=1,3
2708  30 hhv(i)=-isgn*hv(i)
2709  nevacc=nevacc+1
2710 C
2711  ELSEIF(mode.EQ. 1) THEN
2712 C =======================
2713  IF(nevraw.EQ.0) RETURN
2714  pargam=swt/float(nevraw+1)
2715  error=0
2716  IF(nevraw.NE.0) error=sqrt(sswt/swt**2-1./float(nevraw))
2717  rat=pargam/gamel
2718  WRITE(iout, 10000) nevraw,nevacc,nevovr,pargam,rat,error
2719 CC CALL HPRINT(802)
2720  gampmc(2)=rat
2721  gamper(2)=error
2722 CAM NEVDEC(2)=NEVACC
2723  ENDIF
2724 C =====
2725  RETURN
2726 10000 FORMAT(///1x,15(5h*****)
2727  + /,' *', 25x,'******** DADMMU FINAL REPORT ******** ',9x,1h*
2728  + /,' *',i20 ,5x,'NEVRAW = NO. OF MU DECAYS TOTAL ',9x,1h*
2729  + /,' *',i20 ,5x,'NEVACC = NO. OF MU DECS. ACCEPTED ',9x,1h*
2730  + /,' *',i20 ,5x,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9x,1h*
2731  + /,' *',e20.5,5x,'PARTIAL WTDTH (MU DECAY) IN GEV UNITS ',9x,1h*
2732  + /,' *',f20.9,5x,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',9x,1h*
2733  + /,' *',f20.9,5x,'RELATIVE ERROR OF PARTIAL WIDTH ',9x,1h*
2734  + /,' *',25x, 'COMPLETE QED CORRECTIONS INCLUDED ',9x,1h*
2735  + /,' *',25x, 'BUT ONLY V-A CUPLINGS ',9x,1h*
2736  + /,1x,15(5h*****)/)
2737  40 WRITE(iout, 10100)
2738 10100 FORMAT(' ----- DADMMU: LACK OF INITIALISATION')
2739  stop
2740  END
2741 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
2742 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
2743 *-- AUTHOR :
2744  SUBROUTINE dadmpi(MODE,ISGN,HV,PPI,PNU)
2745 C ----------------------------------------------------------------------
2746  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
2747  * ,ampiz,ampi,amro,gamro,ama1,gama1
2748  * ,amk,amkz,amkst,gamkst
2749 C
2750  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
2751  * ,ampiz,ampi,amro,gamro,ama1,gama1
2752  * ,amk,amkz,amkst,gamkst
2753  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
2754  REAL*4 gfermi,gv,ga,ccabib,scabib,gamel
2755  COMMON / taubmc / gampmc(30),gamper(30),nevdec(30)
2756  REAL*4 gampmc ,gamper
2757  COMMON / inout / inut,iout
2758  REAL ppi(4),pnu(4),hv(4)
2759  DATA pi /3.141592653589793238462643/
2760 C
2761  IF(mode.EQ.-1) THEN
2762 C ===================
2763  nevtot=0
2764  ELSEIF(mode.EQ. 0) THEN
2765 C =======================
2766  nevtot=nevtot+1
2767  epi= (amtau**2+ampi**2-amnuta**2)/(2*amtau)
2768  enu= (amtau**2-ampi**2+amnuta**2)/(2*amtau)
2769  xpi= sqrt(epi**2-ampi**2)
2770 C PI MOMENTUM
2771  CALL sphera(xpi,ppi)
2772  ppi(4)=epi
2773 C TAU-NEUTRINO MOMENTUM
2774  DO 10 i=1,3
2775  10 pnu(i)=-ppi(i)
2776  pnu(4)=enu
2777  pxq=amtau*epi
2778  pxn=amtau*enu
2779  qxn=ppi(4)*pnu(4)-ppi(1)*pnu(1)-ppi(2)*pnu(2)-ppi(3)*pnu(3)
2780  brak=(gv**2+ga**2)*(2*pxq*qxn-ampi**2*pxn)
2781  & +(gv**2-ga**2)*amtau*amnuta*ampi**2
2782  DO 20 i=1,3
2783  20 hv(i)=-isgn*2*ga*gv*amtau*(2*ppi(i)*qxn-pnu(i)*ampi**2)/brak
2784  hv(4)=1
2785 C
2786  ELSEIF(mode.EQ. 1) THEN
2787 C =======================
2788  IF(nevtot.EQ.0) RETURN
2789  fpi=0.1284
2790 C GAMM=(GFERMI*FPI)**2/(16.*PI)*AMTAU**3*
2791 C * (BRAK/AMTAU**4)**2
2792 CZW 7.02.93 HERE WAS AN ERROR AFFECTING NON STANDARD MODEL
2793 C CONFIGURATIONS ONLY
2794  gamm=(gfermi*fpi)**2/(16.*pi)*amtau**3*
2795  $ (brak/amtau**4)*
2796  $ sqrt((amtau**2-ampi**2-amnuta**2)**2
2797  $ -4*ampi**2*amnuta**2 )/amtau**2
2798  error=0
2799  rat=gamm/gamel
2800  WRITE(iout, 10000) nevtot,gamm,rat,error
2801  gampmc(3)=rat
2802  gamper(3)=error
2803 CAM NEVDEC(3)=NEVTOT
2804  ENDIF
2805 C =====
2806  RETURN
2807 10000 FORMAT(///1x,15(5h*****)
2808  $ /,' *', 25x,'******** DADMPI FINAL REPORT ******** ',9x,1h*
2809  $ /,' *',i20 ,5x,'NEVTOT = NO. OF PI DECAYS TOTAL ',9x,1h*
2810  $ /,' *',e20.5,5x,'PARTIAL WTDTH ( PI DECAY) IN GEV UNITS ',9x,1h*
2811  $ /,' *',f20.9,5x,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',9x,1h*
2812  $ /,' *',f20.8,5x,'RELATIVE ERROR OF PARTIAL WIDTH (STAT.)',9x,1h*
2813  $ /,1x,15(5h*****)/)
2814  END
2815 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
2816 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
2817 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
2818 *-- AUTHOR :
2819  SUBROUTINE dadmro(MODE,ISGN,HHV,PNU,PRO,PIC,PIZ)
2820 C ----------------------------------------------------------------------
2821  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
2822  + ,ampiz,ampi,amro,gamro,ama1,gama1
2823  + ,amk,amkz,amkst,gamkst
2824 C
2825  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
2826  + ,ampiz,ampi,amro,gamro,ama1,gama1
2827  + ,amk,amkz,amkst,gamkst
2828  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
2829  REAL*4 gfermi,gv,ga,ccabib,scabib,gamel
2830  COMMON / taubmc / gampmc(30),gamper(30),nevdec(30)
2831  REAL*4 gampmc ,gamper
2832  COMMON / inout / inut,iout
2833  REAL hhv(4)
2834  REAL hv(4),pro(4),pnu(4),pic(4),piz(4)
2835  REAL pdum1(4),pdum2(4),pdum3(4),pdum4(4)
2836  REAL*4 rrr(3)
2837  REAL*8 swt, sswt
2838  DATA pi /3.141592653589793238462643/
2839  DATA iwarm/0/
2840 C
2841  IF(mode.EQ.-1) THEN
2842 C ===================
2843  iwarm=1
2844  nevraw=0
2845  nevacc=0
2846  nevovr=0
2847  swt=0
2848  sswt=0
2849  wtmax=1e-20
2850  DO 10 i=1,500
2851  CALL dphsro(wt,hv,pdum1,pdum2,pdum3,pdum4)
2852  IF(wt.GT.wtmax/1.2) wtmax=wt*1.2
2853  10 CONTINUE
2854 CC CALL HBOOK1(801,'WEIGHT DISTRIBUTION DADMRO $',100,0,2)
2855 CC PRINT 7003,WTMAX
2856 C
2857  ELSEIF(mode.EQ. 0) THEN
2858 C =======================
2859  20 CONTINUE
2860  IF(iwarm.EQ.0) goto 40
2861  CALL dphsro(wt,hv,pnu,pro,pic,piz)
2862 CC CALL HFILL(801,WT/WTMAX)
2863  nevraw=nevraw+1
2864  swt=swt+wt
2865  sswt=sswt+wt**2
2866  CALL ranmar(rrr,3)
2867  rn=rrr(1)
2868  IF(wt.GT.wtmax) nevovr=nevovr+1
2869  IF(rn*wtmax.GT.wt) goto 20
2870 C ROTATIONS TO BASIC TAU REST FRAME
2871  costhe=-1.+2.*rrr(2)
2872  thet=acos(costhe)
2873  phi =2*pi*rrr(3)
2874  CALL rotor2(thet,pnu,pnu)
2875  CALL rotor3( phi,pnu,pnu)
2876  CALL rotor2(thet,pro,pro)
2877  CALL rotor3( phi,pro,pro)
2878  CALL rotor2(thet,pic,pic)
2879  CALL rotor3( phi,pic,pic)
2880  CALL rotor2(thet,piz,piz)
2881  CALL rotor3( phi,piz,piz)
2882  CALL rotor2(thet,hv,hv)
2883  CALL rotor3( phi,hv,hv)
2884  DO 30 i=1,3
2885  30 hhv(i)=-isgn*hv(i)
2886  nevacc=nevacc+1
2887 C
2888  ELSEIF(mode.EQ. 1) THEN
2889 C =======================
2890  IF(nevraw.EQ.0) RETURN
2891  pargam=swt/float(nevraw+1)
2892  error=0
2893  IF(nevraw.NE.0) error=sqrt(sswt/swt**2-1./float(nevraw))
2894  rat=pargam/gamel
2895  WRITE(iout, 10100) nevraw,nevacc,nevovr,pargam,rat,error
2896 CC CALL HPRINT(801)
2897  gampmc(4)=rat
2898  gamper(4)=error
2899 CAM NEVDEC(4)=NEVACC
2900  ENDIF
2901 C =====
2902  RETURN
2903 10000 FORMAT(///1x,15(5h*****)
2904  + /,' *', 25x,'******** DADMRO INITIALISATION ********',9x,1h*
2905  + /,' *',e20.5,5x,'WTMAX = MAXIMUM WEIGHT ',9x,1h*
2906  + /,1x,15(5h*****)/)
2907 10100 FORMAT(///1x,15(5h*****)
2908  + /,' *', 25x,'******** DADMRO FINAL REPORT ******** ',9x,1h*
2909  + /,' *',i20 ,5x,'NEVRAW = NO. OF RHO DECAYS TOTAL ',9x,1h*
2910  + /,' *',i20 ,5x,'NEVACC = NO. OF RHO DECS. ACCEPTED ',9x,1h*
2911  + /,' *',i20 ,5x,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9x,1h*
2912  + /,' *',e20.5,5x,'PARTIAL WTDTH (RHO DECAY) IN GEV UNITS ',9x,1h*
2913  + /,' *',f20.9,5x,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',9x,1h*
2914  + /,' *',f20.8,5x,'RELATIVE ERROR OF PARTIAL WIDTH ',9x,1h*
2915  + /,1x,15(5h*****)/)
2916  40 WRITE(iout, 10200)
2917 10200 FORMAT(' ----- DADMRO: LACK OF INITIALISATION')
2918  stop
2919  END
2920 *CMZ : 1.01/50 22/05/96 18.06.08 by Piero Zucchelli
2921 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
2922 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
2923 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
2924 *-- AUTHOR :
2925  SUBROUTINE dadnew(MODE,ISGN,HV,PNU,PWB,PNPI,JNPI)
2926 C ----------------------------------------------------------------------
2927  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
2928  + ,ampiz,ampi,amro,gamro,ama1,gama1
2929  + ,amk,amkz,amkst,gamkst
2930 C
2931  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
2932  + ,ampiz,ampi,amro,gamro,ama1,gama1
2933  + ,amk,amkz,amkst,gamkst
2934  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
2935  REAL*4 gfermi,gv,ga,ccabib,scabib,gamel
2936  COMMON / taubmc / gampmc(30),gamper(30),nevdec(30)
2937  REAL*4 gampmc ,gamper
2938  COMMON / inout / inut,iout
2939  parameter(nmode=15,nm1=0,nm2=1,nm3=8,nm4=2,nm5=1,nm6=3)
2940  COMMON / mdecomp /idffin(9,nmode),mulpik(nmode)
2941  + ,names
2942  CHARACTER names(nmode)*31
2943 
2944  REAL*4 pnu(4),pwb(4),pnpi(4,9),hv(4),hhv(4)
2945  REAL*4 pdum1(4),pdum2(4),pdumi(4,9)
2946  REAL*4 rrr(3)
2947  REAL*4 wtmax(nmode)
2948  REAL*8 swt(nmode),sswt(nmode)
2949  dimension nevraw(nmode),nevovr(nmode),nevacc(nmode)
2950 C
2951  DATA pi /3.141592653589793238462643/
2952  DATA iwarm/0/
2953 C
2954  IF(mode.EQ.-1) THEN
2955 C ===================
2956 C -- AT THE MOMENT ONLY TWO DECAY MODES OF MULTIPIONS HAVE M. ELEM
2957  nmod=nmode
2958  iwarm=1
2959 C PRINT 7003
2960  DO 10 jnpi=1,nmod
2961  nevraw(jnpi)=0
2962  nevacc(jnpi)=0
2963  nevovr(jnpi)=0
2964  swt(jnpi)=0
2965  sswt(jnpi)=0
2966  wtmax(jnpi)=-1.
2967  DO i=1,500
2968  IF (jnpi.LE.0) THEN
2969  goto 60
2970  ELSEIF(jnpi.LE.nm4) THEN
2971  CALL dph4pi(wt,hv,pdum1,pdum2,pdumi,jnpi)
2972  ELSEIF(jnpi.LE.nm4+nm5) THEN
2973  CALL dph5pi(wt,hv,pdum1,pdum2,pdumi,jnpi)
2974  ELSEIF(jnpi.LE.nm4+nm5+nm6) THEN
2975  CALL dphnpi(wt,hv,pdum1,pdum2,pdumi,jnpi)
2976  ELSEIF(jnpi.LE.nm4+nm5+nm6+nm3) THEN
2977  inum=jnpi-nm4-nm5-nm6
2978  CALL dphspk(wt,hv,pdum1,pdum2,pdumi,inum)
2979  ELSEIF(jnpi.LE.nm4+nm5+nm6+nm3+nm2) THEN
2980  inum=jnpi-nm4-nm5-nm6-nm3
2981  CALL dphsrk(wt,hv,pdum1,pdum2,pdumi,inum)
2982  ELSE
2983  goto 60
2984  ENDIF
2985  IF(wt.GT.wtmax(jnpi)/1.2) wtmax(jnpi)=wt*1.2
2986  ENDDO
2987 C CALL HBOOK1(801,'WEIGHT DISTRIBUTION DADNPI $',100,0.,2.,.0)
2988 C PRINT 7004,WTMAX(JNPI)
2989  10 CONTINUE
2990  WRITE(iout,10200)
2991 C
2992  ELSEIF(mode.EQ. 0) THEN
2993 C =======================
2994  IF(iwarm.EQ.0) goto 50
2995 C
2996  20 CONTINUE
2997  IF (jnpi.LE.0) THEN
2998  goto 60
2999  ELSEIF(jnpi.LE.nm4) THEN
3000  CALL dph4pi(wt,hhv,pnu,pwb,pnpi,jnpi)
3001  ELSEIF(jnpi.LE.nm4+nm5) THEN
3002  CALL dph5pi(wt,hhv,pnu,pwb,pnpi,jnpi)
3003  ELSEIF(jnpi.LE.nm4+nm5+nm6) THEN
3004  CALL dphnpi(wt,hhv,pnu,pwb,pnpi,jnpi)
3005  ELSEIF(jnpi.LE.nm4+nm5+nm6+nm3) THEN
3006  inum=jnpi-nm4-nm5-nm6
3007  CALL dphspk(wt,hhv,pnu,pwb,pnpi,inum)
3008  ELSEIF(jnpi.LE.nm4+nm5+nm6+nm3+nm2) THEN
3009  inum=jnpi-nm4-nm5-nm6-nm3
3010  CALL dphsrk(wt,hhv,pnu,pwb,pnpi,inum)
3011  ELSE
3012  goto 60
3013  ENDIF
3014  DO i=1,4
3015  hv(i)=-isgn*hhv(i)
3016  ENDDO
3017 C CALL HFILL(801,WT/WTMAX(JNPI))
3018  nevraw(jnpi)=nevraw(jnpi)+1
3019  swt(jnpi)=swt(jnpi)+wt
3020  sswt(jnpi)=sswt(jnpi)+wt**2
3021  CALL ranmar(rrr,3)
3022  rn=rrr(1)
3023  IF(wt.GT.wtmax(jnpi)) nevovr(jnpi)=nevovr(jnpi)+1
3024  IF(rn*wtmax(jnpi).GT.wt) goto 20
3025 C ROTATIONS TO BASIC TAU REST FRAME
3026  costhe=-1.+2.*rrr(2)
3027  thet=acos(costhe)
3028  phi =2*pi*rrr(3)
3029  CALL rotor2(thet,pnu,pnu)
3030  CALL rotor3( phi,pnu,pnu)
3031  CALL rotor2(thet,pwb,pwb)
3032  CALL rotor3( phi,pwb,pwb)
3033  CALL rotor2(thet,hv,hv)
3034  CALL rotor3( phi,hv,hv)
3035  nd=mulpik(jnpi)
3036  DO 30 i=1,nd
3037  CALL rotor2(thet,pnpi(1,i),pnpi(1,i))
3038  CALL rotor3( phi,pnpi(1,i),pnpi(1,i))
3039  30 CONTINUE
3040  nevacc(jnpi)=nevacc(jnpi)+1
3041 C
3042  ELSEIF(mode.EQ. 1) THEN
3043 C =======================
3044  DO 40 jnpi=1,nmod
3045  IF(nevraw(jnpi).EQ.0) goto 40
3046  pargam=swt(jnpi)/float(nevraw(jnpi)+1)
3047  error=0
3048  IF(nevraw(jnpi).NE.0)
3049  + error=sqrt(sswt(jnpi)/swt(jnpi)**2-1./float(nevraw(jnpi)))
3050  rat=pargam/gamel
3051  WRITE(iout, 10300) names(jnpi), nevraw(jnpi),nevacc(jnpi),
3052  + nevovr(jnpi),pargam,rat,error
3053 CC CALL HPRINT(801)
3054  gampmc(8+jnpi-1)=rat
3055  gamper(8+jnpi-1)=error
3056 CAM NEVDEC(8+JNPI-1)=NEVACC(JNPI)
3057  40 CONTINUE
3058  ENDIF
3059 C =====
3060  RETURN
3061 10000 FORMAT(///1x,15(5h*****)
3062  + /,' *', 25x,'******** DADNEW INITIALISATION ********',9x,1h*
3063  + )
3064 10100 FORMAT(' *',e20.5,5x,'WTMAX = MAXIMUM WEIGHT ',9x,1h*/)
3065 10200 FORMAT(
3066  + /,1x,15(5h*****)/)
3067 10300 FORMAT(///1x,15(5h*****)
3068  + /,' *', 25x,'******** DADNEW FINAL REPORT ******** ',9x,1h*
3069  + /,' *', 25x,'CHANNEL:',a31 ,9x,1h*
3070  + /,' *',i20 ,5x,'NEVRAW = NO. OF DECAYS TOTAL ',9x,1h*
3071  + /,' *',i20 ,5x,'NEVACC = NO. OF DECAYS ACCEPTED ',9x,1h*
3072  + /,' *',i20 ,5x,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9x,1h*
3073  + /,' *',e20.5,5x,'PARTIAL WTDTH IN GEV UNITS ',9x,1h*
3074  + /,' *',f20.9,5x,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',9x,1h*
3075  + /,' *',f20.8,5x,'RELATIVE ERROR OF PARTIAL WIDTH ',9x,1h*
3076  + /,1x,15(5h*****)/)
3077  50 WRITE(iout, 10400)
3078 10400 FORMAT(' ----- DADNEW: LACK OF INITIALISATION')
3079  stop
3080  60 WRITE(iout, 10500) jnpi,mode
3081 10500 FORMAT(' ----- DADNEW: WRONG JNPI',2i5)
3082  stop
3083  END
3084 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
3085 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
3086 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
3087 *-- AUTHOR :
3088  SUBROUTINE dam4pi(MNUM,PT,PN,PIM1,PIM2,PIM3,PIM4,AMPLIT,HV)
3089 C ----------------------------------------------------------------------
3090 * CALCULATES DIFFERENTIAL CROSS SECTION AND POLARIMETER VECTOR
3091 * FOR TAU DECAY INTO 4 PI MODES
3092 * ALL SPIN EFFECTS IN THE FULL DECAY CHAIN ARE TAKEN INTO ACCOUNT.
3093 * CALCULATIONS DONE IN TAU REST FRAME WITH Z-AXIS ALONG NEUTRINO MOMENT
3094 C MNUM DECAY MODE IDENTIFIER.
3095 C
3096 C CALLED BY : DPHSAA
3097 C ----------------------------------------------------------------------
3098  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
3099  + ,ampiz,ampi,amro,gamro,ama1,gama1
3100  + ,amk,amkz,amkst,gamkst
3101 C
3102  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
3103  + ,ampiz,ampi,amro,gamro,ama1,gama1
3104  + ,amk,amkz,amkst,gamkst
3105  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
3106  REAL*4 gfermi,gv,ga,ccabib,scabib,gamel
3107  REAL hv(4),pt(4),pn(4),pim1(4),pim2(4),pim3(4),pim4(4)
3108  REAL pivec(4),piaks(4),hvm(4)
3109  COMPLEX hadcur(4),form1,form2,form3,form4,form5
3110  EXTERNAL form1,form2,form3,form4,form5
3111  DATA pi /3.141592653589793238462643/
3112  DATA icont /0/
3113 C
3114  CALL curr(mnum,pim1,pim2,pim3,pim4,hadcur)
3115 C
3116 * CALCULATE PI-VECTORS: VECTOR AND AXIAL
3117  CALL clvec(hadcur,pn,pivec)
3118  CALL claxi(hadcur,pn,piaks)
3119  CALL clnut(hadcur,brakm,hvm)
3120 * SPIN INDEPENDENT PART OF DECAY DIFF-CROSS-SECT. IN TAU REST FRAME
3121  brak= (gv**2+ga**2)*pt(4)*pivec(4) +2.*gv*ga*pt(4)*piaks(4)
3122  + +2.*(gv**2-ga**2)*amnuta*amtau*brakm
3123  amplit=(ccabib*gfermi)**2*brak/2.
3124 C POLARIMETER VECTOR IN TAU REST FRAME
3125  DO 10 i=1,3
3126  hv(i)=-(amtau*((gv**2+ga**2)*piaks(i)+2.*gv*ga*pivec(i)))
3127  + +(gv**2-ga**2)*amnuta*amtau*hvm(i)
3128 C HV IS DEFINED FOR TAU- WITH GAMMA=B+HV*POL
3129  IF (brak.NE.0.0) hv(i)=-hv(i)/brak
3130  10 CONTINUE
3131  END
3132 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
3133 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
3134 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
3135 *-- AUTHOR :
3136  SUBROUTINE dampaa(PT,PN,PIM1,PIM2,PIPL,AMPLIT,HV)
3137 C ----------------------------------------------------------------------
3138 * CALCULATES DIFFERENTIAL CROSS SECTION AND POLARIMETER VECTOR
3139 * FOR TAU DECAY INTO A1, A1 DECAYS NEXT INTO RHO+PI AND RHO INTO PI+PI.
3140 * ALL SPIN EFFECTS IN THE FULL DECAY CHAIN ARE TAKEN INTO ACCOUNT.
3141 * CALCULATIONS DONE IN TAU REST FRAME WITH Z-AXIS ALONG NEUTRINO MOMENT
3142 * THE ROUTINE IS WRITEN FOR ZERO NEUTRINO MASS.
3143 C
3144 C CALLED BY : DPHSAA
3145 C ----------------------------------------------------------------------
3146  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
3147  + ,ampiz,ampi,amro,gamro,ama1,gama1
3148  + ,amk,amkz,amkst,gamkst
3149 C
3150  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
3151  + ,ampiz,ampi,amro,gamro,ama1,gama1
3152  + ,amk,amkz,amkst,gamkst
3153  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
3154  REAL*4 gfermi,gv,ga,ccabib,scabib,gamel
3155  COMMON /testa1/ keya1
3156  REAL hv(4),pt(4),pn(4),pim1(4),pim2(4),pipl(4)
3157  REAL paa(4),vec1(4),vec2(4)
3158  REAL pivec(4),piaks(4),hvm(4)
3159  COMPLEX bwign,hadcur(4),fpik
3160  DATA icont /1/
3161 C
3162 * F CONSTANTS FOR A1, A1-RHO-PI, AND RHO-PI-PI
3163 *
3164  DATA fpi /93.3e-3/
3165 * THIS INLINE FUNCT. CALCULATES THE SCALAR PART OF THE PROPAGATOR
3166  bwign(xm,am,gamma)=1./cmplx(xm**2-am**2,gamma*am)
3167 C
3168 * FOUR MOMENTUM OF A1
3169  DO 10 i=1,4
3170  10 paa(i)=pim1(i)+pim2(i)+pipl(i)
3171 * MASSES OF A1, AND OF TWO PI-PAIRS WHICH MAY FORM RHO
3172  xmaa =sqrt(abs(paa(4)**2-paa(3)**2-paa(2)**2-paa(1)**2))
3173  xmro1 =sqrt(abs((pipl(4)+pim1(4))**2-(pipl(1)+pim1(1))**2
3174  + -(pipl(2)+pim1(2))**2-(pipl(3)+pim1(3))**2))
3175  xmro2 =sqrt(abs((pipl(4)+pim2(4))**2-(pipl(1)+pim2(1))**2
3176  + -(pipl(2)+pim2(2))**2-(pipl(3)+pim2(3))**2))
3177 * ELEMENTS OF HADRON CURRENT
3178  prod1 =paa(4)*(pim1(4)-pipl(4))-paa(1)*(pim1(1)-pipl(1))
3179  + -paa(2)*(pim1(2)-pipl(2))-paa(3)*(pim1(3)-pipl(3))
3180  prod2 =paa(4)*(pim2(4)-pipl(4))-paa(1)*(pim2(1)-pipl(1))
3181  + -paa(2)*(pim2(2)-pipl(2))-paa(3)*(pim2(3)-pipl(3))
3182  DO 20 i=1,4
3183  vec1(i)= pim1(i)-pipl(i) -paa(i)*prod1/xmaa**2
3184  20 vec2(i)= pim2(i)-pipl(i) -paa(i)*prod2/xmaa**2
3185 * HADRON CURRENT SATURATED WITH A1 AND RHO RESONANCES
3186  IF (keya1.EQ.1) THEN
3187  fa1=9.87
3188  faropi=1.0
3189  fro2pi=1.0
3190  fnorm=fa1/sqrt(2.)*faropi*fro2pi
3191  DO 30 i=1,4
3192  hadcur(i)= cmplx(fnorm) *ama1**2*bwign(xmaa,ama1,gama1)
3193  + *(cmplx(vec1(i))*amro**2*bwign(xmro1,amro,gamro) +
3194  + cmplx(vec2(i))*amro**2*bwign(xmro2,amro,gamro))
3195  30 CONTINUE
3196  ELSE
3197  fnorm=2.0*sqrt(2.)/3.0/fpi
3198  gamax=gama1*gfun(xmaa**2)/gfun(ama1**2)
3199  DO 40 i=1,4
3200  hadcur(i)= cmplx(fnorm) *ama1**2*bwign(xmaa,ama1,gamax)
3201  + *(cmplx(vec1(i))*fpik(xmro1) +cmplx(vec2(i))*fpik(xmro2))
3202  40 CONTINUE
3203  ENDIF
3204 C
3205 * CALCULATE PI-VECTORS: VECTOR AND AXIAL
3206  CALL clvec(hadcur,pn,pivec)
3207  CALL claxi(hadcur,pn,piaks)
3208  CALL clnut(hadcur,brakm,hvm)
3209 * SPIN INDEPENDENT PART OF DECAY DIFF-CROSS-SECT. IN TAU REST FRAME
3210  brak= (gv**2+ga**2)*pt(4)*pivec(4) +2.*gv*ga*pt(4)*piaks(4)
3211  + +2.*(gv**2-ga**2)*amnuta*amtau*brakm
3212  amplit=(gfermi*ccabib)**2*brak/2.
3213 C THE STATISTICAL FACTOR FOR IDENTICAL PI'S WAS CANCELLED WITH
3214 C TWO, FOR TWO MODES OF A1 DECAY NAMELLY PI+PI-PI- AND PI-PI0PI0
3215 C POLARIMETER VECTOR IN TAU REST FRAME
3216  DO 50 i=1,3
3217  hv(i)=-(amtau*((gv**2+ga**2)*piaks(i)+2.*gv*ga*pivec(i)))
3218  + +(gv**2-ga**2)*amnuta*amtau*hvm(i)
3219 C HV IS DEFINED FOR TAU- WITH GAMMA=B+HV*POL
3220  hv(i)=-hv(i)/brak
3221  50 CONTINUE
3222  END
3223 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
3224 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
3225 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
3226 *-- AUTHOR :
3227  SUBROUTINE dampog(PT,PN,PIM1,PIM2,PIPL,AMPLIT,HV)
3228 C ----------------------------------------------------------------------
3229 * CALCULATES DIFFERENTIAL CROSS SECTION AND POLARIMETER VECTOR
3230 * FOR TAU DECAY INTO A1, A1 DECAYS NEXT INTO RHO+PI AND RHO INTO PI+PI.
3231 * ALL SPIN EFFECTS IN THE FULL DECAY CHAIN ARE TAKEN INTO ACCOUNT.
3232 * CALCULATIONS DONE IN TAU REST FRAME WITH Z-AXIS ALONG NEUTRINO MOMENT
3233 * THE ROUTINE IS WRITEN FOR ZERO NEUTRINO MASS.
3234 C
3235 C CALLED BY : DPHSAA
3236 C ----------------------------------------------------------------------
3237  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
3238  + ,ampiz,ampi,amro,gamro,ama1,gama1
3239  + ,amk,amkz,amkst,gamkst
3240 C
3241  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
3242  + ,ampiz,ampi,amro,gamro,ama1,gama1
3243  + ,amk,amkz,amkst,gamkst
3244  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
3245  REAL*4 gfermi,gv,ga,ccabib,scabib,gamel
3246  COMMON /testa1/ keya1
3247  REAL hv(4),pt(4),pn(4),pim1(4),pim2(4),pipl(4)
3248  REAL paa(4),vec1(4),vec2(4)
3249  REAL pivec(4),piaks(4),hvm(4)
3250  COMPLEX bwign,hadcur(4),fnorm,formom
3251  DATA icont /1/
3252 * THIS INLINE FUNCT. CALCULATES THE SCALAR PART OF THE PROPAGATOR
3253  bwign(xm,am,gamma)=1./cmplx(xm**2-am**2,gamma*am)
3254 C
3255 * FOUR MOMENTUM OF A1
3256  DO 10 i=1,4
3257  vec1(i)=0.0
3258  vec2(i)=0.0
3259  hv(i) =0.0
3260  10 paa(i)=pim1(i)+pim2(i)+pipl(i)
3261  vec1(1)=1.0
3262 * MASSES OF A1, AND OF TWO PI-PAIRS WHICH MAY FORM RHO
3263  xmaa =sqrt(abs(paa(4)**2-paa(3)**2-paa(2)**2-paa(1)**2))
3264  xmom =sqrt(abs( (pim2(4)+pipl(4))**2-(pim2(3)+pipl(3))**2
3265  + -(pim2(2)+pipl(2))**2-(pim2(1)+pipl(1))**2 ))
3266  xmro2 =(pipl(1))**2 +(pipl(2))**2 +(pipl(3))**2
3267 * ELEMENTS OF HADRON CURRENT
3268  prod1 =vec1(1)*pipl(1)
3269  prod2 =vec2(2)*pipl(2)
3270  p12 =pim1(4)*pim2(4)-pim1(1)*pim2(1)
3271  + -pim1(2)*pim2(2)-pim1(3)*pim2(3)
3272  p1pl =pim1(4)*pipl(4)-pim1(1)*pipl(1)
3273  + -pim1(2)*pipl(2)-pim1(3)*pipl(3)
3274  p2pl =pipl(4)*pim2(4)-pipl(1)*pim2(1)
3275  + -pipl(2)*pim2(2)-pipl(3)*pim2(3)
3276  DO 20 i=1,3
3277  vec1(i)= (vec1(i)-prod1/xmro2*pipl(i))
3278  20 CONTINUE
3279  gnorm=sqrt(vec1(1)**2+vec1(2)**2+vec1(3)**2)
3280  DO 30 i=1,3
3281  vec1(i)= vec1(i)/gnorm
3282  30 CONTINUE
3283  vec2(1)=(vec1(2)*pipl(3)-vec1(3)*pipl(2))/sqrt(xmro2)
3284  vec2(2)=(vec1(3)*pipl(1)-vec1(1)*pipl(3))/sqrt(xmro2)
3285  vec2(3)=(vec1(1)*pipl(2)-vec1(2)*pipl(1))/sqrt(xmro2)
3286  p1vec1 =pim1(4)*vec1(4)-pim1(1)*vec1(1)
3287  + -pim1(2)*vec1(2)-pim1(3)*vec1(3)
3288  p2vec1 =vec1(4)*pim2(4)-vec1(1)*pim2(1)
3289  + -vec1(2)*pim2(2)-vec1(3)*pim2(3)
3290  p1vec2 =pim1(4)*vec2(4)-pim1(1)*vec2(1)
3291  + -pim1(2)*vec2(2)-pim1(3)*vec2(3)
3292  p2vec2 =vec2(4)*pim2(4)-vec2(1)*pim2(1)
3293  + -vec2(2)*pim2(2)-vec2(3)*pim2(3)
3294 * HADRON CURRENT
3295  fnorm=formom(xmaa,xmom)
3296  brak=0.0
3297  DO 60 jj=1,2
3298  DO 40 i=1,4
3299  IF (jj.EQ.1) THEN
3300  hadcur(i) = fnorm *( vec1(i)*(ampi**2*p1pl-p2pl*(p12-p1pl))
3301  + -pim2(i)*(p2vec1*p1pl-p1vec1*p2pl) +pipl(i)*(p2vec1*p12 -
3302  + p1vec1*(ampi**2+p2pl)) )
3303  ELSE
3304  hadcur(i) = fnorm *( vec2(i)*(ampi**2*p1pl-p2pl*(p12-p1pl))
3305  + -pim2(i)*(p2vec2*p1pl-p1vec2*p2pl) +pipl(i)*(p2vec2*p12 -
3306  + p1vec2*(ampi**2+p2pl)) )
3307  ENDIF
3308  40 CONTINUE
3309 C
3310 * CALCULATE PI-VECTORS: VECTOR AND AXIAL
3311  CALL clvec(hadcur,pn,pivec)
3312  CALL claxi(hadcur,pn,piaks)
3313  CALL clnut(hadcur,brakm,hvm)
3314 * SPIN INDEPENDENT PART OF DECAY DIFF-CROSS-SECT. IN TAU REST FRAME
3315  brak=brak+(gv**2+ga**2)*pt(4)*pivec(4) +2.*gv*ga*pt(4)*piaks(4)
3316  + +2.*(gv**2-ga**2)*amnuta*amtau*brakm
3317  DO 50 i=1,3
3318  hv(i)=hv(i)-(amtau*((gv**2+ga**2)*piaks(i)+2.*gv*ga*pivec(i))
3319  + ) +(gv**2-ga**2)*amnuta*amtau*hvm(i)
3320  50 CONTINUE
3321 C HV IS DEFINED FOR TAU- WITH GAMMA=B+HV*POL
3322  60 CONTINUE
3323  amplit=(gfermi*ccabib)**2*brak/2.
3324 C THE STATISTICAL FACTOR FOR IDENTICAL PI'S WAS CANCELLED WITH
3325 C TWO, FOR TWO MODES OF A1 DECAY NAMELLY PI+PI-PI- AND PI-PI0PI0
3326 C POLARIMETER VECTOR IN TAU REST FRAME
3327  DO 70 i=1,3
3328  hv(i)=-hv(i)/brak
3329  70 CONTINUE
3330 
3331  END
3332 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
3333 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
3334 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
3335 *-- AUTHOR :
3336  SUBROUTINE damppk(MNUM,PT,PN,PIM1,PIM2,PIM3,AMPLIT,HV)
3337 C ----------------------------------------------------------------------
3338 * CALCULATES DIFFERENTIAL CROSS SECTION AND POLARIMETER VECTOR
3339 * FOR TAU DECAY INTO K K PI, K PI PI.
3340 * ALL SPIN EFFECTS IN THE FULL DECAY CHAIN ARE TAKEN INTO ACCOUNT.
3341 * CALCULATIONS DONE IN TAU REST FRAME WITH Z-AXIS ALONG NEUTRINO MOMENT
3342 C MNUM DECAY MODE IDENTIFIER.
3343 C
3344 C CALLED BY : DPHSAA
3345 C ----------------------------------------------------------------------
3346  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
3347  + ,ampiz,ampi,amro,gamro,ama1,gama1
3348  + ,amk,amkz,amkst,gamkst
3349 C
3350  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
3351  + ,ampiz,ampi,amro,gamro,ama1,gama1
3352  + ,amk,amkz,amkst,gamkst
3353  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
3354  REAL*4 gfermi,gv,ga,ccabib,scabib,gamel
3355  REAL hv(4),pt(4),pn(4),pim1(4),pim2(4),pim3(4)
3356  REAL paa(4),vec1(4),vec2(4),vec3(4),vec4(4),vec5(4)
3357  REAL pivec(4),piaks(4),hvm(4)
3358  REAL fnorm(0:7),coef(1:5,0:7)
3359  COMPLEX hadcur(4),form1,form2,form3,form4,form5,uroj
3360  EXTERNAL form1,form2,form3,form4,form5
3361  DATA pi /3.141592653589793238462643/
3362  DATA icont /0/
3363 C
3364  DATA fpi /93.3e-3/
3365  IF (icont.EQ.0) THEN
3366  icont=1
3367  uroj=cmplx(0.0,1.0)
3368  dwapi0=sqrt(2.0)
3369  fnorm(0)=ccabib/fpi
3370  fnorm(1)=ccabib/fpi
3371  fnorm(2)=ccabib/fpi
3372  fnorm(3)=ccabib/fpi
3373  fnorm(4)=scabib/fpi/dwapi0
3374  fnorm(5)=scabib/fpi
3375  fnorm(6)=scabib/fpi
3376  fnorm(7)=ccabib/fpi
3377 C
3378  coef(1,0)= 2.0*sqrt(2.)/3.0
3379  coef(2,0)=-2.0*sqrt(2.)/3.0
3380  coef(3,0)= 0.0
3381  coef(4,0)= fpi
3382  coef(5,0)= 0.0
3383 C
3384  coef(1,1)=-sqrt(2.)/3.0
3385  coef(2,1)= sqrt(2.)/3.0
3386  coef(3,1)= 0.0
3387  coef(4,1)= fpi
3388  coef(5,1)= sqrt(2.)
3389 C
3390  coef(1,2)=-sqrt(2.)/3.0
3391  coef(2,2)= sqrt(2.)/3.0
3392  coef(3,2)= 0.0
3393  coef(4,2)= 0.0
3394  coef(5,2)=-sqrt(2.)
3395 C
3396  coef(1,3)= 0.0
3397  coef(2,3)=-1.0
3398  coef(3,3)= 0.0
3399  coef(4,3)= 0.0
3400  coef(5,3)= 0.0
3401 C
3402  coef(1,4)= 1.0/sqrt(2.)/3.0
3403  coef(2,4)=-1.0/sqrt(2.)/3.0
3404  coef(3,4)= 0.0
3405  coef(4,4)= 0.0
3406  coef(5,4)= 0.0
3407 C
3408  coef(1,5)=-sqrt(2.)/3.0
3409  coef(2,5)= sqrt(2.)/3.0
3410  coef(3,5)= 0.0
3411  coef(4,5)= 0.0
3412  coef(5,5)=-sqrt(2.)
3413 C
3414  coef(1,6)= 0.0
3415  coef(2,6)=-1.0
3416  coef(3,6)= 0.0
3417  coef(4,6)= 0.0
3418  coef(5,6)=-2.0
3419 C
3420  coef(1,7)= 0.0
3421  coef(2,7)= 0.0
3422  coef(3,7)= 0.0
3423  coef(4,7)= 0.0
3424  coef(5,7)=-sqrt(2.0/3.0)
3425 C
3426  ENDIF
3427 C
3428  DO 10 i=1,4
3429  10 paa(i)=pim1(i)+pim2(i)+pim3(i)
3430  xmaa =sqrt(abs(paa(4)**2-paa(3)**2-paa(2)**2-paa(1)**2))
3431  xmro1 =sqrt(abs((pim3(4)+pim2(4))**2-(pim3(1)+pim2(1))**2
3432  + -(pim3(2)+pim2(2))**2-(pim3(3)+pim2(3))**2))
3433  xmro2 =sqrt(abs((pim3(4)+pim1(4))**2-(pim3(1)+pim1(1))**2
3434  + -(pim3(2)+pim1(2))**2-(pim3(3)+pim1(3))**2))
3435  xmro3 =sqrt(abs((pim1(4)+pim2(4))**2-(pim1(1)+pim2(1))**2
3436  + -(pim1(2)+pim2(2))**2-(pim1(3)+pim2(3))**2))
3437 * ELEMENTS OF HADRON CURRENT
3438  prod1 =paa(4)*(pim2(4)-pim3(4))-paa(1)*(pim2(1)-pim3(1))
3439  + -paa(2)*(pim2(2)-pim3(2))-paa(3)*(pim2(3)-pim3(3))
3440  prod2 =paa(4)*(pim3(4)-pim1(4))-paa(1)*(pim3(1)-pim1(1))
3441  + -paa(2)*(pim3(2)-pim1(2))-paa(3)*(pim3(3)-pim1(3))
3442  prod3 =paa(4)*(pim1(4)-pim2(4))-paa(1)*(pim1(1)-pim2(1))
3443  + -paa(2)*(pim1(2)-pim2(2))-paa(3)*(pim1(3)-pim2(3))
3444  DO 20 i=1,4
3445  vec1(i)= pim2(i)-pim3(i) -paa(i)*prod1/xmaa**2
3446  vec2(i)= pim3(i)-pim1(i) -paa(i)*prod2/xmaa**2
3447  vec3(i)= pim1(i)-pim2(i) -paa(i)*prod3/xmaa**2
3448  20 vec4(i)= pim1(i)+pim2(i)+pim3(i)
3449  CALL prod5(pim1,pim2,pim3,vec5)
3450 * HADRON CURRENT
3451 C BE AWARE THAT SIGN OF VEC2 IS OPPOSITE TO SIGN OF VEC1 IN A1 CASE
3452  DO 30 i=1,4
3453  hadcur(i)= cmplx(fnorm(mnum)) * ( cmplx(vec1(i)*coef(1,mnum))*
3454  + form1(mnum,xmaa**2,xmro1**2,xmro2**2)+cmplx(vec2(i)*coef(2,
3455  + mnum))*form2(mnum,xmaa**2,xmro2**2,xmro1**2)+cmplx(vec3(i)*
3456  + coef(3,mnum))*form3(mnum,xmaa**2,xmro3**2,xmro1**2)+(-1.0*uroj)
3457  + * cmplx(vec4(i)*coef(4,mnum))*form4(mnum,xmaa**2,xmro1**2,
3458  + xmro2**2,xmro3**2) +(-1.0)*uroj/4.0/pi**2/fpi**2* cmplx(vec5(i)
3459  + *coef(5,mnum))*form5(mnum,xmaa**2,xmro1**2,xmro2**2))
3460  30 CONTINUE
3461 C
3462 * CALCULATE PI-VECTORS: VECTOR AND AXIAL
3463  CALL clvec(hadcur,pn,pivec)
3464  CALL claxi(hadcur,pn,piaks)
3465  CALL clnut(hadcur,brakm,hvm)
3466 * SPIN INDEPENDENT PART OF DECAY DIFF-CROSS-SECT. IN TAU REST FRAME
3467  brak= (gv**2+ga**2)*pt(4)*pivec(4) +2.*gv*ga*pt(4)*piaks(4)
3468  + +2.*(gv**2-ga**2)*amnuta*amtau*brakm
3469  amplit=(gfermi)**2*brak/2.
3470  IF (mnum.GE.9) THEN
3471  print *, 'MNUM=',mnum
3472  znak=-1.0
3473  xm1=0.0
3474  xm2=0.0
3475  xm3=0.0
3476  DO 40 k=1,4
3477  IF (k.EQ.4) znak=1.0
3478  xm1=znak*pim1(k)**2+xm1
3479  xm2=znak*pim2(k)**2+xm2
3480  xm3=znak*pim3(k)**2+xm3
3481  40 print *, 'PIM1=',pim1(k),'PIM2=',pim2(k),'PIM3=',pim3(k)
3482  print *, 'XM1=',sqrt(xm1),'XM2=',sqrt(xm2),'XM3=',sqrt(xm3)
3483  print *, '************************************************'
3484  ENDIF
3485 C POLARIMETER VECTOR IN TAU REST FRAME
3486  DO 50 i=1,3
3487  hv(i)=-(amtau*((gv**2+ga**2)*piaks(i)+2.*gv*ga*pivec(i)))
3488  + +(gv**2-ga**2)*amnuta*amtau*hvm(i)
3489 C HV IS DEFINED FOR TAU- WITH GAMMA=B+HV*POL
3490  hv(i)=-hv(i)/brak
3491  50 CONTINUE
3492  END
3493 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
3494 *-- AUTHOR :
3495  SUBROUTINE dampry(ITDKRC,XK0DEC,XK,XA,QP,XN,AMPLIT,HV)
3496  IMPLICIT REAL*8 (a-h,o-z)
3497 C ----------------------------------------------------------------------
3498 C IT CALCULATES MATRIX ELEMENT FOR THE
3499 C TAU --> MU(E) NU NUBAR DECAY MODE
3500 C INCLUDING COMPLETE ORDER ALPHA QED CORRECTIONS.
3501 C ----------------------------------------------------------------------
3502  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
3503  * ,ampiz,ampi,amro,gamro,ama1,gama1
3504  * ,amk,amkz,amkst,gamkst
3505 C
3506  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
3507  * ,ampiz,ampi,amro,gamro,ama1,gama1
3508  * ,amk,amkz,amkst,gamkst
3509  REAL*8 hv(4),qp(4),xn(4),xa(4),xk(4)
3510 C
3511  hv(4)=1.d0
3512  ak0=xk0dec*amtau
3513  IF(xk(4).LT.0.1d0*ak0) THEN
3514  amplit=thb(itdkrc,qp,xn,xa,ak0,hv)
3515  ELSE
3516  amplit=sqm2(itdkrc,qp,xn,xa,xk,ak0,hv)
3517  ENDIF
3518  RETURN
3519  END
3520 *CMZ : 1.00/00 09/08/94 17.43.59 BY PIERO ZUCCHELLI
3521 *-- AUTHOR :
3522  FUNCTION dcdmas(IDENT)
3523  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
3524  * ,ampiz,ampi,amro,gamro,ama1,gama1
3525  * ,amk,amkz,amkst,gamkst
3526 C
3527  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
3528  * ,ampiz,ampi,amro,gamro,ama1,gama1
3529  * ,amk,amkz,amkst,gamkst
3530  IF (ident.EQ. 1) THEN
3531  apkmas=ampi
3532  ELSEIF (ident.EQ.-1) THEN
3533  apkmas=ampi
3534  ELSEIF (ident.EQ. 2) THEN
3535  apkmas=ampiz
3536  ELSEIF (ident.EQ.-2) THEN
3537  apkmas=ampiz
3538  ELSEIF (ident.EQ. 3) THEN
3539  apkmas=amk
3540  ELSEIF (ident.EQ.-3) THEN
3541  apkmas=amk
3542  ELSEIF (ident.EQ. 4) THEN
3543  apkmas=amkz
3544  ELSEIF (ident.EQ.-4) THEN
3545  apkmas=amkz
3546  ELSEIF (ident.EQ. 8) THEN
3547  apkmas=0.0001
3548  ELSEIF (ident.EQ.-8) THEN
3549  apkmas=0.0001
3550  ELSEIF (ident.EQ. 9) THEN
3551  apkmas=0.5488
3552  ELSEIF (ident.EQ.-9) THEN
3553  apkmas=0.5488
3554  ELSE
3555  print *, 'STOP IN APKMAS, WRONG IDENT=',ident
3556  stop
3557  ENDIF
3558  dcdmas=apkmas
3559  END
3560 *CMZ : 04/03/97 14.19.02 by Unknown
3561 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
3562 *CMZ : 1.00/00 14/07/94 16.40.21 BY PIERO ZUCCHELLI
3563 *-- AUTHOR :
3564 C **********************************************************************
3565 
3566  FUNCTION dcross(V1,V2)
3567 
3568 C...DIFFERENTIAL CROSS-SECTION DSIGMA/DV1DV2; V1=X, V2=Q2 OR Y OR W2.
3569 C...USED FOR NUMERICAL INTEGRATION ETC.
3570 C...NOTE, NON-ZERO RESULT ONLY FOR REGION DEFINED BY CUTS THROUGH CUT.
3571 
3572  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
3573  COMMON /linter/ pari(40),ewqc(2,2,8),qc(8),zl(2,4),zq(2,8),pq(17)
3574  COMMON /lintrl/ psave(3,4,5),ksave(4),xmin,xmax,ymin,ymax,
3575  +q2min,q2max,w2min,w2max,ilep,inu,ig,iz
3576  COMMON /loptim/ optx(4),opty(4),optq2(4),optw2(4),comfac
3577  COMMON /linteg/ ntot,npass
3578  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
3579  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
3580 
3581 
3582  dcross=0.
3583  ntot=ntot+1
3584 C...VARIABLE V1 IS X, VARIABLE V2 IS EITHER Q**2, Y OR W**2
3585  x=v1
3586  IF(x.LT.xmin.OR.x.GT.xmax) RETURN
3587  s=parl(21)
3588 
3589 c write(*,*) s
3590  pm2=psave(3,2,5)**2
3591  IF(lst(31).EQ.1) THEN
3592  q2=v2
3593  y=q2/(parl(21)*x)
3594  w2=(1.-x)*y*parl(21)+psave(3,2,5)**2
3595  ELSEIF(lst(31).EQ.2) THEN
3596  y=v2
3597  q2=y*x*parl(21)
3598  w2=(1.-x)*y*parl(21)+psave(3,2,5)**2
3599  ELSEIF(lst(31).EQ.3) THEN
3600  w2=v2
3601  y=(w2-psave(3,2,5)**2)/((1.-x)*parl(21))
3602  q2=x*y*parl(21)
3603  ENDIF
3604  q2low=max(q2min,x*ymin*s,(w2min-pm2)*x/(1.-x))
3605  q2upp=min(q2max,x*ymax*s,(w2max-pm2)*x/(1.-x))
3606  ylow=max(ymin,q2min/(s*x),(w2min-pm2)/(s*(1.-x)))
3607  yupp=min(ymax,q2max/(s*x),(w2max-pm2)/(s*(1.-x)))
3608  w2low=max(w2min,(1.-x)*ymin*s+pm2,q2min*(1.-x)/x+pm2)
3609  w2upp=min(w2max,(1.-x)*ymax*s+pm2,q2max*(1.-x)/x+pm2)
3610  IF(q2.LT.q2low.OR.q2.GT.q2upp) RETURN
3611  IF(y.LT.ylow.OR.y.GT.yupp) RETURN
3612  IF(w2.LT.w2low.OR.w2.GT.w2upp) RETURN
3613  lst2=lst(2)
3614  lst(2)=-2
3615 c print*,' calling lepto'
3616  CALL lepto
3617  lst(2)=lst2
3618 c write(*,*) lst(21)
3619  IF(lst(21).NE.0) RETURN
3620  npass=npass+1
3621  dcross=pari(31)*pq(17)*comfac
3622 c write(*,*) dcross
3623  RETURN
3624  END
3625 *CMZ : 1.01/50 20/03/96 12.40.51 by Piero Zucchelli
3626 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
3627 *CMZ : 1.01/08 05/03/95 11.39.27 BY PIERO ZUCCHELLI
3628 *CMZ : 1.01/00 01/09/94 17.30.38 BY PIERO ZUCCHELLI
3629 *CMZ : 1.00/00 09/08/94 18.46.32 BY PIERO ZUCCHELLI
3630 *-- AUTHOR :
3631  SUBROUTINE dectes(KTORY)
3632 C ************************
3633 *KEEP,KEYS.
3634  common/cfread/space(5000)
3635  common/mykeys/ievar,if5cc,ineut,iinte,iferm,iflat,icoun,
3636  & refix,imudo,ikat1,ikat2,ikat3,ikat4,ikat5,ikat6,
3637  & inevt,ijak1,ijak2,iitdk,rptau,rxk0d,ntgr,idimuon,iglu,
3638  & iqden,lome(2),ifiles,iccha,iseed,idsubs,ionem,ehac,ipsel,
3639  & ihist
3640 
3641 
3642 *KEND.
3643  REAL pol(4)
3644  DOUBLE PRECISION hh(4)
3645 C SWITCHES FOR TAUOLA;
3646  COMMON / jaki / jak1,jak2,jakp,jakm,ktom
3647  COMMON / idfc / idff
3648 C I/O UNITS NUMBERS
3649  COMMON / inout / inut,iout
3650 C LUND TYPE IDENTIFIER FOR A1
3651  COMMON / idpart / ia1
3652 C /PTAU/ IS USED IN ROUTINE TRALO4
3653  COMMON /ptau/ ptau
3654  COMMON / taurad / xk0dec,itdkrc
3655  REAL*8 xk0dec
3656  COMMON /testa1/ keya1
3657 C SPECIAL SWITCH FOR TESTS OF DGAMMA/DQ**2 IN A1 DECAY
3658 C KEYA1=1 CONSTANT WIDTH OF A1 AND RHO
3659 C KEYA1=2 FREE CHOICE OF RHO PROPAGATOR (DEFINED IN FUNCTION FPIK)
3660 C AND FREE CHOICE OF A1 MASS AND WIDTH. FUNCTION G(Q**2)
3661 C (SEE FORMULA 3.48 IN COMP. PHYS. COMM. 64 (1991) 275)
3662 C HARD CODED BOTH IN MONTE CARLO AND IN TESTING DISTRIBUTION.
3663 C KEYA1=3 FUNCTION G(Q**2) HARDCODED IN THE MONTE CARLO
3664 C (IT IS TIMY TO CALCULATE!), BUT APPROPRIATELY ADJUSTED IN
3665 C TESTING DISTRIBUTION.
3666 C-----------------------------------------------------------------------
3667 C INITIALIZATION
3668 C-----------------------------------------------------------------------
3669 C======================================
3670  ninp=inut
3671  nout=iout
3672 10000 FORMAT(a80)
3673 10100 FORMAT(8i2)
3674 10200 FORMAT(i10)
3675 10300 FORMAT(f10.0)
3676  IF (ktory.EQ.1) THEN
3677 * READ( NINP,3000) TESTIT
3678 * WRITE(NOUT,3000) TESTIT
3679 * READ( NINP,3001) KAT1,KAT2,KAT3,KAT4,KAT5,KAT6
3680 * READ( NINP,3002) NEVT,JAK1,JAK2,ITDKRC
3681 * READ( NINP,3003) PTAU,XK0DEC
3682 
3683  kat1=ikat1
3684  kat2=ikat2
3685  kat3=ikat3
3686  kat4=ikat4
3687  kat5=ikat5
3688  kat6=ikat6
3689  nevt=inevt
3690  jak1=ijak1
3691  jak2=ijak2
3692  itdkrc=iitdk
3693  ptau=rptau
3694  xk0dec=rxk0d
3695 
3696 
3697 
3698 
3699  ENDIF
3700 C======================================
3701 C CONTROL OUTPUT
3702  WRITE(nout,'(6A6/6I6)')
3703  + 'KAT1','KAT2','KAT3','KAT4','KAT5','KAT6',
3704  + kat1 , kat2 , kat3 , kat4 , kat5 , kat6
3705  WRITE(nout,'(4A12/4I12)')
3706  + 'NEVT','JAK1','JAK2','ITDKRC',
3707  + nevt, jak1 , jak2 , itdkrc
3708  WRITE(nout,'(2A12/2F12.6)')
3709  + 'PTAU','XK0DEC',
3710  + ptau , xk0dec
3711 C======================================
3712  jak=0
3713 C JAK1=5
3714 C JAK2=5
3715 C LUND IDENTIFIER (FOR TAU+) -15
3716  IF (ktory.EQ.1) THEN
3717  idff=-15
3718  ELSE
3719  idff= 15
3720  ENDIF
3721 C KTO=1 DENOTES TAU DEFINED BY IDFF (I.E. TAU+)
3722 C KTO=2 DENOTES THE OPPOSITE (I.E. TAU-)
3723 *PZ PATCH
3724  idff=-15
3725 
3726  kto=2
3727  IF (kto.NE.2) THEN
3728  print *, 'FOR THE SAKE OF THESE TESTS KTO HAS TO BE 2'
3729  print *, 'TO CHANGE TAU- TO TAU+ CHANGE IDFF FROM -15 TO 15'
3730  stop
3731  ENDIF
3732 C TAU POLARIZATION IN ITS RESTFRAME;
3733  pol(1)=0.
3734  pol(2)=0.
3735  pol(3)=.9
3736 C TAU MOMENTUM IN GEV;
3737 C PTAU=CMSENE/2.D0
3738 C NUMBER OF EVENTS TO BE GENERATED;
3739  nevtes=0
3740 C NEVTES=NEVT
3741  print *, 'NEVTES= ',nevtes
3742  WRITE(iout,10800) keya1
3743 C
3744  IF (ktory.EQ.1) THEN
3745  WRITE(iout,10400) jak,idff,pol(3),ptau
3746  ELSE
3747  WRITE(iout,10700) jak,idff,pol(3),ptau
3748  ENDIF
3749 C INITIALISATION OF TAU DECAY PACKAGE TAUOLA
3750 C ******************************************
3751  CALL inimas
3752  CALL initdk
3753 
3754 
3755  CALL iniphy(0.1d0)
3756  IF (ktory.EQ.1) THEN
3757  CALL dexay(-1,pol)
3758  ELSE
3759  CALL dekay(-1,hh)
3760  ENDIF
3761 
3762  RETURN
3763 10400 FORMAT(//4(/1x,15(5h=====))
3764  + /,' ', 19x,' TEST OF RAD. CORR IN ELECTRON DECAY ',9x,1h ,
3765  + /,' ', 19x,' TESTS OF TAU DECAY ROUTINES ',9x,1h ,
3766  + /,' ', 19x,' INTERFACE OF THE KORAL-Z TYPE ',9x,1h ,
3767  + 2(/,1x,15(5h=====)),
3768  + /,5x ,'JAK =',i7 ,' KEY DEFINING DECAY TYPE ',9x,1h ,
3769  + /,5x ,'IDFF =',i7 ,' LUND IDENTIFIER FOR FIRST TAU ',9x,1h ,
3770  + /,5x ,'POL(3)=',f7.2,' THIRD COMPONENT OF TAU POLARIZ. ',9x,1h ,
3771  + /,5x ,'PTAU =',f7.2,' THIRD COMPONENT OF TAU MOM. GEV ',9x,1h ,
3772  + 2(/,1x,15(5h=====))/)
3773 10500 FORMAT(///1x, '===== EVENT NO.',i4,1x,5h=====)
3774 10600 FORMAT(5x,'POLARIMETRIC VECTOR: ',
3775  + 7x,'HH(1)',7x,'HH(2)',7x,'HH(3)',7x,'HH(4)',
3776  + /, 5x,' ', 4(1x,f11.8) )
3777 10700 FORMAT(//4(/1x,15(5h=====))
3778  + /,' ', 19x,' TEST OF RAD. CORR IN ELECTRON DECAY ',9x,1h ,
3779  + /,' ', 19x,' TESTS OF TAU DECAY ROUTINES ',9x,1h ,
3780  + /,' ', 19x,' INTERFACE OF THE KORAL-B TYPE ',9x,1h ,
3781  + 2(/,1x,15(5h=====)),
3782  + /,5x ,'JAK =',i7 ,' KEY DEFINING DECAY TYPE ',9x,1h ,
3783  + /,5x ,'IDFF =',i7 ,' LUND IDENTIFIER FOR FIRST TAU ',9x,1h ,
3784  + /,5x ,'POL(3)=',f7.2,' THIRD COMPONENT OF TAU POLARIZ. ',9x,1h ,
3785  + /,5x ,'PTAU =',f7.2,' THIRD COMPONENT OF TAU MOM. GEV ',9x,1h ,
3786  + 2(/,1x,15(5h=====))/)
3787 10800 FORMAT(///1x, '===== TYPE OF CURRENT',i4,1x,5h=====)
3788  END
3789 *CMZ : 1.01/50 22/05/96 18.06.08 by Piero Zucchelli
3790 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
3791 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
3792 *CMZ : 1.00/00 10/08/94 16.29.39 BY PIERO ZUCCHELLI
3793 *-- AUTHOR :
3794  SUBROUTINE dekay(KTO,HX)
3795 C ***********************
3796 C THIS DEKAY IS IN SPIRIT OF THE 'DECAY' WHICH
3797 C WAS INCLUDED IN KORAL-B PROGRAM, COMP. PHYS. COMMUN.
3798 C VOL. 36 (1985) 191, SEE COMMENTS ON GENERAL PHILOSOPHY THERE.
3799 C KTO=0 INITIALISATION (OBLIGATORY)
3800 C KTO=1,11 DENOTES TAU+ AND KTO=2,12 TAU-
3801 C DEKAY(1,H) AND DEKAY(2,H) IS CALLED INTERNALLY BY MC GENERATOR.
3802 C H DENOTES THE POLARIMETRIC VECTOR, USED BY THE HOST PROGRAM FOR
3803 C CALCULATION OF THE SPIN WEIGHT.
3804 C USER MAY OPTIONALLY CALL DEKAY(11,H) DEKAY(12,H) IN ORDER
3805 C TO TRANSFORM DECAY PRODUCTS TO CMS AND WRITE LUND RECORD IN /LUJETS/.
3806 C KTO=100, PRINT FINAL REPORT (OPTIONAL).
3807 C DECAY MODES:
3808 C JAK=1 ELECTRON DECAY
3809 C JAK=2 MU DECAY
3810 C JAK=3 PI DECAY
3811 C JAK=4 RHO DECAY
3812 C JAK=5 A1 DECAY
3813 C JAK=6 K DECAY
3814 C JAK=7 K* DECAY
3815 C JAK=8 NPI DECAY
3816 C JAK=0 INCLUSIVE: JAK=1,2,3,4,5,6,7,8
3817  REAL h(4)
3818  REAL*8 hx(4)
3819  COMMON / jaki / jak1,jak2,jakp,jakm,ktom
3820  COMMON / idfc / idf
3821  COMMON / taubmc / gampmc(30),gamper(30),nevdec(30)
3822  REAL*4 gampmc ,gamper
3823  parameter(nmode=15,nm1=0,nm2=1,nm3=8,nm4=2,nm5=1,nm6=3)
3824  COMMON / mdecomp /idffin(9,nmode),mulpik(nmode)
3825  + ,names
3826  CHARACTER names(nmode)*31
3827  COMMON / inout / inut,iout
3828  REAL pdum1(4),pdum2(4),pdum3(4),pdum4(4),pdum5(4),hdum(4)
3829  REAL pdumx(4,9)
3830  DATA iwarm/0/
3831  ktom=kto
3832  IF(kto.EQ.-1) THEN
3833 C ==================
3834 C INITIALISATION OR REINITIALISATION
3835  ktom=1
3836  IF (iwarm.EQ.1) x=5/(iwarm-1)
3837  iwarm=1
3838  WRITE(iout,10000) jak1,jak2
3839  nevtot=0
3840  nev1=0
3841  nev2=0
3842  IF(jak1.NE.-1.OR.jak2.NE.-1) THEN
3843  CALL dadmel(-1,idum,hdum,pdum1,pdum2,pdum3,pdum4,pdum5)
3844  CALL dadmmu(-1,idum,hdum,pdum1,pdum2,pdum3,pdum4,pdum5)
3845  CALL dadmpi(-1,idum,pdum,pdum1,pdum2)
3846  CALL dadmro(-1,idum,hdum,pdum1,pdum2,pdum3,pdum4)
3847  CALL dadmaa(-1,idum,hdum,pdum1,pdum2,pdum3,pdum4,pdum5,jdum)
3848  CALL dadmkk(-1,idum,pdum,pdum1,pdum2)
3849  CALL dadmks(-1,idum,hdum,pdum1,pdum2,pdum3,pdum4,jdum)
3850  CALL dadnew(-1,idum,hdum,pdum1,pdum2,pdumx,jdum)
3851  ENDIF
3852  DO 10 i=1,30
3853  nevdec(i)=0
3854  gampmc(i)=0
3855  10 gamper(i)=0
3856  ELSEIF(kto.EQ.1) THEN
3857 C =====================
3858 C DECAY OF TAU+ IN THE TAU REST FRAME
3859  nevtot=nevtot+1
3860  IF(iwarm.EQ.0) goto 30
3861  isgn= idf/iabs(idf)
3862  CALL dekay1(0,h,isgn)
3863  ELSEIF(kto.EQ.2) THEN
3864 C =================================
3865 C DECAY OF TAU- IN THE TAU REST FRAME
3866  nevtot=nevtot+1
3867  IF(iwarm.EQ.0) goto 30
3868  isgn=-idf/iabs(idf)
3869  CALL dekay2(0,h,isgn)
3870  ELSEIF(kto.EQ.11) THEN
3871 C ======================
3872 C REST OF DECAY PROCEDURE FOR ACCEPTED TAU+ DECAY
3873  nev1=nev1+1
3874  isgn= idf/iabs(idf)
3875  CALL dekay1(1,h,isgn)
3876  ELSEIF(kto.EQ.12) THEN
3877 C ======================
3878 C REST OF DECAY PROCEDURE FOR ACCEPTED TAU- DECAY
3879  nev2=nev2+1
3880  isgn=-idf/iabs(idf)
3881  CALL dekay2(1,h,isgn)
3882  ELSEIF(kto.EQ.100) THEN
3883 C =======================
3884  IF(jak1.NE.-1.OR.jak2.NE.-1) THEN
3885  CALL dadmel( 1,idum,hdum,pdum1,pdum2,pdum3,pdum4,pdum5)
3886  CALL dadmmu( 1,idum,hdum,pdum1,pdum2,pdum3,pdum4,pdum5)
3887  CALL dadmpi( 1,idum,pdum,pdum1,pdum2)
3888  CALL dadmro( 1,idum,hdum,pdum1,pdum2,pdum3,pdum4)
3889  CALL dadmaa( 1,idum,hdum,pdum1,pdum2,pdum3,pdum4,pdum5,jdum)
3890  CALL dadmkk( 1,idum,pdum,pdum1,pdum2)
3891  CALL dadmks( 1,idum,hdum,pdum1,pdum2,pdum3,pdum4,jdum)
3892  CALL dadnew( 1,idum,hdum,pdum1,pdum2,pdumx,jdum)
3893  WRITE(iout,10100) nev1,nev2,nevtot
3894  WRITE(iout,10200) (nevdec(i),gampmc(i),gamper(i),i= 1,7)
3895  WRITE(iout,10300) (nevdec(i),gampmc(i),gamper(i),names(i-7),
3896  + i=8,7+nmode)
3897  WRITE(iout,10400)
3898  ENDIF
3899  ELSE
3900 C ====
3901  goto 40
3902  ENDIF
3903 C =====
3904  DO 20 k=1,4
3905  20 hx(k)=h(k)
3906  RETURN
3907 
3908 10000 FORMAT(///1x,15(5h*****)
3909  + /,' *', 25x,'*****TAUOLA LIBRARY: VERSION 2.5 ******',9x,1h*,
3910  + /,' *', 25x,'***********JUNE 1994***************',9x,1h*,
3911  + /,' *', 25x,'**AUTHORS: S.JADACH, Z.WAS*************',9x,1h*,
3912  + /,' *', 25x,'**R. DECKER, M. JEZABEK, J.H.KUEHN*****',9x,1h*,
3913  + /,' *', 25x,'**AVAILABLE FROM: WASM AT CERNVM ******',9x,1h*,
3914  + /,' *', 25x,'***** PUBLISHED IN COMP. PHYS. COMM.***',9x,1h*,
3915  + /,' *', 25x,'*******CERN-TH-5856 SEPTEMBER 1990*****',9x,1h*,
3916  + /,' *', 25x,'*******CERN-TH-6195 SEPTEMBER 1991*****',9x,1h*,
3917  + /,' *', 25x,'*******CERN TH-6793 NOVEMBER 1992*****',9x,1h*,
3918  + /,' *', 25x,'**5 OR MORE PI DEC.: PRECISION LIMITED ',9x,1h*,
3919  + /,' *', 25x,'****DEKAY ROUTINE: INITIALIZATION******',9x,1h*,
3920  + /,' *',i20 ,5x,'JAK1 = DECAY MODE TAU+ ',9x,1h*,
3921  + /,' *',i20 ,5x,'JAK2 = DECAY MODE TAU- ',9x,1h*,
3922  + /,1x,15(5h*****)/)
3923 10100 FORMAT(///1x,15(5h*****)
3924  + /,' *', 25x,'*****TAUOLA LIBRARY: VERSION 2.5 ******',9x,1h*,
3925  + /,' *', 25x,'***********JUNE 1994***************',9x,1h*,
3926  + /,' *', 25x,'**AUTHORS: S.JADACH, Z.WAS*************',9x,1h*,
3927  + /,' *', 25x,'**R. DECKER, M. JEZABEK, J.H.KUEHN*****',9x,1h*,
3928  + /,' *', 25x,'**AVAILABLE FROM: WASM AT CERNVM ******',9x,1h*,
3929  + /,' *', 25x,'***** PUBLISHED IN COMP. PHYS. COMM.***',9x,1h*,
3930  + /,' *', 25x,'*******CERN-TH-5856 SEPTEMBER 1990*****',9x,1h*,
3931  + /,' *', 25x,'*******CERN-TH-6195 SEPTEMBER 1991*****',9x,1h*,
3932  + /,' *', 25x,'*******CERN TH-6793 NOVEMBER 1992*****',9x,1h*,
3933  + /,' *', 25x,'*****DEKAY ROUTINE: FINAL REPORT*******',9x,1h*,
3934  + /,' *',i20 ,5x,'NEV1 = NO. OF TAU+ DECS. ACCEPTED ',9x,1h*,
3935  + /,' *',i20 ,5x,'NEV2 = NO. OF TAU- DECS. ACCEPTED ',9x,1h*,
3936  + /,' *',i20 ,5x,'NEVTOT = SUM ',9x,1h*,
3937  + /,' *',' NOEVTS ',
3938  + ' PART.WIDTH ERROR ROUTINE DECAY MODE ',9x,1h*)
3939 10200 FORMAT(1x,'*'
3940  + ,i10,2f12.7 ,' DADMEL ELECTRON ',9x,1h*
3941  + /,' *',i10,2f12.7 ,' DADMMU MUON ',9x,1h*
3942  + /,' *',i10,2f12.7 ,' DADMPI PION ',9x,1h*
3943  + /,' *',i10,2f12.7, ' DADMRO RHO (->2PI) ',9x,1h*
3944  + /,' *',i10,2f12.7, ' DADMAA A1 (->3PI) ',9x,1h*
3945  + /,' *',i10,2f12.7, ' DADMKK KAON ',9x,1h*
3946  + /,' *',i10,2f12.7, ' DADMKS K* ',9x,1h*)
3947 10300 FORMAT(1x,'*'
3948  + ,i10,2f12.7,a31 ,8x,1h*)
3949 10400 FORMAT(1x,'*'
3950  + ,20x,'THE ERROR IS RELATIVE AND PART.WIDTH ',10x,1h*
3951  + /,' *',20x,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',10x,1h*
3952  + /,1x,15(5h*****)/)
3953  30 print 10500
3954 10500 FORMAT(' ----- DEKAY: LACK OF INITIALISATION')
3955  stop
3956  40 print 10600
3957 10600 FORMAT(' ----- DEKAY: WRONG VALUE OF KTO ')
3958  stop
3959  END
3960 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
3961 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
3962 *CMZ : 1.00/00 10/08/94 16.29.39 BY PIERO ZUCCHELLI
3963 *-- AUTHOR :
3964  SUBROUTINE dekay1(IMOD,HH,ISGN)
3965 C *******************************
3966 C THIS ROUTINE SIMULATES TAU+ DECAY
3967  COMMON / decp4 / pp1(4),pp2(4),kf1,kf2
3968  COMMON / jaki / jak1,jak2,jakp,jakm,ktom
3969  COMMON / taubmc / gampmc(30),gamper(30),nevdec(30)
3970  REAL*4 gampmc ,gamper
3971  REAL hh(4)
3972  REAL hv(4),pnu(4),ppi(4)
3973  REAL pwb(4),pmu(4),pnm(4)
3974  REAL prho(4),pic(4),piz(4)
3975  REAL paa(4),pim1(4),pim2(4),pipl(4)
3976  REAL pkk(4),pks(4)
3977  REAL pnpi(4,9)
3978  REAL phot(4)
3979  REAL pdum(4)
3980  DATA nev,nprin/0,10/
3981  kto=1
3982  IF(jak1.EQ.-1) RETURN
3983  imd=imod
3984  IF(imd.EQ.0) THEN
3985 C =================
3986  jak=jak1
3987  IF(jak1.EQ.0) CALL jaker(jak)
3988  IF(jak.EQ.1) THEN
3989  CALL dadmel(0, isgn,hv,pnu,pwb,pmu,pnm,phot)
3990  ELSEIF(jak.EQ.2) THEN
3991  CALL dadmmu(0, isgn,hv,pnu,pwb,pmu,pnm,phot)
3992  ELSEIF(jak.EQ.3) THEN
3993  CALL dadmpi(0, isgn,hv,ppi,pnu)
3994  ELSEIF(jak.EQ.4) THEN
3995  CALL dadmro(0, isgn,hv,pnu,prho,pic,piz)
3996  ELSEIF(jak.EQ.5) THEN
3997  CALL dadmaa(0, isgn,hv,pnu,paa,pim1,pim2,pipl,jaa)
3998  ELSEIF(jak.EQ.6) THEN
3999  CALL dadmkk(0, isgn,hv,pkk,pnu)
4000  ELSEIF(jak.EQ.7) THEN
4001  CALL dadmks(0, isgn,hv,pnu,pks ,pkk,ppi,jkst)
4002  ELSE
4003  CALL dadnew(0, isgn,hv,pnu,pwb,pnpi,jak-7)
4004  ENDIF
4005  DO 10 i=1,3
4006  10 hh(i)=hv(i)
4007  hh(4)=1.0
4008 
4009  ELSEIF(imd.EQ.1) THEN
4010 C =====================
4011  nev=nev+1
4012  IF (jak.LT.31) THEN
4013  nevdec(jak)=nevdec(jak)+1
4014  ENDIF
4015  DO 20 i=1,4
4016  20 pdum(i)=.0
4017  IF(jak.EQ.1) THEN
4018  CALL dwluel(1,isgn,pnu,pwb,pmu,pnm)
4019  CALL dwrph(ktom,phot)
4020  DO 30 i=1,4
4021  30 pp1(i)=pmu(i)
4022 
4023  ELSEIF(jak.EQ.2) THEN
4024  CALL dwlumu(1,isgn,pnu,pwb,pmu,pnm)
4025  CALL dwrph(ktom,phot)
4026  DO 40 i=1,4
4027  40 pp1(i)=pmu(i)
4028 
4029  ELSEIF(jak.EQ.3) THEN
4030  CALL dwlupi(1,isgn,ppi,pnu)
4031  DO 50 i=1,4
4032  50 pp1(i)=ppi(i)
4033 
4034  ELSEIF(jak.EQ.4) THEN
4035  CALL dwluro(1,isgn,pnu,prho,pic,piz)
4036  DO 60 i=1,4
4037  60 pp1(i)=prho(i)
4038 
4039  ELSEIF(jak.EQ.5) THEN
4040  CALL dwluaa(1,isgn,pnu,paa,pim1,pim2,pipl,jaa)
4041  DO 70 i=1,4
4042  70 pp1(i)=paa(i)
4043  ELSEIF(jak.EQ.6) THEN
4044  CALL dwlukk(1,isgn,pkk,pnu)
4045  DO 80 i=1,4
4046  80 pp1(i)=pkk(i)
4047  ELSEIF(jak.EQ.7) THEN
4048  CALL dwluks(1,isgn,pnu,pks,pkk,ppi,jkst)
4049  DO 90 i=1,4
4050  90 pp1(i)=pks(i)
4051  ELSE
4052 CAM MULTIPION DECAY
4053  CALL dwlnew(1,isgn,pnu,pwb,pnpi,jak)
4054  DO 100 i=1,4
4055  100 pp1(i)=pwb(i)
4056  ENDIF
4057 
4058  ENDIF
4059 C =====
4060  END
4061 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
4062 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
4063 *CMZ : 1.00/00 10/08/94 16.29.39 BY PIERO ZUCCHELLI
4064 *-- AUTHOR :
4065  SUBROUTINE dekay2(IMOD,HH,ISGN)
4066 C *******************************
4067 C THIS ROUTINE SIMULATES TAU- DECAY
4068  COMMON / decp4 / pp1(4),pp2(4),kf1,kf2
4069  COMMON / jaki / jak1,jak2,jakp,jakm,ktom
4070  COMMON / taubmc / gampmc(30),gamper(30),nevdec(30)
4071  REAL*4 gampmc ,gamper
4072  REAL hh(4)
4073  REAL hv(4),pnu(4),ppi(4)
4074  REAL pwb(4),pmu(4),pnm(4)
4075  REAL prho(4),pic(4),piz(4)
4076  REAL paa(4),pim1(4),pim2(4),pipl(4)
4077  REAL pkk(4),pks(4)
4078  REAL pnpi(4,9)
4079  REAL phot(4)
4080  REAL pdum(4)
4081  DATA nev,nprin/0,10/
4082  kto=2
4083  IF(jak2.EQ.-1) RETURN
4084  imd=imod
4085  IF(imd.EQ.0) THEN
4086 C =================
4087  jak=jak2
4088  IF(jak2.EQ.0) CALL jaker(jak)
4089  IF(jak.EQ.1) THEN
4090  CALL dadmel(0, isgn,hv,pnu,pwb,pmu,pnm,phot)
4091  ELSEIF(jak.EQ.2) THEN
4092  CALL dadmmu(0, isgn,hv,pnu,pwb,pmu,pnm,phot)
4093  ELSEIF(jak.EQ.3) THEN
4094  CALL dadmpi(0, isgn,hv,ppi,pnu)
4095  ELSEIF(jak.EQ.4) THEN
4096  CALL dadmro(0, isgn,hv,pnu,prho,pic,piz)
4097  ELSEIF(jak.EQ.5) THEN
4098  CALL dadmaa(0, isgn,hv,pnu,paa,pim1,pim2,pipl,jaa)
4099  ELSEIF(jak.EQ.6) THEN
4100  CALL dadmkk(0, isgn,hv,pkk,pnu)
4101  ELSEIF(jak.EQ.7) THEN
4102  CALL dadmks(0, isgn,hv,pnu,pks ,pkk,ppi,jkst)
4103  ELSE
4104  CALL dadnew(0, isgn,hv,pnu,pwb,pnpi,jak-7)
4105  ENDIF
4106  DO 10 i=1,3
4107  10 hh(i)=hv(i)
4108  hh(4)=1.0
4109  ELSEIF(imd.EQ.1) THEN
4110 C =====================
4111  nev=nev+1
4112  IF (jak.LT.31) THEN
4113  nevdec(jak)=nevdec(jak)+1
4114  ENDIF
4115  DO 20 i=1,4
4116  20 pdum(i)=.0
4117  IF(jak.EQ.1) THEN
4118  CALL dwluel(2,isgn,pnu,pwb,pmu,pnm)
4119  CALL dwrph(ktom,phot)
4120  DO 30 i=1,4
4121  30 pp2(i)=pmu(i)
4122 
4123  ELSEIF(jak.EQ.2) THEN
4124  CALL dwlumu(2,isgn,pnu,pwb,pmu,pnm)
4125  CALL dwrph(ktom,phot)
4126  DO 40 i=1,4
4127  40 pp2(i)=pmu(i)
4128 
4129  ELSEIF(jak.EQ.3) THEN
4130  CALL dwlupi(2,isgn,ppi,pnu)
4131  DO 50 i=1,4
4132  50 pp2(i)=ppi(i)
4133 
4134  ELSEIF(jak.EQ.4) THEN
4135  CALL dwluro(2,isgn,pnu,prho,pic,piz)
4136  DO 60 i=1,4
4137  60 pp2(i)=prho(i)
4138 
4139  ELSEIF(jak.EQ.5) THEN
4140  CALL dwluaa(2,isgn,pnu,paa,pim1,pim2,pipl,jaa)
4141  DO 70 i=1,4
4142  70 pp2(i)=paa(i)
4143  ELSEIF(jak.EQ.6) THEN
4144  CALL dwlukk(2,isgn,pkk,pnu)
4145  DO 80 i=1,4
4146  80 pp1(i)=pkk(i)
4147  ELSEIF(jak.EQ.7) THEN
4148  CALL dwluks(2,isgn,pnu,pks,pkk,ppi,jkst)
4149  DO 90 i=1,4
4150  90 pp1(i)=pks(i)
4151  ELSE
4152 CAM MULTIPION DECAY
4153  CALL dwlnew(2,isgn,pnu,pwb,pnpi,jak)
4154  DO 100 i=1,4
4155  100 pp1(i)=pwb(i)
4156  ENDIF
4157 C
4158  ENDIF
4159 C =====
4160  END
4161 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
4162 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
4163 *-- AUTHOR :
4164  SUBROUTINE dexaa(MODE,ISGN,POL,PNU,PAA,PIM1,PIM2,PIPL,JAA)
4165 C ----------------------------------------------------------------------
4166 * THIS SIMULATES TAU DECAY IN TAU REST FRAME
4167 * INTO NU A1, NEXT A1 DECAYS INTO RHO PI AND FINALLY RHO INTO PI PI.
4168 * OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
4169 * PAA A1
4170 * PIM1 PION MINUS (OR PI0) 1 (FOR TAU MINUS)
4171 * PIM2 PION MINUS (OR PI0) 2
4172 * PIPL PION PLUS (OR PI-)
4173 * (PIPL,PIM1) FORM A RHO
4174 C ----------------------------------------------------------------------
4175  COMMON / inout / inut,iout
4176  REAL pol(4),hv(4),paa(4),pnu(4),pim1(4),pim2(4),pipl(4)
4177  DATA iwarm/0/
4178 C
4179  IF(mode.EQ.-1) THEN
4180 C ===================
4181  iwarm=1
4182  CALL dadmaa( -1,isgn,hv,pnu,paa,pim1,pim2,pipl,jaa)
4183 CC CALL HBOOK1(816,'WEIGHT DISTRIBUTION DEXAA $',100,-2.,2.)
4184 C
4185  ELSEIF(mode.EQ. 0) THEN
4186 * =======================
4187  10 CONTINUE
4188  IF(iwarm.EQ.0) goto 20
4189  CALL dadmaa( 0,isgn,hv,pnu,paa,pim1,pim2,pipl,jaa)
4190  wt=(1+pol(1)*hv(1)+pol(2)*hv(2)+pol(3)*hv(3))/2.
4191 CC CALL HFILL(816,WT)
4192  CALL ranmar(rn,1)
4193  IF(rn.GT.wt) goto 10
4194 C
4195  ELSEIF(mode.EQ. 1) THEN
4196 * =======================
4197  CALL dadmaa( 1,isgn,hv,pnu,paa,pim1,pim2,pipl,jaa)
4198 CC CALL HPRINT(816)
4199  ENDIF
4200 C =====
4201  RETURN
4202  20 WRITE(iout, 10000)
4203 10000 FORMAT(' ----- DEXAA: LACK OF INITIALISATION')
4204  stop
4205  END
4206 *CMZ : 1.01/50 22/05/96 18.06.08 by Piero Zucchelli
4207 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
4208 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
4209 *CMZ : 1.00/00 10/08/94 16.29.39 BY PIERO ZUCCHELLI
4210 *-- AUTHOR :
4211  SUBROUTINE dexay(KTO,POL)
4212 C ----------------------------------------------------------------------
4213 C THIS 'DEXAY' IS A ROUTINE WHICH GENERATES DECAY OF THE SINGLE
4214 C POLARIZED TAU, POL IS A POLARIZATION VECTOR (NOT A POLARIMETER
4215 C VECTOR AS IN DEKAY) OF THE TAU AND IT IS AN INPUT PARAMETER.
4216 C KTO=0 INITIALISATION (OBLIGATORY)
4217 C KTO=1 DENOTES TAU+ AND KTO=2 TAU-
4218 C DEXAY(1,POL) AND DEXAY(2,POL) ARE CALLED INTERNALLY BY MC GENERATOR.
4219 C DECAY PRODUCTS ARE TRANSFORMED READILY
4220 C TO CMS AND WRITEN IN THE LUND RECORD IN /LUJETS/
4221 C KTO=100, PRINT FINAL REPORT (OPTIONAL).
4222 C
4223 C CALLED BY : KORALZ
4224 C ----------------------------------------------------------------------
4225  COMMON / taubmc / gampmc(30),gamper(30),nevdec(30)
4226  REAL*4 gampmc ,gamper
4227  COMMON / jaki / jak1,jak2,jakp,jakm,ktom
4228  COMMON / idfc / idff
4229  parameter(nmode=15,nm1=0,nm2=1,nm3=8,nm4=2,nm5=1,nm6=3)
4230  COMMON / mdecomp /idffin(9,nmode),mulpik(nmode)
4231  + ,names
4232  CHARACTER names(nmode)*31
4233  COMMON / inout / inut,iout
4234  REAL pol(4)
4235  REAL pdum1(4),pdum2(4),pdum3(4),pdum4(4),pdum5(4)
4236  REAL pdum(4)
4237  REAL pdumi(4,9)
4238  DATA iwarm/0/
4239  ktom=kto
4240 C
4241  IF(kto.EQ.-1) THEN
4242 C ==================
4243 C INITIALISATION OR REINITIALISATION
4244  iwarm=1
4245  WRITE(iout, 10000) jak1,jak2
4246  nevtot=0
4247  nev1=0
4248  nev2=0
4249  IF(jak1.NE.-1.OR.jak2.NE.-1) THEN
4250  CALL dexel(-1,idum,pdum,pdum1,pdum2,pdum3,pdum4,pdum5)
4251  CALL dexmu(-1,idum,pdum,pdum1,pdum2,pdum3,pdum4,pdum5)
4252  CALL dexpi(-1,idum,pdum,pdum1,pdum2)
4253  CALL dexro(-1,idum,pdum,pdum1,pdum2,pdum3,pdum4)
4254  CALL dexaa(-1,idum,pdum,pdum1,pdum2,pdum3,pdum4,pdum5,idum)
4255  CALL dexkk(-1,idum,pdum,pdum1,pdum2)
4256  CALL dexks(-1,idum,pdum,pdum1,pdum2,pdum3,pdum4,idum)
4257  CALL dexnew(-1,idum,pdum,pdum1,pdum2,pdumi,idum)
4258  ENDIF
4259  DO 10 i=1,30
4260  nevdec(i)=0
4261  gampmc(i)=0
4262  10 gamper(i)=0
4263  ELSEIF(kto.EQ.1) THEN
4264 C =====================
4265 C DECAY OF TAU+ IN THE TAU REST FRAME
4266  nevtot=nevtot+1
4267  nev1=nev1+1
4268  IF(iwarm.EQ.0) goto 20
4269  isgn=idff/iabs(idff)
4270 CAM CALL DEXAY1(POL,ISGN)
4271  CALL dexay1(kto,jak1,jakp,pol,isgn)
4272  ELSEIF(kto.EQ.2) THEN
4273 C =================================
4274 C DECAY OF TAU- IN THE TAU REST FRAME
4275  nevtot=nevtot+1
4276  nev2=nev2+1
4277  IF(iwarm.EQ.0) goto 20
4278  isgn=-idff/iabs(idff)
4279 CAM CALL DEXAY2(POL,ISGN)
4280  CALL dexay1(kto,jak2,jakm,pol,isgn)
4281  ELSEIF(kto.EQ.100) THEN
4282 C =======================
4283  IF(jak1.NE.-1.OR.jak2.NE.-1) THEN
4284  CALL dexel( 1,idum,pdum,pdum1,pdum2,pdum3,pdum4,pdum5)
4285  CALL dexmu( 1,idum,pdum,pdum1,pdum2,pdum3,pdum4,pdum5)
4286  CALL dexpi( 1,idum,pdum,pdum1,pdum2)
4287  CALL dexro( 1,idum,pdum,pdum1,pdum2,pdum3,pdum4)
4288  CALL dexaa( 1,idum,pdum,pdum1,pdum2,pdum3,pdum4,pdum5,idum)
4289  CALL dexkk( 1,idum,pdum,pdum1,pdum2)
4290  CALL dexks( 1,idum,pdum,pdum1,pdum2,pdum3,pdum4,idum)
4291  CALL dexnew( 1,idum,pdum,pdum1,pdum2,pdumi,idum)
4292  WRITE(iout,10100) nev1,nev2,nevtot
4293  WRITE(iout,10200) (nevdec(i),gampmc(i),gamper(i),i= 1,7)
4294  WRITE(iout,10300) (nevdec(i),gampmc(i),gamper(i),names(i-7),
4295  + i=8,7+nmode)
4296  WRITE(iout,10400)
4297  ENDIF
4298  ELSE
4299  goto 30
4300  ENDIF
4301  RETURN
4302 10000 FORMAT(///1x,15(5h*****)
4303  + /,' *', 25x,'*****TAUOLA LIBRARY: VERSION 2.5 ******',9x,1h*,
4304  + /,' *', 25x,'***********JUNE 1994***************',9x,1h*,
4305  + /,' *', 25x,'**AUTHORS: S.JADACH, Z.WAS*************',9x,1h*,
4306  + /,' *', 25x,'**R. DECKER, M. JEZABEK, J.H.KUEHN*****',9x,1h*,
4307  + /,' *', 25x,'**AVAILABLE FROM: WASM AT CERNVM ******',9x,1h*,
4308  + /,' *', 25x,'***** PUBLISHED IN COMP. PHYS. COMM.***',9x,1h*,
4309  + /,' *', 25x,'*******CERN-TH-5856 SEPTEMBER 1990*****',9x,1h*,
4310  + /,' *', 25x,'*******CERN-TH-6195 SEPTEMBER 1991*****',9x,1h*,
4311  + /,' *', 25x,'*******CERN-TH-6793 NOVEMBER 1992*****',9x,1h*,
4312  + /,' *', 25x,'**5 OR MORE PI DEC.: PRECISION LIMITED ',9x,1h*,
4313  + /,' *', 25x,'******DEXAY ROUTINE: INITIALIZATION****',9x,1h*
4314  + /,' *',i20 ,5x,'JAK1 = DECAY MODE FERMION1 (TAU+) ',9x,1h*
4315  + /,' *',i20 ,5x,'JAK2 = DECAY MODE FERMION2 (TAU-) ',9x,1h*
4316  + /,1x,15(5h*****)/)
4317 CHBU FORMAT 7010 HAD MORE THAN 19 CONTINUATION LINES
4318 CHBU SPLIT INTO TWO
4319 10100 FORMAT(///1x,15(5h*****)
4320  + /,' *', 25x,'*****TAUOLA LIBRARY: VERSION 2.5 ******',9x,1h*,
4321  + /,' *', 25x,'***********JUNE 1994***************',9x,1h*,
4322  + /,' *', 25x,'**AUTHORS: S.JADACH, Z.WAS*************',9x,1h*,
4323  + /,' *', 25x,'**R. DECKER, M. JEZABEK, J.H.KUEHN*****',9x,1h*,
4324  + /,' *', 25x,'**AVAILABLE FROM: WASM AT CERNVM ******',9x,1h*,
4325  + /,' *', 25x,'***** PUBLISHED IN COMP. PHYS. COMM.***',9x,1h*,
4326  + /,' *', 25x,'*******CERN-TH-5856 SEPTEMBER 1990*****',9x,1h*,
4327  + /,' *', 25x,'*******CERN-TH-6195 SEPTEMBER 1991*****',9x,1h*,
4328  + /,' *', 25x,'*******CERN-TH-6793 NOVEMBER 1992*****',9x,1h*,
4329  + /,' *', 25x,'******DEXAY ROUTINE: FINAL REPORT******',9x,1h*
4330  + /,' *',i20 ,5x,'NEV1 = NO. OF TAU+ DECS. ACCEPTED ',9x,1h*
4331  + /,' *',i20 ,5x,'NEV2 = NO. OF TAU- DECS. ACCEPTED ',9x,1h*
4332  + /,' *',i20 ,5x,'NEVTOT = SUM ',9x,1h*
4333  + /,' *',' NOEVTS ',
4334  + ' PART.WIDTH ERROR ROUTINE DECAY MODE ',9x,1h*)
4335 10200 FORMAT(1x,'*'
4336  + ,i10,2f12.7 ,' DADMEL ELECTRON ',9x,1h*
4337  + /,' *',i10,2f12.7 ,' DADMMU MUON ',9x,1h*
4338  + /,' *',i10,2f12.7 ,' DADMPI PION ',9x,1h*
4339  + /,' *',i10,2f12.7, ' DADMRO RHO (->2PI) ',9x,1h*
4340  + /,' *',i10,2f12.7, ' DADMAA A1 (->3PI) ',9x,1h*
4341  + /,' *',i10,2f12.7, ' DADMKK KAON ',9x,1h*
4342  + /,' *',i10,2f12.7, ' DADMKS K* ',9x,1h*)
4343 10300 FORMAT(1x,'*'
4344  + ,i10,2f12.7,a31 ,8x,1h*)
4345 10400 FORMAT(1x,'*'
4346  + ,20x,'THE ERROR IS RELATIVE AND PART.WIDTH ',10x,1h*
4347  + /,' *',20x,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',10x,1h*
4348  + /,1x,15(5h*****)/)
4349  20 WRITE(iout, 10500)
4350 10500 FORMAT(' ----- DEXAY: LACK OF INITIALISATION')
4351  stop
4352  30 WRITE(iout, 10600)
4353 10600 FORMAT(' ----- DEXAY: WRONG VALUE OF KTO ')
4354  stop
4355  END
4356 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
4357 *CMZ : 1.00/00 10/08/94 16.29.39 BY PIERO ZUCCHELLI
4358 *-- AUTHOR :
4359  SUBROUTINE dexay1(KTO,JAKIN,JAK,POL,ISGN)
4360 C ---------------------------------------------------------------------
4361 C THIS ROUTINE SIMULATES TAU+- DECAY
4362 C
4363 C CALLED BY : DEXAY
4364 C ---------------------------------------------------------------------
4365  COMMON / taubmc / gampmc(30),gamper(30),nevdec(30)
4366  REAL*4 gampmc ,gamper
4367  COMMON / inout / inut,iout
4368  REAL pol(4),polar(4)
4369  REAL pnu(4),ppi(4)
4370  REAL prho(4),pic(4),piz(4)
4371  REAL pwb(4),pmu(4),pnm(4)
4372  REAL paa(4),pim1(4),pim2(4),pipl(4)
4373  REAL pkk(4),pks(4)
4374  REAL pnpi(4,9)
4375  REAL phot(4)
4376  REAL pdum(4)
4377 C
4378  IF(jakin.EQ.-1) RETURN
4379  DO 10 i=1,3
4380  10 polar(i)=pol(i)
4381  polar(4)=0.
4382  DO 20 i=1,4
4383  20 pdum(i)=.0
4384  jak=jakin
4385  IF(jak.EQ.0) CALL jaker(jak)
4386 CAM
4387  IF(jak.EQ.1) THEN
4388  CALL dexel(0, isgn,polar,pnu,pwb,pmu,pnm,phot)
4389  CALL dwluel(kto,isgn,pnu,pwb,pmu,pnm)
4390  CALL dwrph(kto,phot )
4391  ELSEIF(jak.EQ.2) THEN
4392  CALL dexmu(0, isgn,polar,pnu,pwb,pmu,pnm,phot)
4393  CALL dwlumu(kto,isgn,pnu,pwb,pmu,pnm)
4394  CALL dwrph(kto,phot )
4395  ELSEIF(jak.EQ.3) THEN
4396  CALL dexpi(0, isgn,polar,ppi,pnu)
4397  CALL dwlupi(kto,isgn,ppi,pnu)
4398  ELSEIF(jak.EQ.4) THEN
4399  CALL dexro(0, isgn,polar,pnu,prho,pic,piz)
4400  CALL dwluro(kto,isgn,pnu,prho,pic,piz)
4401  ELSEIF(jak.EQ.5) THEN
4402  CALL dexaa(0, isgn,polar,pnu,paa,pim1,pim2,pipl,jaa)
4403  CALL dwluaa(kto,isgn,pnu,paa,pim1,pim2,pipl,jaa)
4404  ELSEIF(jak.EQ.6) THEN
4405  CALL dexkk(0, isgn,polar,pkk,pnu)
4406  CALL dwlukk(kto,isgn,pkk,pnu)
4407  ELSEIF(jak.EQ.7) THEN
4408  CALL dexks(0, isgn,polar,pnu,pks,pkk,ppi,jkst)
4409  CALL dwluks(kto,isgn,pnu,pks,pkk,ppi,jkst)
4410  ELSE
4411  jnpi=jak-7
4412  CALL dexnew(0, isgn,polar,pnu,pwb,pnpi,jnpi)
4413  CALL dwlnew(kto,isgn,pnu,pwb,pnpi,jak)
4414  ENDIF
4415  nevdec(jak)=nevdec(jak)+1
4416  END
4417 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
4418 *CMZ : 1.00/00 10/08/94 16.29.39 BY PIERO ZUCCHELLI
4419 *-- AUTHOR :
4420  SUBROUTINE dexel(MODE,ISGN,POL,PNU,PWB,Q1,Q2,PH)
4421 C ----------------------------------------------------------------------
4422 C THIS SIMULATES TAU DECAY IN TAU REST FRAME
4423 C INTO ELECTRON AND TWO NEUTRINOS
4424 C
4425 C CALLED BY : DEXAY,DEXAY1
4426 C ----------------------------------------------------------------------
4427  REAL pol(4),hv(4),pwb(4),pnu(4),q1(4),q2(4),ph(4)
4428  DATA iwarm/0/
4429 C
4430  IF(mode.EQ.-1) THEN
4431 C ===================
4432  iwarm=1
4433  CALL dadmel( -1,isgn,hv,pnu,pwb,q1,q2,ph)
4434 CC CALL HBOOK1(813,'WEIGHT DISTRIBUTION DEXEL $',100,0,2)
4435 C
4436  ELSEIF(mode.EQ. 0) THEN
4437 C =======================
4438  10 CONTINUE
4439  IF(iwarm.EQ.0) goto 20
4440  CALL dadmel( 0,isgn,hv,pnu,pwb,q1,q2,ph)
4441  wt=(1+pol(1)*hv(1)+pol(2)*hv(2)+pol(3)*hv(3))/2.
4442 CC CALL HFILL(813,WT)
4443  CALL ranmar(rn,1)
4444  IF(rn.GT.wt) goto 10
4445 C
4446  ELSEIF(mode.EQ. 1) THEN
4447 C =======================
4448  CALL dadmel( 1,isgn,hv,pnu,pwb,q1,q2,ph)
4449 CC CALL HPRINT(813)
4450  ENDIF
4451 C =====
4452  RETURN
4453  20 print 10000
4454 10000 FORMAT(' ----- DEXEL: LACK OF INITIALISATION')
4455  stop
4456  END
4457 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
4458 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
4459 *-- AUTHOR :
4460  SUBROUTINE dexkk(MODE,ISGN,POL,PKK,PNU)
4461 C ----------------------------------------------------------------------
4462 C TAU DECAY INTO KAON AND TAU-NEUTRINO
4463 C IN TAU REST FRAME
4464 C OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
4465 C PKK KAON CHARGED
4466 C ----------------------------------------------------------------------
4467  REAL pol(4),hv(4),pnu(4),pkk(4)
4468 C
4469  IF(mode.EQ.-1) THEN
4470 C ===================
4471  CALL dadmkk(-1,isgn,hv,pkk,pnu)
4472 CC CALL HBOOK1(815,'WEIGHT DISTRIBUTION DEXPI $',100,0,2)
4473 C
4474  ELSEIF(mode.EQ. 0) THEN
4475 C =======================
4476  10 CONTINUE
4477  CALL dadmkk( 0,isgn,hv,pkk,pnu)
4478  wt=(1+pol(1)*hv(1)+pol(2)*hv(2)+pol(3)*hv(3))/2.
4479 CC CALL HFILL(815,WT)
4480  CALL ranmar(rn,1)
4481  IF(rn.GT.wt) goto 10
4482 C
4483  ELSEIF(mode.EQ. 1) THEN
4484 C =======================
4485  CALL dadmkk( 1,isgn,hv,pkk,pnu)
4486 CC CALL HPRINT(815)
4487  ENDIF
4488 C =====
4489  RETURN
4490  END
4491 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
4492 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
4493 *-- AUTHOR :
4494  SUBROUTINE dexks(MODE,ISGN,POL,PNU,PKS,PKK,PPI,JKST)
4495 C ----------------------------------------------------------------------
4496 C THIS SIMULATES TAU DECAY IN TAU REST FRAME
4497 C INTO NU K*, THEN K* DECAYS INTO PI0,K+-(JKST=20)
4498 C OR PI+-,K0(JKST=10).
4499 C OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
4500 C PKS K* CHARGED
4501 C PK0 K ZERO
4502 C PKC K CHARGED
4503 C PIC PION CHARGED
4504 C PIZ PION ZERO
4505 C ----------------------------------------------------------------------
4506  COMMON / inout / inut,iout
4507  REAL pol(4),hv(4),pks(4),pnu(4),pkk(4),ppi(4)
4508  DATA iwarm/0/
4509 C
4510  IF(mode.EQ.-1) THEN
4511 C ===================
4512  iwarm=1
4513 CFZ INITIALISATION DONE WITH THE GHARGED PION NEUTRAL KAON MODE(JKST=10
4514  CALL dadmks( -1,isgn,hv,pnu,pks,pkk,ppi,jkst)
4515 CC CALL HBOOK1(816,'WEIGHT DISTRIBUTION DEXKS $',100,0,2)
4516 CC CALL HBOOK1(916,'ABS2 OF HV IN ROUTINE DEXKS $',100,0,2)
4517 C
4518  ELSEIF(mode.EQ. 0) THEN
4519 C =======================
4520  10 CONTINUE
4521  IF(iwarm.EQ.0) goto 20
4522  CALL dadmks( 0,isgn,hv,pnu,pks,pkk,ppi,jkst)
4523  wt=(1+pol(1)*hv(1)+pol(2)*hv(2)+pol(3)*hv(3))/2.
4524 CC CALL HFILL(816,WT)
4525 CC XHELP=HV(1)**2+HV(2)**2+HV(3)**2
4526 CC CALL HFILL(916,XHELP)
4527  CALL ranmar(rn,1)
4528  IF(rn.GT.wt) goto 10
4529 C
4530  ELSEIF(mode.EQ. 1) THEN
4531 C ======================================
4532  CALL dadmks( 1,isgn,hv,pnu,pks,pkk,ppi,jkst)
4533 CC CALL HPRINT(816)
4534 CC CALL HPRINT(916)
4535  ENDIF
4536 C =====
4537  RETURN
4538  20 WRITE(iout, 10000)
4539 10000 FORMAT(' ----- DEXKS: LACK OF INITIALISATION')
4540  stop
4541  END
4542 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
4543 *CMZ : 1.00/00 10/08/94 16.29.39 BY PIERO ZUCCHELLI
4544 *-- AUTHOR :
4545  SUBROUTINE dexmu(MODE,ISGN,POL,PNU,PWB,Q1,Q2,PH)
4546 C ----------------------------------------------------------------------
4547 C THIS SIMULATES TAU DECAY IN ITS REST FRAME
4548 C INTO MUON AND TWO NEUTRINOS
4549 C OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
4550 C PWB W-BOSON
4551 C Q1 MUON
4552 C Q2 MUON-NEUTRINO
4553 C ----------------------------------------------------------------------
4554  COMMON / inout / inut,iout
4555  REAL pol(4),hv(4),pwb(4),pnu(4),q1(4),q2(4),ph(4)
4556  DATA iwarm/0/
4557 C
4558  IF(mode.EQ.-1) THEN
4559 C ===================
4560  iwarm=1
4561  CALL dadmmu( -1,isgn,hv,pnu,pwb,q1,q2,ph)
4562 CC CALL HBOOK1(814,'WEIGHT DISTRIBUTION DEXMU $',100,0,2)
4563 C
4564  ELSEIF(mode.EQ. 0) THEN
4565 C =======================
4566  10 CONTINUE
4567  IF(iwarm.EQ.0) goto 20
4568  CALL dadmmu( 0,isgn,hv,pnu,pwb,q1,q2,ph)
4569  wt=(1+pol(1)*hv(1)+pol(2)*hv(2)+pol(3)*hv(3))/2.
4570 CC CALL HFILL(814,WT)
4571  CALL ranmar(rn,1)
4572  IF(rn.GT.wt) goto 10
4573 C
4574  ELSEIF(mode.EQ. 1) THEN
4575 C =======================
4576  CALL dadmmu( 1,isgn,hv,pnu,pwb,q1,q2,ph)
4577 CC CALL HPRINT(814)
4578  ENDIF
4579 C =====
4580  RETURN
4581  20 WRITE(iout, 10000)
4582 10000 FORMAT(' ----- DEXMU: LACK OF INITIALISATION')
4583  stop
4584  END
4585 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
4586 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
4587 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
4588 *-- AUTHOR :
4589  SUBROUTINE dexnew(MODE,ISGN,POL,PNU,PAA,PNPI,JNPI)
4590 C ----------------------------------------------------------------------
4591 * THIS SIMULATES TAU DECAY IN TAU REST FRAME
4592 * INTO NU A1, NEXT A1 DECAYS INTO RHO PI AND FINALLY RHO INTO PI PI.
4593 * OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
4594 * PAA A1
4595 * PIM1 PION MINUS (OR PI0) 1 (FOR TAU MINUS)
4596 * PIM2 PION MINUS (OR PI0) 2
4597 * PIPL PION PLUS (OR PI-)
4598 * (PIPL,PIM1) FORM A RHO
4599 C ----------------------------------------------------------------------
4600  COMMON / inout / inut,iout
4601  REAL pol(4),hv(4),paa(4),pnu(4),pnpi(4,9)
4602  DATA iwarm/0/
4603 C
4604  IF(mode.EQ.-1) THEN
4605 C ===================
4606  iwarm=1
4607  CALL dadnew( -1,isgn,hv,pnu,paa,pnpi,jdumm)
4608 CC CALL HBOOK1(816,'WEIGHT DISTRIBUTION DEXAA $',100,-2.,2.)
4609 C
4610  ELSEIF(mode.EQ. 0) THEN
4611 * =======================
4612  10 CONTINUE
4613  IF(iwarm.EQ.0) goto 20
4614  CALL dadnew( 0,isgn,hv,pnu,paa,pnpi,jnpi)
4615  wt=(1+pol(1)*hv(1)+pol(2)*hv(2)+pol(3)*hv(3))/2.
4616 CC CALL HFILL(816,WT)
4617  CALL ranmar(rn,1)
4618  IF(rn.GT.wt) goto 10
4619 C
4620  ELSEIF(mode.EQ. 1) THEN
4621 * =======================
4622  CALL dadnew( 1,isgn,hv,pnu,paa,pnpi,jdumm)
4623 CC CALL HPRINT(816)
4624  ENDIF
4625 C =====
4626  RETURN
4627  20 WRITE(iout, 10000)
4628 10000 FORMAT(' ----- DEXNEW: LACK OF INITIALISATION')
4629  stop
4630  END
4631 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
4632 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
4633 *-- AUTHOR :
4634  SUBROUTINE dexpi(MODE,ISGN,POL,PPI,PNU)
4635 C ----------------------------------------------------------------------
4636 C TAU DECAY INTO PION AND TAU-NEUTRINO
4637 C IN TAU REST FRAME
4638 C OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
4639 C PPI PION CHARGED
4640 C ----------------------------------------------------------------------
4641  REAL pol(4),hv(4),pnu(4),ppi(4)
4642 CC
4643  IF(mode.EQ.-1) THEN
4644 C ===================
4645  CALL dadmpi(-1,isgn,hv,ppi,pnu)
4646 CC CALL HBOOK1(815,'WEIGHT DISTRIBUTION DEXPI $',100,0,2)
4647 
4648  ELSEIF(mode.EQ. 0) THEN
4649 C =======================
4650  10 CONTINUE
4651  CALL dadmpi( 0,isgn,hv,ppi,pnu)
4652  wt=(1+pol(1)*hv(1)+pol(2)*hv(2)+pol(3)*hv(3))/2.
4653 CC CALL HFILL(815,WT)
4654  CALL ranmar(rn,1)
4655  IF(rn.GT.wt) goto 10
4656 C
4657  ELSEIF(mode.EQ. 1) THEN
4658 C =======================
4659  CALL dadmpi( 1,isgn,hv,ppi,pnu)
4660 CC CALL HPRINT(815)
4661  ENDIF
4662 C =====
4663  RETURN
4664  END
4665 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
4666 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
4667 *-- AUTHOR :
4668  SUBROUTINE dexro(MODE,ISGN,POL,PNU,PRO,PIC,PIZ)
4669 C ----------------------------------------------------------------------
4670 C THIS SIMULATES TAU DECAY IN TAU REST FRAME
4671 C INTO NU RHO, NEXT RHO DECAYS INTO PION PAIR.
4672 C OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
4673 C PRO RHO
4674 C PIC PION CHARGED
4675 C PIZ PION ZERO
4676 C ----------------------------------------------------------------------
4677  COMMON / inout / inut,iout
4678  REAL pol(4),hv(4),pro(4),pnu(4),pic(4),piz(4)
4679  DATA iwarm/0/
4680 C
4681  IF(mode.EQ.-1) THEN
4682 C ===================
4683  iwarm=1
4684  CALL dadmro( -1,isgn,hv,pnu,pro,pic,piz)
4685 CC CALL HBOOK1(816,'WEIGHT DISTRIBUTION DEXRO $',100,0,2)
4686 CC CALL HBOOK1(916,'ABS2 OF HV IN ROUTINE DEXRO $',100,0,2)
4687 C
4688  ELSEIF(mode.EQ. 0) THEN
4689 C =======================
4690  10 CONTINUE
4691  IF(iwarm.EQ.0) goto 20
4692  CALL dadmro( 0,isgn,hv,pnu,pro,pic,piz)
4693  wt=(1+pol(1)*hv(1)+pol(2)*hv(2)+pol(3)*hv(3))/2.
4694 CC CALL HFILL(816,WT)
4695 CC XHELP=HV(1)**2+HV(2)**2+HV(3)**2
4696 CC CALL HFILL(916,XHELP)
4697  CALL ranmar(rn,1)
4698  IF(rn.GT.wt) goto 10
4699 C
4700  ELSEIF(mode.EQ. 1) THEN
4701 C =======================
4702  CALL dadmro( 1,isgn,hv,pnu,pro,pic,piz)
4703 CC CALL HPRINT(816)
4704 CC CALL HPRINT(916)
4705  ENDIF
4706 C =====
4707  RETURN
4708  20 WRITE(iout, 10000)
4709 10000 FORMAT(' ----- DEXRO: LACK OF INITIALISATION')
4710  stop
4711  END
4712 *CMZ : 1.02/00 12/01/97 15.00.23 by J. Brunner
4713 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
4714 *-- AUTHOR :
4715 C **********************************************************************
4716 
4717  DOUBLE PRECISION FUNCTION dfun(NDIM,X)
4718  INTEGER ndim
4719  DOUBLE PRECISION x(ndim)
4720  dfun=riwfun(x)
4721  RETURN
4722  END
4723 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
4724 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
4725 *-- AUTHOR :
4726  FUNCTION dilog(X)
4727 C *****************
4728  IMPLICIT REAL*8(a-h,o-z)
4729 CERN C304 VERSION 29/07/71 DILOG 59 C
4730  z=-1.64493406684822
4731  IF(x .LT.-1.0) go to 10
4732  IF(x .LE. 0.5) go to 20
4733  IF(x .EQ. 1.0) go to 30
4734  IF(x .LE. 2.0) go to 40
4735  z=3.2898681336964
4736  10 t=1.0/x
4737  s=-0.5
4738  z=z-0.5* log(abs(x))**2
4739  go to 50
4740  20 t=x
4741  s=0.5
4742  z=0.
4743  go to 50
4744  30 dilog=1.64493406684822
4745  RETURN
4746  40 t=1.0-x
4747  s=-0.5
4748  z=1.64493406684822 - log(x)* log(abs(t))
4749  50 y=2.66666666666666 *t+0.66666666666666
4750  b= 0.00000 00000 00001
4751  a=y*b +0.00000 00000 00004
4752  b=y*a-b+0.00000 00000 00011
4753  a=y*b-a+0.00000 00000 00037
4754  b=y*a-b+0.00000 00000 00121
4755  a=y*b-a+0.00000 00000 00398
4756  b=y*a-b+0.00000 00000 01312
4757  a=y*b-a+0.00000 00000 04342
4758  b=y*a-b+0.00000 00000 14437
4759  a=y*b-a+0.00000 00000 48274
4760  b=y*a-b+0.00000 00001 62421
4761  a=y*b-a+0.00000 00005 50291
4762  b=y*a-b+0.00000 00018 79117
4763  a=y*b-a+0.00000 00064 74338
4764  b=y*a-b+0.00000 00225 36705
4765  a=y*b-a+0.00000 00793 87055
4766  b=y*a-b+0.00000 02835 75385
4767  a=y*b-a+0.00000 10299 04264
4768  b=y*a-b+0.00000 38163 29463
4769  a=y*b-a+0.00001 44963 00557
4770  b=y*a-b+0.00005 68178 22718
4771  a=y*b-a+0.00023 20021 96094
4772  b=y*a-b+0.00100 16274 96164
4773  a=y*b-a+0.00468 63619 59447
4774  b=y*a-b+0.02487 93229 24228
4775  a=y*b-a+0.16607 30329 27855
4776  a=y*a-b+1.93506 43008 6996
4777  dilog=s*t*(a-b)+z
4778  RETURN
4779 C=======================================================================
4780 C===================END OF CPC PART ====================================
4781 C=======================================================================
4782  END
4783 *CMZ : 1.01/50 29/02/96 09.49.49 by Piero Zucchelli
4784 *CMZ : 1.01/43 15/12/95 18.02.33 by Piero Zucchelli
4785 *CMZ : 1.01/40 09/11/95 16.09.04 by Piero Zucchelli
4786 *CMZ : 1.01/39 20/10/95 18.27.32 by Piero Zucchelli
4787 *CMZ : 1.01/32 02/06/95 20.27.41 BY PIERO ZUCCHELLI
4788 *CMZ : 1.01/31 02/06/95 20.17.17 BY PIERO ZUCCHELLI
4789 *CMZ : 1.01/08 05/03/95 11.35.13 BY PIERO ZUCCHELLI
4790 *CMZ : 1.01/01 23/09/94 12.02.06 BY PIERO ZUCCHELLI
4791 *CMZ : 1.00/00 15/08/94 07.15.40 BY PIERO ZUCCHELLI
4792 *CMZ : 1.00/00 11/07/94 09.26.54 BY PIERO ZUCCHELLI
4793 *-- AUTHOR : PIERO ZUCCHELLI 04/07/94
4794 
4795  REAL*4 FUNCTION distrr(DUMMY)
4796 *KEEP,JETTA.
4797 C--
4798  parameter(icento=100)
4799  parameter(isiz=93)
4800  parameter(iof1=32)
4801  parameter(iof2=83)
4802  parameter(lux_level=4)
4803  INTEGER*4 jtau(100),jpri(100),jstro(100)
4804  REAL*4 ftuple(isiz)
4805  common/jettagl/jtau,jpri,jstro
4806  common/ntupla/ftuple,isfirst
4807  common/beam/spec(icento)
4808  COMMON /maxspec/rmaxspec,rintspec
4809  common/sav/xminsav(icento),xmaxsav(icento),yminsav(icento),
4810  & ymaxsav(icento),q2minsav(icento),q2maxsav(icento),
4811  & w2minsav(icento),w2maxsav(icento),parimax(icento),
4812  & ppsave(icento,3,4,5),paricor(icento),index,sigmasav(icento),
4813  & xmsigma,xsect
4814 
4815 *KEEP,KEYS.
4816  common/cfread/space(5000)
4817  common/mykeys/ievar,if5cc,ineut,iinte,iferm,iflat,icoun,
4818  & refix,imudo,ikat1,ikat2,ikat3,ikat4,ikat5,ikat6,
4819  & inevt,ijak1,ijak2,iitdk,rptau,rxk0d,ntgr,idimuon,iglu,
4820  & iqden,lome(2),ifiles,iccha,iseed,idsubs,ionem,ehac,ipsel,
4821  & ihist
4822 
4823 
4824 *KEND.
4825  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
4826  COMMON /lintrl/ psave(3,4,5),ksave(4),xmin,xmax,ymin,ymax,
4827  +q2min,q2max,w2min,w2max,ilep,inu,ig,iz
4828  COMMON /linter/ pari(40),ewqc(2,2,8),qc(8),zl(2,4),zq(2,8),pq(17)
4829 
4830 10 CONTINUE
4831  distr=dummy
4832 * now we have to understand to what index corresponds
4833 * ENE=(I-1)*3. + 1.5
4834 
4835  itest=(dummy-1.5)/3.+1
4836 * this is the lower bin, we have to determine its xsection
4837 * and then accept/reject it ,
4838 * if accepted we fill the numbers....
4839  dice=rndmm(iseed)*xmsigma
4840  ene1=(itest-1)*3. + 1.5
4841  ene2=(itest)*3. + 1.5
4842  IF (itest.EQ.0) ene1=0
4843  IF (itest.NE.0) THEN
4844  s1=sigmasav(itest)
4845  ELSE
4846  s1=0
4847  ENDIF
4848  s2=sigmasav(itest+1)
4849  xsect=(dummy-ene1)/(ene2-ene1)*(s2-s1)+s1
4850 
4851 
4852  IF (dice.GT.xsect) THEN
4853  distr=0.
4854  RETURN
4855  ENDIF
4856 
4857  index=itest
4858 
4859  IF (index.LE.0.OR.index.GT.icento) THEN
4860  WRITE(*,*)'+++DISTR WARNING: OUTOFRANGE',index
4861  distr=0.
4862  RETURN
4863  ENDIF
4864 
4865  pari(32)=paricor(index)
4866  pari(lst(23))=parimax(index)
4867  xmin=xminsav(index)
4868  xmax=xmaxsav(index)
4869  ymin=yminsav(index)
4870  ymax=ymaxsav(index)
4871  q2min=q2minsav(index)
4872  q2max=q2maxsav(index)
4873  w2min=w2minsav(index)
4874  w2max=w2maxsav(index)
4875  DO 20 ia=1,2
4876  DO 20 ja=1,5
4877  20 psave(3,ia,ja)=ppsave(index,3,ia,ja)
4878 
4879  RETURN
4880  END
4881 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
4882 *-- AUTHOR :
4883 C **********************************************************************
4884 
4885  FUNCTION dlower(V1)
4886 
4887 C...LOWER LIMIT ON SECOND VARIABLE (Y, Q**2 OR W**2) DEPENDING ON FIRST
4888 C...VARIABLE X=V1. USED FOR INTEGRATING DIFFERENTIAL CROSS-SECTION.
4889 
4890  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
4891  COMMON /lintrl/ psave(3,4,5),ksave(4),xmin,xmax,ymin,ymax,
4892  &q2min,q2max,w2min,w2max,ilep,inu,ig,iz
4893 C...CMS ENERGY SQUARED AND TARGET NUCLEON MASS.
4894  s=parl(21)
4895  pm2=psave(3,2,5)**2
4896  IF(lst(31).EQ.1) THEN
4897  dlower=max(q2min,v1*ymin*s,(w2min-pm2)*v1/max(1.-v1,1.e-22))
4898  ELSEIF(lst(31).EQ.2) THEN
4899  dlower=max(ymin,q2min/(s*v1),(w2min-pm2)/max(s*(1.-v1),1.e-22))
4900  ELSEIF(lst(31).EQ.3) THEN
4901  dlower=max(w2min,(1.-v1)*ymin*s+pm2,
4902  & q2min*(1.-v1)/max(v1,1.e-22)+pm2)
4903  ENDIF
4904  RETURN
4905  END
4906 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
4907 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
4908 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
4909 *-- AUTHOR :
4910  SUBROUTINE dph4pi(DGAMT,HV,PN,PAA,PMULT,JNPI)
4911 C ----------------------------------------------------------------------
4912 * IT SIMULATES A1 DECAY IN TAU REST FRAME WITH
4913 * Z-AXIS ALONG A1 MOMENTUM
4914 C ----------------------------------------------------------------------
4915  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
4916  + ,ampiz,ampi,amro,gamro,ama1,gama1
4917  + ,amk,amkz,amkst,gamkst
4918 C
4919  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
4920  + ,ampiz,ampi,amro,gamro,ama1,gama1
4921  + ,amk,amkz,amkst,gamkst
4922  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
4923  REAL*4 gfermi,gv,ga,ccabib,scabib,gamel
4924  REAL hv(4),pt(4),pn(4),paa(4),pim1(4),pim2(4),pipl(4),pmult(4,9)
4925  REAL pr(4),piz(4)
4926  REAL*4 rrr(9)
4927  REAL*8 uu,ff,ff1,ff2,ff3,ff4,gg1,gg2,gg3,gg4,rr
4928  DATA pi /3.141592653589793238462643/
4929  DATA icont /0/
4930  xlam(x,y,z)=sqrt(abs((x-y-z)**2-4.0*y*z))
4931 C AMRO, GAMRO IS ONLY A PARAMETER FOR GETING HIGHT EFFICIENCY
4932 C
4933 C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
4934 C D**3 P /2E/(2PI)**3 (2PI)**4 DELTA4(SUM P)
4935  phspac=1./2**23/pi**11
4936  phsp=1./2**5/pi**2
4937  IF (jnpi.EQ.1) THEN
4938  prez=0.7
4939  amp1=ampi
4940  amp2=ampi
4941  amp3=ampi
4942  amp4=ampiz
4943  amrx=0.782
4944  gamrx=0.0084
4945  amrop =1.2
4946  gamrop=.46
4947 
4948  ELSE
4949  prez=0.0
4950  amp1=ampiz
4951  amp2=ampiz
4952  amp3=ampiz
4953  amp4=ampi
4954  amrx=1.4
4955  gamrx=.6
4956  amrop =amrx
4957  gamrop=gamrx
4958 
4959  ENDIF
4960  rr=0.3
4961  CALL choice(100+jnpi,rr,ichan,prob1,prob2,prob3,
4962  + amrop,gamrop,amrx,gamrx,amrb,gamrb)
4963  prez=prob1+prob2
4964 C TAU MOMENTUM
4965  pt(1)=0.
4966  pt(2)=0.
4967  pt(3)=0.
4968  pt(4)=amtau
4969 C
4970  CALL ranmar(rrr,9)
4971 C
4972 * MASSES OF 4, 3 AND 2 PI SYSTEMS
4973 C 3 PI WITH SAMPLING FOR RESONANCE
4974 CAM
4975  rr1=rrr(6)
4976  ams1=(amp1+amp2+amp3+amp4)**2
4977  ams2=(amtau-amnuta)**2
4978  alp1=atan((ams1-amrop**2)/amrop/gamrop)
4979  alp2=atan((ams2-amrop**2)/amrop/gamrop)
4980  alp=alp1+rr1*(alp2-alp1)
4981  am4sq =amrop**2+amrop*gamrop*tan(alp)
4982  am4 =sqrt(am4sq)
4983  phspac=phspac* ((am4sq-amrop**2)**2+(amrop*gamrop)**2)/(amrop*
4984  +gamrop)
4985  phspac=phspac*(alp2-alp1)
4986 
4987 C
4988  rr1=rrr(1)
4989  ams1=(amp2+amp3+amp4)**2
4990  ams2=(am4-amp1)**2
4991  IF (rrr(9).GT.prez) THEN
4992  am3sq=ams1+ rr1*(ams2-ams1)
4993  am3 =sqrt(am3sq)
4994 C --- THIS PART OF JACOBIAN WILL BE RECOVERED LATER
4995  ff1=ams2-ams1
4996  ELSE
4997 * PHASE SPACE WITH SAMPLING FOR OMEGA RESONANCE,
4998  alp1=atan((ams1-amrx**2)/amrx/gamrx)
4999  alp2=atan((ams2-amrx**2)/amrx/gamrx)
5000  alp=alp1+rr1*(alp2-alp1)
5001  am3sq =amrx**2+amrx*gamrx*tan(alp)
5002  am3 =sqrt(am3sq)
5003 C --- THIS PART OF THE JACOBIAN WILL BE RECOVERED LATER ---------------
5004  ff1=((am3sq-amrx**2)**2+(amrx*gamrx)**2)/(amrx*gamrx)
5005  ff1=ff1*(alp2-alp1)
5006  ENDIF
5007 C MASS OF 2
5008  rr2=rrr(2)
5009  ams1=(amp3+amp4)**2
5010  ams2=(am3-amp2)**2
5011 * FLAT PHASE SPACE;
5012  am2sq=ams1+ rr2*(ams2-ams1)
5013  am2 =sqrt(am2sq)
5014 C --- THIS PART OF JACOBIAN WILL BE RECOVERED LATER
5015  ff2=(ams2-ams1)
5016 * 2 RESTFRAME, DEFINE PIZ AND PIPL
5017  enq1=(am2sq-amp3**2+amp4**2)/(2*am2)
5018  enq2=(am2sq+amp3**2-amp4**2)/(2*am2)
5019  ppi= enq1**2-amp4**2
5020  pppi=sqrt(abs(enq1**2-amp4**2))
5021  phspac=phspac*(4*pi)*(2*pppi/am2)
5022 * PIZ MOMENTUM IN 2 REST FRAME
5023  CALL sphera(pppi,piz)
5024  piz(4)=enq1
5025 * PIPL MOMENTUM IN 2 REST FRAME
5026  DO 10 i=1,3
5027  10 pipl(i)=-piz(i)
5028  pipl(4)=enq2
5029 * 3 REST FRAME, DEFINE PIM1
5030 * PR MOMENTUM
5031  pr(1)=0
5032  pr(2)=0
5033  pr(4)=1./(2*am3)*(am3**2+am2**2-amp2**2)
5034  pr(3)= sqrt(abs(pr(4)**2-am2**2))
5035  ppi = pr(4)**2-am2**2
5036 * PIM1 MOMENTUM
5037  pim1(1)=0
5038  pim1(2)=0
5039  pim1(4)=1./(2*am3)*(am3**2-am2**2+amp2**2)
5040  pim1(3)=-pr(3)
5041 C --- THIS PART OF JACOBIAN WILL BE RECOVERED LATER
5042  ff3=(4*pi)*(2*pr(3)/am3)
5043 * OLD PIONS BOOSTED FROM 2 REST FRAME TO 3 REST FRAME
5044  exe=(pr(4)+pr(3))/am2
5045  CALL bostr3(exe,piz,piz)
5046  CALL bostr3(exe,pipl,pipl)
5047  rr3=rrr(3)
5048  rr4=rrr(4)
5049  thet =acos(-1.+2*rr3)
5050  phi = 2*pi*rr4
5051  CALL rotpol(thet,phi,pipl)
5052  CALL rotpol(thet,phi,pim1)
5053  CALL rotpol(thet,phi,piz)
5054  CALL rotpol(thet,phi,pr)
5055 * 4 REST FRAME, DEFINE PIM2
5056 * PR MOMENTUM
5057  pr(1)=0
5058  pr(2)=0
5059  pr(4)=1./(2*am4)*(am4**2+am3**2-amp1**2)
5060  pr(3)= sqrt(abs(pr(4)**2-am3**2))
5061  ppi = pr(4)**2-am3**2
5062 * PIM2 MOMENTUM
5063  pim2(1)=0
5064  pim2(2)=0
5065  pim2(4)=1./(2*am4)*(am4**2-am3**2+amp1**2)
5066  pim2(3)=-pr(3)
5067 C --- THIS PART OF JACOBIAN WILL BE RECOVERED LATER
5068  ff4=(4*pi)*(2*pr(3)/am4)
5069 * OLD PIONS BOOSTED FROM 3 REST FRAME TO 4 REST FRAME
5070  exe=(pr(4)+pr(3))/am3
5071  CALL bostr3(exe,piz,piz)
5072  CALL bostr3(exe,pipl,pipl)
5073  CALL bostr3(exe,pim1,pim1)
5074  rr3=rrr(7)
5075  rr4=rrr(8)
5076  thet =acos(-1.+2*rr3)
5077  phi = 2*pi*rr4
5078  CALL rotpol(thet,phi,pipl)
5079  CALL rotpol(thet,phi,pim1)
5080  CALL rotpol(thet,phi,pim2)
5081  CALL rotpol(thet,phi,piz)
5082  CALL rotpol(thet,phi,pr)
5083 C
5084 * NOW TO THE TAU REST FRAME, DEFINE PAA AND NEUTRINO MOMENTA
5085 * PAA MOMENTUM
5086  paa(1)=0
5087  paa(2)=0
5088  paa(4)=1./(2*amtau)*(amtau**2-amnuta**2+am4**2)
5089  paa(3)= sqrt(abs(paa(4)**2-am4**2))
5090  ppi = paa(4)**2-am4**2
5091  phspac=phspac*(4*pi)*(2*paa(3)/amtau)
5092  phsp=phsp*(4*pi)*(2*paa(3)/amtau)
5093 * TAU-NEUTRINO MOMENTUM
5094  pn(1)=0
5095  pn(2)=0
5096  pn(4)=1./(2*amtau)*(amtau**2+amnuta**2-am4**2)
5097  pn(3)=-paa(3)
5098 C WE INCLUDE REMAINING PART OF THE JACOBIAN
5099 C --- FLAT CHANNEL
5100  am3sq=(pim1(4)+piz(4)+pipl(4))**2-(pim1(3)+piz(3)+pipl(3))**2
5101  +-(pim1(2)+piz(2)+pipl(2))**2-(pim1(1)+piz(1)+pipl(1))**2
5102  ams2=(am4-amp2)**2
5103  ams1=(amp1+amp3+amp4)**2
5104  ff1=(ams2-ams1)
5105  ams1=(amp3+amp4)**2
5106  ams2=(sqrt(am3sq)-amp1)**2
5107  ff2=ams2-ams1
5108  ff3=(4*pi)*(xlam(am2**2,amp1**2,am3sq)/am3sq)
5109  ff4=(4*pi)*(xlam(am3sq,amp2**2,am4**2)/am4**2)
5110  uu=ff1*ff2*ff3*ff4
5111 C --- FIRST CHANNEL
5112  am3sq=(pim1(4)+piz(4)+pipl(4))**2-(pim1(3)+piz(3)+pipl(3))**2
5113  +-(pim1(2)+piz(2)+pipl(2))**2-(pim1(1)+piz(1)+pipl(1))**2
5114  ams2=(am4-amp2)**2
5115  ams1=(amp1+amp3+amp4)**2
5116  alp1=atan((ams1-amrx**2)/amrx/gamrx)
5117  alp2=atan((ams2-amrx**2)/amrx/gamrx)
5118  ff1=((am3sq-amrx**2)**2+(amrx*gamrx)**2)/(amrx*gamrx)
5119  ff1=ff1*(alp2-alp1)
5120  ams1=(amp3+amp4)**2
5121  ams2=(sqrt(am3sq)-amp1)**2
5122  ff2=ams2-ams1
5123  ff3=(4*pi)*(xlam(am2**2,amp1**2,am3sq)/am3sq)
5124  ff4=(4*pi)*(xlam(am3sq,amp2**2,am4**2)/am4**2)
5125  ff=ff1*ff2*ff3*ff4
5126 C --- SECOND CHANNEL
5127  am3sq=(pim2(4)+piz(4)+pipl(4))**2-(pim2(3)+piz(3)+pipl(3))**2
5128  +-(pim2(2)+piz(2)+pipl(2))**2-(pim2(1)+piz(1)+pipl(1))**2
5129  ams2=(am4-amp1)**2
5130  ams1=(amp2+amp3+amp4)**2
5131  alp1=atan((ams1-amrx**2)/amrx/gamrx)
5132  alp2=atan((ams2-amrx**2)/amrx/gamrx)
5133  gg1=((am3sq-amrx**2)**2+(amrx*gamrx)**2)/(amrx*gamrx)
5134  gg1=gg1*(alp2-alp1)
5135  ams1=(amp3+amp4)**2
5136  ams2=(sqrt(am3sq)-amp2)**2
5137  gg2=ams2-ams1
5138  gg3=(4*pi)*(xlam(am2**2,amp2**2,am3sq)/am3sq)
5139  gg4=(4*pi)*(xlam(am3sq,amp1**2,am4**2)/am4**2)
5140  gg=gg1*gg2*gg3*gg4
5141 C --- JACOBIAN AVERAGED OVER THE TWO
5142  IF ( ( (ff+gg)*uu+ff*gg ).GT.0.0d0) THEN
5143  rr=ff*gg*uu/(0.5*prez*(ff+gg)*uu+(1.0-prez)*ff*gg)
5144  phspac=phspac*rr
5145  ELSE
5146  phspac=0.0
5147  ENDIF
5148 * MOMENTA OF THE TWO PI-MINUS ARE RANDOMLY SYMMETRISED
5149  IF (jnpi.EQ.1) THEN
5150  rr5= rrr(5)
5151  IF(rr5.LE.0.5) THEN
5152  DO 20 i=1,4
5153  x=pim1(i)
5154  pim1(i)=pim2(i)
5155  20 pim2(i)=x
5156  ENDIF
5157  phspac=phspac/2.
5158  ELSE
5159 C MOMENTA OF PI0'S ARE GENERATED UNIFORMLY ONLY IF PREZ=0.0
5160  rr5= rrr(5)
5161  IF(rr5.LE.0.5) THEN
5162  DO 30 i=1,4
5163  x=pim1(i)
5164  pim1(i)=pim2(i)
5165  30 pim2(i)=x
5166  ENDIF
5167  phspac=phspac/6.
5168  ENDIF
5169 * ALL PIONS BOOSTED FROM 4 REST FRAME TO TAU REST FRAME
5170 * Z-AXIS ANTIPARALLEL TO NEUTRINO MOMENTUM
5171  exe=(paa(4)+paa(3))/am4
5172  CALL bostr3(exe,piz,piz)
5173  CALL bostr3(exe,pipl,pipl)
5174  CALL bostr3(exe,pim1,pim1)
5175  CALL bostr3(exe,pim2,pim2)
5176  CALL bostr3(exe,pr,pr)
5177 C PARTIAL WIDTH CONSISTS OF PHASE SPACE AND AMPLITUDE
5178 C CHECK ON CONSISTENCY WITH DADNPI, THEN, CODE BREAKES UNIFORM PION
5179 C DISTRIBUTION IN HADRONIC SYSTEM
5180 CAM ASSUME NEUTRINO MASS=0. AND SUM OVER FINAL POLARISATION
5181 C AMX2=AM4**2
5182 C BRAK= 2*(AMTAU**2-AMX2) * (AMTAU**2+2.*AMX2)
5183 C AMPLIT=CCABIB**2*GFERMI**2/2. * BRAK * AMX2*SIGEE(AMX2,1)
5184  IF (jnpi.EQ.1) THEN
5185  CALL dam4pi(jnpi,pt,pn,pim1,pim2,piz,pipl,amplit,hv)
5186  ELSEIF (jnpi.EQ.2) THEN
5187  CALL dam4pi(jnpi,pt,pn,pim1,pim2,pipl,piz,amplit,hv)
5188  ENDIF
5189  dgamt=1/(2.*amtau)*amplit*phspac
5190 C PHASE SPACE CHECK
5191 C DGAMT=PHSPAC
5192  DO 40 k=1,4
5193  pmult(k,1)=pim1(k)
5194  pmult(k,2)=pim2(k)
5195  pmult(k,3)=pipl(k)
5196  pmult(k,4)=piz(k)
5197  40 CONTINUE
5198  END
5199 *CMZ : 1.02/01 12/01/97 16.41.51 by J. Brunner
5200 *CMZ : 1.01/50 22/05/96 18.06.08 by Piero Zucchelli
5201 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
5202 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
5203 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
5204 *-- AUTHOR :
5205  SUBROUTINE dph5pi(DGAMT,HV,PN,PAA,PMULT,JNPI)
5206 C ----------------------------------------------------------------------
5207 * IT SIMULATES 5PI DECAY IN TAU REST FRAME WITH
5208 * Z-AXIS ALONG 5PI MOMENTUM
5209 C ----------------------------------------------------------------------
5210  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
5211  + ,ampiz,ampi,amro,gamro,ama1,gama1
5212  + ,amk,amkz,amkst,gamkst
5213 C
5214  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
5215  + ,ampiz,ampi,amro,gamro,ama1,gama1
5216  + ,amk,amkz,amkst,gamkst
5217 
5218 
5219  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
5220  REAL*4 gfermi,gv,ga,ccabib,scabib,gamel
5221  parameter(nmode=15,nm1=0,nm2=1,nm3=8,nm4=2,nm5=1,nm6=3)
5222  COMMON / mdecomp /idffin(9,nmode),mulpik(nmode)
5223  + ,names
5224  CHARACTER names(nmode)*31
5225  REAL hv(4),pt(4),pn(4),paa(4),pmult(4,9)
5226  REAL*4 pr(4),pi1(4),pi2(4),pi3(4),pi4(4),pi5(4)
5227  REAL*8 amp1,amp2,amp3,amp4,amp5,ams1,ams2,amom,gamom
5228  REAL*8 am5sq,am4sq,am3sq,am2sq,am5,am4,am3
5229  REAL*4 rrr(10)
5230  REAL*8 gg1,gg2,gg3,ff1,ff2,ff3,ff4,alp,alp1,alp2
5231  REAL*8 xm,am,gamma
5232  COMPLEX bwign
5233  DATA pi /3.141592653589793238462643/
5234  DATA icont /0/
5235  DATA fpi /93.3e-3/
5236 C
5237 C
5238  bwign(xm,am,gamma)=xm**2/cmplx(xm**2-am**2,gamma*am)
5239 C
5240  amom=.782
5241  gamom=0.0085
5242 C
5243 C 6 BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
5244 C D**3 P /2E/(2PI)**3 (2PI)**4 DELTA4(SUM P)
5245  phspac=1./2**29/pi**14
5246 C PHSPAC=1./2**5/PI**2
5247 C INIT 5PI DECAY MODE (JNPI)
5248  amp1=dcdmas(idffin(1,jnpi))
5249  amp2=dcdmas(idffin(2,jnpi))
5250  amp3=dcdmas(idffin(3,jnpi))
5251  amp4=dcdmas(idffin(4,jnpi))
5252  amp5=dcdmas(idffin(5,jnpi))
5253 C
5254 C TAU MOMENTUM
5255  pt(1)=0.
5256  pt(2)=0.
5257  pt(3)=0.
5258  pt(4)=amtau
5259 C
5260  CALL ranmar(rrr,10)
5261 C
5262 C MASSES OF 5, 4, 3 AND 2 PI SYSTEMS
5263 C 3 PI WITH SAMPLING FOR OMEGA RESONANCE
5264 CAM
5265 C MASS OF 5 (12345)
5266  rr1=rrr(10)
5267  ams1=(amp1+amp2+amp3+amp4+amp5)**2
5268  ams2=(amtau-amnuta)**2
5269  am5sq=ams1+ rr1*(ams2-ams1)
5270  am5 =sqrt(am5sq)
5271  phspac=phspac*(ams2-ams1)
5272 C
5273 C MASS OF 4 (2345)
5274 C FLAT PHASE SPACE
5275  rr1=rrr(9)
5276  ams1=(amp2+amp3+amp4+amp5)**2
5277  ams2=(am5-amp1)**2
5278  am4sq=ams1+ rr1*(ams2-ams1)
5279  am4 =sqrt(am4sq)
5280  gg1=ams2-ams1
5281 C
5282 C MASS OF 3 (234)
5283 C PHASE SPACE WITH SAMPLING FOR OMEGA RESONANCE
5284  rr1=rrr(1)
5285  ams1=(amp2+amp3+amp4)**2
5286  ams2=(am4-amp5)**2
5287  alp1=atan((ams1-amom**2)/amom/gamom)
5288  alp2=atan((ams2-amom**2)/amom/gamom)
5289  alp=alp1+rr1*(alp2-alp1)
5290  am3sq =amom**2+amom*gamom*tan(alp)
5291  am3 =sqrt(am3sq)
5292 C --- THIS PART OF THE JACOBIAN WILL BE RECOVERED LATER ---------------
5293  gg2=((am3sq-amom**2)**2+(amom*gamom)**2)/(amom*gamom)
5294  gg2=gg2*(alp2-alp1)
5295 C FLAT PHASE SPACE;
5296 C AM3SQ=AMS1+ RR1*(AMS2-AMS1)
5297 C AM3 =SQRT(AM3SQ)
5298 C --- THIS PART OF JACOBIAN WILL BE RECOVERED LATER
5299 C GG2=AMS2-AMS1
5300 C
5301 C MASS OF 2 (34)
5302  rr2=rrr(2)
5303  ams1=(amp3+amp4)**2
5304  ams2=(am3-amp2)**2
5305 C FLAT PHASE SPACE;
5306  am2sq=ams1+ rr2*(ams2-ams1)
5307  am2 =sqrt(am2sq)
5308 C --- THIS PART OF JACOBIAN WILL BE RECOVERED LATER
5309  gg3=ams2-ams1
5310 C
5311 C (34) RESTFRAME, DEFINE PI3 AND PI4
5312  enq1=(am2sq+amp3**2-amp4**2)/(2*am2)
5313  enq2=(am2sq-amp3**2+amp4**2)/(2*am2)
5314  ppi= enq1**2-amp3**2
5315  pppi=sqrt(abs(enq1**2-amp3**2))
5316  ff1=(4*pi)*(2*pppi/am2)
5317 C PI3 MOMENTUM IN (34) REST FRAME
5318  CALL sphera(pppi,pi3)
5319  pi3(4)=enq1
5320 C PI4 MOMENTUM IN (34) REST FRAME
5321  DO 10 i=1,3
5322  10 pi4(i)=-pi3(i)
5323  pi4(4)=enq2
5324 C
5325 C (234) REST FRAME, DEFINE PI2
5326 C PR MOMENTUM
5327  pr(1)=0
5328  pr(2)=0
5329  pr(4)=1./(2*am3)*(am3**2+am2**2-amp2**2)
5330  pr(3)= sqrt(abs(pr(4)**2-am2**2))
5331  ppi = pr(4)**2-am2**2
5332 C PI2 MOMENTUM
5333  pi2(1)=0
5334  pi2(2)=0
5335  pi2(4)=1./(2*am3)*(am3**2-am2**2+amp2**2)
5336  pi2(3)=-pr(3)
5337 C --- THIS PART OF JACOBIAN WILL BE RECOVERED LATER
5338  ff2=(4*pi)*(2*pr(3)/am3)
5339 C OLD PIONS BOOSTED FROM 2 REST FRAME TO 3 REST FRAME
5340  exe=(pr(4)+pr(3))/am2
5341  CALL bostr3(exe,pi3,pi3)
5342  CALL bostr3(exe,pi4,pi4)
5343  rr3=rrr(3)
5344  rr4=rrr(4)
5345  thet =acos(-1.+2*rr3)
5346  phi = 2*pi*rr4
5347  CALL rotpol(thet,phi,pi2)
5348  CALL rotpol(thet,phi,pi3)
5349  CALL rotpol(thet,phi,pi4)
5350 C
5351 C (2345) REST FRAME, DEFINE PI5
5352 C PR MOMENTUM
5353  pr(1)=0
5354  pr(2)=0
5355  pr(4)=1./(2*am4)*(am4**2+am3**2-amp5**2)
5356  pr(3)= sqrt(abs(pr(4)**2-am3**2))
5357  ppi = pr(4)**2-am3**2
5358 C PI5 MOMENTUM
5359  pi5(1)=0
5360  pi5(2)=0
5361  pi5(4)=1./(2*am4)*(am4**2-am3**2+amp5**2)
5362  pi5(3)=-pr(3)
5363 C --- THIS PART OF JACOBIAN WILL BE RECOVERED LATER
5364  ff3=(4*pi)*(2*pr(3)/am4)
5365 C OLD PIONS BOOSTED FROM 3 REST FRAME TO 4 REST FRAME
5366  exe=(pr(4)+pr(3))/am3
5367  CALL bostr3(exe,pi2,pi2)
5368  CALL bostr3(exe,pi3,pi3)
5369  CALL bostr3(exe,pi4,pi4)
5370  rr3=rrr(5)
5371  rr4=rrr(6)
5372  thet =acos(-1.+2*rr3)
5373  phi = 2*pi*rr4
5374  CALL rotpol(thet,phi,pi2)
5375  CALL rotpol(thet,phi,pi3)
5376  CALL rotpol(thet,phi,pi4)
5377  CALL rotpol(thet,phi,pi5)
5378 C
5379 C (12345) REST FRAME, DEFINE PI1
5380 C PR MOMENTUM
5381  pr(1)=0
5382  pr(2)=0
5383  pr(4)=1./(2*am5)*(am5**2+am4**2-amp1**2)
5384  pr(3)= sqrt(abs(pr(4)**2-am4**2))
5385  ppi = pr(4)**2-am4**2
5386 C PI1 MOMENTUM
5387  pi1(1)=0
5388  pi1(2)=0
5389  pi1(4)=1./(2*am5)*(am5**2-am4**2+amp1**2)
5390  pi1(3)=-pr(3)
5391 C --- THIS PART OF JACOBIAN WILL BE RECOVERED LATER
5392  ff4=(4*pi)*(2*pr(3)/am5)
5393 C OLD PIONS BOOSTED FROM 4 REST FRAME TO 5 REST FRAME
5394  exe=(pr(4)+pr(3))/am4
5395  CALL bostr3(exe,pi2,pi2)
5396  CALL bostr3(exe,pi3,pi3)
5397  CALL bostr3(exe,pi4,pi4)
5398  CALL bostr3(exe,pi5,pi5)
5399  rr3=rrr(7)
5400  rr4=rrr(8)
5401  thet =acos(-1.+2*rr3)
5402  phi = 2*pi*rr4
5403  CALL rotpol(thet,phi,pi1)
5404  CALL rotpol(thet,phi,pi2)
5405  CALL rotpol(thet,phi,pi3)
5406  CALL rotpol(thet,phi,pi4)
5407  CALL rotpol(thet,phi,pi5)
5408 C
5409 * NOW TO THE TAU REST FRAME, DEFINE PAA AND NEUTRINO MOMENTA
5410 * PAA MOMENTUM
5411  paa(1)=0
5412  paa(2)=0
5413 C PAA(4)=1./(2*AMTAU)*(AMTAU**2-AMNUTA**2+AM5**2)
5414 C PAA(3)= SQRT(ABS(PAA(4)**2-AM5**2))
5415 C PPI = PAA(4)**2-AM5**2
5416  paa(4)=1./(2*amtau)*(amtau**2-amnuta**2+am5sq)
5417  paa(3)= sqrt(abs(paa(4)**2-am5sq))
5418  ppi = paa(4)**2-am5sq
5419  phspac=phspac*(4*pi)*(2*paa(3)/amtau)
5420 * TAU-NEUTRINO MOMENTUM
5421  pn(1)=0
5422  pn(2)=0
5423  pn(4)=1./(2*amtau)*(amtau**2+amnuta**2-am5**2)
5424  pn(3)=-paa(3)
5425 C
5426  phspac=phspac * gg1*gg2*gg3*ff1*ff2*ff3*ff4
5427 C
5428 C ALL PIONS BOOSTED FROM 5 REST FRAME TO TAU REST FRAME
5429 C Z-AXIS ANTIPARALLEL TO NEUTRINO MOMENTUM
5430  exe=(paa(4)+paa(3))/am5
5431  CALL bostr3(exe,pi1,pi1)
5432  CALL bostr3(exe,pi2,pi2)
5433  CALL bostr3(exe,pi3,pi3)
5434  CALL bostr3(exe,pi4,pi4)
5435  CALL bostr3(exe,pi5,pi5)
5436 C
5437 C PARTIAL WIDTH CONSISTS OF PHASE SPACE AND AMPLITUDE
5438 C AMPLITUDE (CF YS.TSAI PHYS.REV.D4,2821(1971)
5439 C OR F.GILMAN SH.RHIE PHYS.REV.D31,1066(1985)
5440 C
5441  pxq=amtau*paa(4)
5442  pxn=amtau*pn(4)
5443  qxn=paa(4)*pn(4)-paa(1)*pn(1)-paa(2)*pn(2)-paa(3)*pn(3)
5444  brak=2*(gv**2+ga**2)*(2*pxq*qxn+am5sq*pxn)
5445  + -6*(gv**2-ga**2)*amtau*amnuta*am5sq
5446  fompp = cabs(bwign(am3,amom,gamom))**2
5447 C NORMALISATION FACTOR (TO SOME NUMERICAL UNDIMENSIONED FACTOR;
5448 C CF R.FISCHER ET AL ZPHYS C3, 313 (1980))
5449  fnorm = 1/fpi**6
5450 C AMPLIT=CCABIB**2*GFERMI**2/2. * BRAK * AM5SQ*SIGEE(AM5SQ,JNPI)
5451  amplit=ccabib**2*gfermi**2/2. * brak
5452  amplit = amplit * fompp * fnorm
5453 C PHASE SPACE TEST
5454 C AMPLIT = AMPLIT * FNORM
5455  dgamt=1/(2.*amtau)*amplit*phspac
5456 C IGNORE SPIN TERMS
5457  DO 20 i=1,3
5458  20 hv(i)=0.
5459 C
5460  DO 30 k=1,4
5461  pmult(k,1)=pi1(k)
5462  pmult(k,2)=pi2(k)
5463  pmult(k,3)=pi3(k)
5464  pmult(k,4)=pi4(k)
5465  pmult(k,5)=pi5(k)
5466  30 CONTINUE
5467  RETURN
5468 C MISSING: TRANSPOSITION OF IDENTICAL PARTICLES, STARTISTICAL FACTORS
5469 C FOR IDENTICAL MATRICES, POLARIMETRIC VECTOR. MATRIX ELEMENT RATHER NAIVE.
5470 C FLAT PHASE SPACE IN PION SYSTEM + WITH BREIT WIGNER FOR OMEGA
5471 C ANYWAY IT IS BETTER THAN NOTHING, AND CODE IS IMPROVABLE.
5472  END
5473 *CMZ : 1.01/50 22/05/96 18.06.08 by Piero Zucchelli
5474 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
5475 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
5476 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
5477 *-- AUTHOR :
5478  SUBROUTINE dphnpi(DGAMT,HVX,PNX,PRX,PPIX,JNPI)
5479 C ----------------------------------------------------------------------
5480 C IT SIMULATES MULTIPI DECAY IN TAU REST FRAME WITH
5481 C Z-AXIS OPPOSITE TO NEUTRINO MOMENTUM
5482 C ----------------------------------------------------------------------
5483  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
5484  + ,ampiz,ampi,amro,gamro,ama1,gama1
5485  + ,amk,amkz,amkst,gamkst
5486 C
5487  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
5488  + ,ampiz,ampi,amro,gamro,ama1,gama1
5489  + ,amk,amkz,amkst,gamkst
5490  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
5491  REAL*4 gfermi,gv,ga,ccabib,scabib,gamel
5492  parameter(nmode=15,nm1=0,nm2=1,nm3=8,nm4=2,nm5=1,nm6=3)
5493  COMMON / mdecomp /idffin(9,nmode),mulpik(nmode)
5494  + ,names
5495  CHARACTER names(nmode)*31
5496  REAL*8 wetmax(20)
5497 C
5498  REAL*8 pn(4),pr(4),ppi(4,9),hv(4)
5499  REAL*4 pnx(4),prx(4),ppix(4,9),hvx(4)
5500  REAL*8 pv(5,9),pt(4),ue(3),be(3)
5501  REAL*8 pawt,amx,ams1,ams2,pa,phs,phsmax,pmin,pmax
5502  REAL*8 gam,bep,phi,a,b,c
5503  REAL*8 ampik
5504  REAL*4 rrr(9),rrx(2),rtemp(1)
5505 C
5506  DATA pi /3.141592653589793238462643/
5507  DATA wetmax /20*1d-15/
5508 C
5509 CC-- PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2.*A)
5510 C
5511  pawt(a,b,c)=
5512  + sqrt(max(0.d0,(a**2-(b+c)**2)*(a**2-(b-c)**2)))/(2.d0*a)
5513 C
5514  ampik(i,j)=dcdmas(idffin(i,j))
5515 C
5516 C
5517  IF ((jnpi.LE.0).OR.jnpi.GT.20) THEN
5518  WRITE(6,*) 'JNPI OUTSIDE RANGE DEFINED BY WETMAX; JNPI=',jnpi
5519  stop
5520  ENDIF
5521 
5522 C TAU MOMENTUM
5523  pt(1)=0.
5524  pt(2)=0.
5525  pt(3)=0.
5526  pt(4)=amtau
5527 C
5528  10 CONTINUE
5529 C MASS OF VIRTUAL W
5530  nd=mulpik(jnpi)
5531  ps=0.
5532  phspac = 1./2.**5 /pi**2
5533  DO 20 i=1,nd
5534  20 ps =ps+ampik(i,jnpi)
5535  rtemp(1)=rr1
5536  CALL ranmar(rtemp,1)
5537  rr1=rtemp(1)
5538  ams1=ps**2
5539  ams2=(amtau-amnuta)**2
5540 C
5541 C
5542  amx2=ams1+ rr1*(ams2-ams1)
5543  amx =sqrt(amx2)
5544  amw =amx
5545  phspac=phspac * (ams2-ams1)
5546 C
5547 C TAU-NEUTRINO MOMENTUM
5548  pn(1)=0
5549  pn(2)=0
5550  pn(4)=1./(2*amtau)*(amtau**2+amnuta**2-amx2)
5551  pn(3)=-sqrt((pn(4)-amnuta)*(pn(4)+amnuta))
5552 C W MOMENTUM
5553  pr(1)=0
5554  pr(2)=0
5555  pr(4)=1./(2*amtau)*(amtau**2-amnuta**2+amx2)
5556  pr(3)=-pn(3)
5557  phspac=phspac * (4.*pi) * (2.*pr(3)/amtau)
5558 C
5559 C AMPLITUDE (CF YS.TSAI PHYS.REV.D4,2821(1971)
5560 C OR F.GILMAN SH.RHIE PHYS.REV.D31,1066(1985)
5561 C
5562  pxq=amtau*pr(4)
5563  pxn=amtau*pn(4)
5564  qxn=pr(4)*pn(4)-pr(1)*pn(1)-pr(2)*pn(2)-pr(3)*pn(3)
5565 C HERE WAS AN ERROR. 20.10.91 (ZW)
5566 C BRAK=2*(GV**2+GA**2)*(2*PXQ*PXN+AMX2*QXN)
5567  brak=2*(gv**2+ga**2)*(2*pxq*qxn+amx2*pxn) -6*(gv**2-ga**2)*amtau*
5568  +amnuta*amx2
5569 CAM ASSUME NEUTRINO MASS=0. AND SUM OVER FINAL POLARISATION
5570 C BRAK= 2*(AMTAU**2-AMX2) * (AMTAU**2+2.*AMX2)
5571  amplit=ccabib**2*gfermi**2/2. * brak * amx2*sigee(amx2,jnpi)
5572  dgamt=1./(2.*amtau)*amplit*phspac
5573 C
5574 C ISOTROPIC W DECAY IN W REST FRAME
5575  phsmax = 1.
5576  DO 30 i=1,4
5577  30 pv(i,1)=pr(i)
5578  pv(5,1)=amw
5579  pv(5,nd)=ampik(nd,jnpi)
5580 C COMPUTE MAX. PHASE SPACE FACTOR
5581  pmax=amw-ps+ampik(nd,jnpi)
5582  pmin=.0
5583  DO 40 il=nd-1,1,-1
5584  pmax=pmax+ampik(il,jnpi)
5585  pmin=pmin+ampik(il+1,jnpi)
5586  40 phsmax=phsmax*pawt(pmax,pmin,ampik(il,jnpi))/pmax
5587 
5588 C --- 2.02.94 ZW 9 LINES
5589  amx=amw
5590  DO 60 il=1,nd-2
5591  ams1=.0
5592  DO 50 jl=il+1,nd
5593  50 ams1=ams1+ampik(jl,jnpi)
5594  ams1=ams1**2
5595  amx =(amx-ampik(il,jnpi))
5596  ams2=(amx)**2
5597  phsmax=phsmax * (ams2-ams1)
5598  60 CONTINUE
5599  ncont=0
5600  70 CONTINUE
5601  ncont=ncont+1
5602 CAM GENERATE ND-2 EFFECTIVE MASSES
5603  phs=1.d0
5604  phspac = 1./2.**(6*nd-7) /pi**(3*nd-4)
5605  amx=amw
5606  CALL ranmar(rrr,nd-2)
5607  DO 90 il=1,nd-2
5608  ams1=.0d0
5609  DO 80 jl=il+1,nd
5610  80 ams1=ams1+ampik(jl,jnpi)
5611  ams1=ams1**2
5612  ams2=(amx-ampik(il,jnpi))**2
5613  rr1=rrr(il)
5614  amx2=ams1+ rr1*(ams2-ams1)
5615  amx=sqrt(amx2)
5616  pv(5,il+1)=amx
5617  phspac=phspac * (ams2-ams1)
5618 C --- 2.02.94 ZW 1 LINE
5619  phs=phs* (ams2-ams1)
5620  pa=pawt(pv(5,il),pv(5,il+1),ampik(il,jnpi))
5621  phs =phs *pa/pv(5,il)
5622  90 CONTINUE
5623  pa=pawt(pv(5,nd-1),ampik(nd-1,jnpi),ampik(nd,jnpi))
5624  phs =phs *pa/pv(5,nd-1)
5625  rtemp(1)=rn
5626  CALL ranmar(rtemp,1)
5627  rn=rtemp(1)
5628  wetmax(jnpi)=1.2d0*max(wetmax(jnpi)/1.2d0,phs/phsmax)
5629  IF (ncont.EQ.500 000) THEN
5630  xnpi=0.0
5631  DO kk=1,nd
5632  xnpi=xnpi+ampik(kk,jnpi)
5633  ENDDO
5634  WRITE(6,*) 'ROUNDING INSTABILITY IN DPHNPI ?'
5635  WRITE(6,*) 'AMW=',amw,'XNPI=',xnpi
5636  WRITE(6,*) 'IF =AMW= IS NEARLY EQUAL =XNPI= THAT IS IT'
5637  WRITE(6,*) 'PHS=',phs,'PHSMAX=',phsmax
5638  goto 10
5639  ENDIF
5640  IF(rn*phsmax*wetmax(jnpi).GT.phs) go to 70
5641 C...PERFORM SUCCESSIVE TWO-PARTICLE DECAYS IN RESPECTIVE CM FRAME
5642  100 DO 120 il=1,nd-1
5643  pa=pawt(pv(5,il),pv(5,il+1),ampik(il,jnpi))
5644  CALL ranmar(rrx,2)
5645  ue(3)=2.*rrx(1)-1.
5646  phi=2.*pi*rrx(2)
5647  ue(1)=sqrt(1.d0-ue(3)**2)*cos(phi)
5648  ue(2)=sqrt(1.d0-ue(3)**2)*sin(phi)
5649  DO 110 j=1,3
5650  ppi(j,il)=pa*ue(j)
5651  110 pv(j,il+1)=-pa*ue(j)
5652  ppi(4,il)=sqrt(pa**2+ampik(il,jnpi)**2)
5653  pv(4,il+1)=sqrt(pa**2+pv(5,il+1)**2)
5654  phspac=phspac *(4.*pi)*(2.*pa/pv(5,il))
5655  120 CONTINUE
5656 C...LORENTZ TRANSFORM DECAY PRODUCTS TO TAU FRAME
5657  DO 130 j=1,4
5658  130 ppi(j,nd)=pv(j,nd)
5659  DO 160 il=nd-1,1,-1
5660  DO 140 j=1,3
5661  140 be(j)=pv(j,il)/pv(4,il)
5662  gam=pv(4,il)/pv(5,il)
5663  DO 160 i=il,nd
5664  bep=be(1)*ppi(1,i)+be(2)*ppi(2,i)+be(3)*ppi(3,i)
5665  DO 150 j=1,3
5666  150 ppi(j,i)=ppi(j,i)+gam*(gam*bep/(1.d0+gam)+ppi(4,i))*be(j)
5667  ppi(4,i)=gam*(ppi(4,i)+bep)
5668  160 CONTINUE
5669 C
5670  hv(4)=1.
5671  hv(3)=0.
5672  hv(2)=0.
5673  hv(1)=0.
5674  DO k=1,4
5675  pnx(k)=pn(k)
5676  prx(k)=pr(k)
5677  hvx(k)=hv(k)
5678  DO l=1,nd
5679  ppix(k,l)=ppi(k,l)
5680  ENDDO
5681  ENDDO
5682  RETURN
5683  END
5684 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
5685 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
5686 *-- AUTHOR :
5687  SUBROUTINE dphsaa(DGAMT,HV,PN,PAA,PIM1,PIM2,PIPL,JAA)
5688 C ----------------------------------------------------------------------
5689 * IT SIMULATES A1 DECAY IN TAU REST FRAME WITH
5690 * Z-AXIS ALONG A1 MOMENTUM
5691 C ----------------------------------------------------------------------
5692  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
5693  + ,ampiz,ampi,amro,gamro,ama1,gama1
5694  + ,amk,amkz,amkst,gamkst
5695 C
5696  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
5697  + ,ampiz,ampi,amro,gamro,ama1,gama1
5698  + ,amk,amkz,amkst,gamkst
5699  COMMON / taukle / bra1,brk0,brk0b,brks
5700  REAL*4 bra1,brk0,brk0b,brks
5701  REAL hv(4),pn(4),paa(4),pim1(4),pim2(4),pipl(4)
5702 
5703 
5704  REAL*4 rrr(1)
5705 C MATRIX ELEMENT NUMBER:
5706  mnum=0
5707 C TYPE OF THE GENERATION:
5708  keyt=1
5709  CALL ranmar(rrr,1)
5710  rmod=rrr(1)
5711  IF (rmod.LT.bra1) THEN
5712  jaa=1
5713  amp1=ampi
5714  amp2=ampi
5715  amp3=ampi
5716  ELSE
5717  jaa=2
5718  amp1=ampiz
5719  amp2=ampiz
5720  amp3=ampi
5721  ENDIF
5722 
5723  CALL
5724  + dphtre(dgamt,hv,pn,paa,pim1,amp1,pim2,amp2,pipl,amp3,keyt,mnum)
5725  END
5726 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
5727 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
5728 *-- AUTHOR :
5729  SUBROUTINE dphsel(DGAMX,HVX,XNX,PAAX,QPX,XAX,PHX)
5730 C XNX,XNA WAS FLIPPED IN PARAMETERS OF DPHSEL AND DPHSMU
5731 C *********************************************************************
5732 C * ELECTRON DECAY MODE *
5733 C *********************************************************************
5734  REAL*4 phx(4)
5735  REAL*4 hvx(4),paax(4),xax(4),qpx(4),xnx(4)
5736  REAL*8 hv(4),ph(4),paa(4),xa(4),qp(4),xn(4)
5737  REAL*8 dgamt
5738  ielmu=1
5739  CALL drcmu(dgamt,hv,ph,paa,xa,qp,xn,ielmu)
5740  DO 10 k=1,4
5741  hvx(k)=hv(k)
5742  phx(k)=ph(k)
5743  paax(k)=paa(k)
5744  xax(k)=xa(k)
5745  qpx(k)=qp(k)
5746  xnx(k)=xn(k)
5747  10 CONTINUE
5748  dgamx=dgamt
5749  END
5750 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
5751 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
5752 *-- AUTHOR :
5753  SUBROUTINE dphsks(DGAMT,HV,PN,PKS,PKK,PPI,JKST)
5754 C ----------------------------------------------------------------------
5755 C IT SIMULATES KAON* DECAY IN TAU REST FRAME WITH
5756 C Z-AXIS ALONG KAON* MOMENTUM
5757 C JKST=10 FOR K* --->K0 + PI+-
5758 C JKST=20 FOR K* --->K+- + PI0
5759 C ----------------------------------------------------------------------
5760  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
5761  REAL*4 gfermi,gv,ga,ccabib,scabib,gamel
5762  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
5763  * ,ampiz,ampi,amro,gamro,ama1,gama1
5764  * ,amk,amkz,amkst,gamkst
5765 C
5766  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
5767  * ,ampiz,ampi,amro,gamro,ama1,gama1
5768  * ,amk,amkz,amkst,gamkst
5769  REAL hv(4),pt(4),pn(4),pks(4),pkk(4),ppi(4),qq(4)
5770  COMPLEX bwigs
5771  DATA pi /3.141592653589793238462643/
5772 C
5773  DATA icont /0/
5774 C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
5775  phspac=1./2**11/pi**5
5776 C TAU MOMENTUM
5777  pt(1)=0.
5778  pt(2)=0.
5779  pt(3)=0.
5780  pt(4)=amtau
5781  CALL ranmar(rr1,1)
5782 C HERE BEGIN THE K0,PI+_ DECAY
5783  IF(jkst.EQ.10)THEN
5784 C ==================
5785 C MASS OF (REAL/VIRTUAL) K*
5786  ams1=(ampi+amkz)**2
5787  ams2=(amtau-amnuta)**2
5788 C FLAT PHASE SPACE
5789 C AMX2=AMS1+ RR1*(AMS2-AMS1)
5790 C AMX=SQRT(AMX2)
5791 C PHSPAC=PHSPAC*(AMS2-AMS1)
5792 C PHASE SPACE WITH SAMPLING FOR K* RESONANCE
5793  alp1=atan((ams1-amkst**2)/amkst/gamkst)
5794  alp2=atan((ams2-amkst**2)/amkst/gamkst)
5795  alp=alp1+rr1*(alp2-alp1)
5796  amx2=amkst**2+amkst*gamkst*tan(alp)
5797  amx=sqrt(amx2)
5798  phspac=phspac*((amx2-amkst**2)**2+(amkst*gamkst)**2)
5799  & /(amkst*gamkst)
5800  phspac=phspac*(alp2-alp1)
5801 C
5802 C TAU-NEUTRINO MOMENTUM
5803  pn(1)=0
5804  pn(2)=0
5805  pn(4)=1./(2*amtau)*(amtau**2+amnuta**2-amx**2)
5806  pn(3)=-sqrt((pn(4)-amnuta)*(pn(4)+amnuta))
5807 C
5808 C K* MOMENTUM
5809  pks(1)=0
5810  pks(2)=0
5811  pks(4)=1./(2*amtau)*(amtau**2-amnuta**2+amx**2)
5812  pks(3)=-pn(3)
5813  phspac=phspac*(4*pi)*(2*pks(3)/amtau)
5814 C
5815 CAM
5816  enpi=( amx**2+ampi**2-amkz**2 ) / ( 2*amx )
5817  pppi=sqrt((enpi-ampi)*(enpi+ampi))
5818  phspac=phspac*(4*pi)*(2*pppi/amx)
5819 C CHARGED PI MOMENTUM IN KAON* REST FRAME
5820  CALL sphera(pppi,ppi)
5821  ppi(4)=enpi
5822 C NEUTRAL KAON MOMENTUM IN K* REST FRAME
5823  DO 10 i=1,3
5824  10 pkk(i)=-ppi(i)
5825  pkk(4)=( amx**2+amkz**2-ampi**2 ) / ( 2*amx )
5826  exe=(pks(4)+pks(3))/amx
5827 C PION AND K BOOSTED FROM K* REST FRAME TO TAU REST FRAME
5828  CALL bostr3(exe,ppi,ppi)
5829  CALL bostr3(exe,pkk,pkk)
5830  DO 20 i=1,4
5831  20 qq(i)=ppi(i)-pkk(i)
5832 C QQ TRANSVERSE TO PKS
5833  pksd =pks(4)*pks(4)-pks(3)*pks(3)-pks(2)*pks(2)-pks(1)*pks(1)
5834  qqpks=pks(4)* qq(4)-pks(3)* qq(3)-pks(2)* qq(2)-pks(1)* qq(1)
5835  DO 30 i=1,4
5836  30 qq(i)=qq(i)-pks(i)*qqpks/pksd
5837 C AMPLITUDE
5838  prodpq=pt(4)*qq(4)
5839  prodnq=pn(4)*qq(4)-pn(1)*qq(1)-pn(2)*qq(2)-pn(3)*qq(3)
5840  prodpn=pt(4)*pn(4)
5841  qq2= qq(4)**2-qq(1)**2-qq(2)**2-qq(3)**2
5842  brak=(gv**2+ga**2)*(2*prodpq*prodnq-prodpn*qq2)
5843  & +(gv**2-ga**2)*amtau*amnuta*qq2
5844 C A SIMPLE BREIT-WIGNER IS CHOSEN FOR K* RESONANCE
5845  fks=cabs(bwigs(amx2,amkst,gamkst))**2
5846  amplit=(gfermi*scabib)**2*brak*2*fks
5847  dgamt=1/(2.*amtau)*amplit*phspac
5848  DO 40 i=1,3
5849  40 hv(i)=2*gv*ga*amtau*(2*prodnq*qq(i)-qq2*pn(i))/brak
5850 C
5851 C HERE BEGIN THE K+-,PI0 DECAY
5852  ELSEIF(jkst.EQ.20)THEN
5853 C ======================
5854 C MASS OF (REAL/VIRTUAL) K*
5855  ams1=(ampiz+amk)**2
5856  ams2=(amtau-amnuta)**2
5857 C FLAT PHASE SPACE
5858 C AMX2=AMS1+ RR1*(AMS2-AMS1)
5859 C AMX=SQRT(AMX2)
5860 C PHSPAC=PHSPAC*(AMS2-AMS1)
5861 C PHASE SPACE WITH SAMPLING FOR K* RESONANCE
5862  alp1=atan((ams1-amkst**2)/amkst/gamkst)
5863  alp2=atan((ams2-amkst**2)/amkst/gamkst)
5864  alp=alp1+rr1*(alp2-alp1)
5865  amx2=amkst**2+amkst*gamkst*tan(alp)
5866  amx=sqrt(amx2)
5867  phspac=phspac*((amx2-amkst**2)**2+(amkst*gamkst)**2)
5868  & /(amkst*gamkst)
5869  phspac=phspac*(alp2-alp1)
5870 C
5871 C TAU-NEUTRINO MOMENTUM
5872  pn(1)=0
5873  pn(2)=0
5874  pn(4)=1./(2*amtau)*(amtau**2+amnuta**2-amx**2)
5875  pn(3)=-sqrt((pn(4)-amnuta)*(pn(4)+amnuta))
5876 C KAON* MOMENTUM
5877  pks(1)=0
5878  pks(2)=0
5879  pks(4)=1./(2*amtau)*(amtau**2-amnuta**2+amx**2)
5880  pks(3)=-pn(3)
5881  phspac=phspac*(4*pi)*(2*pks(3)/amtau)
5882 C
5883 CAM
5884  enpi=( amx**2+ampiz**2-amk**2 ) / ( 2*amx )
5885  pppi=sqrt((enpi-ampiz)*(enpi+ampiz))
5886  phspac=phspac*(4*pi)*(2*pppi/amx)
5887 C NEUTRAL PI MOMENTUM IN K* REST FRAME
5888  CALL sphera(pppi,ppi)
5889  ppi(4)=enpi
5890 C CHARGED KAON MOMENTUM IN K* REST FRAME
5891  DO 50 i=1,3
5892  50 pkk(i)=-ppi(i)
5893  pkk(4)=( amx**2+amk**2-ampiz**2 ) / ( 2*amx )
5894  exe=(pks(4)+pks(3))/amx
5895 C PION AND K BOOSTED FROM K* REST FRAME TO TAU REST FRAME
5896  CALL bostr3(exe,ppi,ppi)
5897  CALL bostr3(exe,pkk,pkk)
5898  DO 60 i=1,4
5899  60 qq(i)=pkk(i)-ppi(i)
5900 C QQ TRANSVERSE TO PKS
5901  pksd =pks(4)*pks(4)-pks(3)*pks(3)-pks(2)*pks(2)-pks(1)*pks(1)
5902  qqpks=pks(4)* qq(4)-pks(3)* qq(3)-pks(2)* qq(2)-pks(1)* qq(1)
5903  DO 70 i=1,4
5904  70 qq(i)=qq(i)-pks(i)*qqpks/pksd
5905 C AMPLITUDE
5906  prodpq=pt(4)*qq(4)
5907  prodnq=pn(4)*qq(4)-pn(1)*qq(1)-pn(2)*qq(2)-pn(3)*qq(3)
5908  prodpn=pt(4)*pn(4)
5909  qq2= qq(4)**2-qq(1)**2-qq(2)**2-qq(3)**2
5910  brak=(gv**2+ga**2)*(2*prodpq*prodnq-prodpn*qq2)
5911  & +(gv**2-ga**2)*amtau*amnuta*qq2
5912 C A SIMPLE BREIT-WIGNER IS CHOSEN FOR THE K* RESONANCE
5913  fks=cabs(bwigs(amx2,amkst,gamkst))**2
5914  amplit=(gfermi*scabib)**2*brak*2*fks
5915  dgamt=1/(2.*amtau)*amplit*phspac
5916  DO 80 i=1,3
5917  80 hv(i)=2*gv*ga*amtau*(2*prodnq*qq(i)-qq2*pn(i))/brak
5918  ENDIF
5919  RETURN
5920  END
5921 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
5922 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
5923 *-- AUTHOR :
5924  SUBROUTINE dphsmu(DGAMX,HVX,XNX,PAAX,QPX,XAX,PHX)
5925 C XNX,XNA WAS FLIPPED IN PARAMETERS OF DPHSEL AND DPHSMU
5926 C *********************************************************************
5927 C * MUON DECAY MODE *
5928 C *********************************************************************
5929  REAL*4 phx(4)
5930  REAL*4 hvx(4),paax(4),xax(4),qpx(4),xnx(4)
5931  REAL*8 hv(4),ph(4),paa(4),xa(4),qp(4),xn(4)
5932  REAL*8 dgamt
5933  ielmu=2
5934  CALL drcmu(dgamt,hv,ph,paa,xa,qp,xn,ielmu)
5935  DO 10 k=1,4
5936  hvx(k)=hv(k)
5937  phx(k)=ph(k)
5938  paax(k)=paa(k)
5939  xax(k)=xa(k)
5940  qpx(k)=qp(k)
5941  xnx(k)=xn(k)
5942  10 CONTINUE
5943  dgamx=dgamt
5944  END
5945 *CMZ : 1.01/50 22/05/96 18.06.08 by Piero Zucchelli
5946 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
5947 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
5948 *-- AUTHOR :
5949  SUBROUTINE dphspk(DGAMT,HV,PN,PAA,PNPI,JAA)
5950 C ----------------------------------------------------------------------
5951 * IT SIMULATES THREE PI (K) DECAY IN THE TAU REST FRAME
5952 * Z-AXIS ALONG HADRONIC SYSTEM
5953 C ----------------------------------------------------------------------
5954  parameter(nmode=15,nm1=0,nm2=1,nm3=8,nm4=2,nm5=1,nm6=3)
5955  COMMON / mdecomp /idffin(9,nmode),mulpik(nmode)
5956  + ,names
5957  CHARACTER names(nmode)*31
5958 
5959  REAL hv(4),pn(4),paa(4),pim1(4),pim2(4),pipl(4),pnpi(4,9)
5960 C MATRIX ELEMENT NUMBER:
5961  mnum=jaa
5962 C TYPE OF THE GENERATION:
5963  keyt=4
5964  IF(jaa.EQ.7) keyt=3
5965 C --- MASSES OF THE DECAY PRODUCTS
5966  amp1=dcdmas(idffin(1,jaa+nm4+nm5+nm6))
5967  amp2=dcdmas(idffin(2,jaa+nm4+nm5+nm6))
5968  amp3=dcdmas(idffin(3,jaa+nm4+nm5+nm6))
5969  CALL
5970  + dphtre(dgamt,hv,pn,paa,pim1,amp1,pim2,amp2,pipl,amp3,keyt,mnum)
5971  DO i=1,4
5972  pnpi(i,1)=pim1(i)
5973  pnpi(i,2)=pim2(i)
5974  pnpi(i,3)=pipl(i)
5975  ENDDO
5976  END
5977 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
5978 *CMZ : 1.01/08 05/03/95 11.39.27 BY PIERO ZUCCHELLI
5979 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
5980 *-- AUTHOR :
5981  SUBROUTINE dphsrk(DGAMT,HV,PN,PR,PMULT,INUM)
5982 C ----------------------------------------------------------------------
5983 C IT SIMULATES RHO DECAY IN TAU REST FRAME WITH
5984 C Z-AXIS ALONG RHO MOMENTUM
5985 C RHO DECAYS TO K KBAR
5986 C ----------------------------------------------------------------------
5987  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
5988  + ,ampiz,ampi,amro,gamro,ama1,gama1
5989  + ,amk,amkz,amkst,gamkst
5990 C
5991  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
5992  + ,ampiz,ampi,amro,gamro,ama1,gama1
5993  + ,amk,amkz,amkst,gamkst
5994  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
5995  REAL*4 gfermi,gv,ga,ccabib,scabib,gamel
5996  REAL hv(4),pt(4),pn(4),pr(4),pkc(4),pkz(4),qq(4),pmult(4,9)
5997  DATA pi /3.141592653589793238462643/
5998  DATA icont /0/
5999 C
6000 C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
6001  phspac=1./2**11/pi**5
6002 C TAU MOMENTUM
6003  pt(1)=0.
6004  pt(2)=0.
6005  pt(3)=0.
6006  pt(4)=amtau
6007 C MASS OF (REAL/VIRTUAL) RHO
6008  ams1=(amk+amkz)**2
6009  ams2=(amtau-amnuta)**2
6010 C FLAT PHASE SPACE
6011  CALL ranmar(rr1,1)
6012  amx2=ams1+ rr1*(ams2-ams1)
6013  amx=sqrt(amx2)
6014  phspac=phspac*(ams2-ams1)
6015 C PHASE SPACE WITH SAMPLING FOR RHO RESONANCE
6016 C ALP1=ATAN((AMS1-AMRO**2)/AMRO/GAMRO)
6017 C ALP2=ATAN((AMS2-AMRO**2)/AMRO/GAMRO)
6018 CAM
6019  10 CONTINUE
6020 C CALL RANMAR(RR1,1)
6021 C ALP=ALP1+RR1*(ALP2-ALP1)
6022 C AMX2=AMRO**2+AMRO*GAMRO*TAN(ALP)
6023 C AMX=SQRT(AMX2)
6024 C IF(AMX.LT.(AMK+AMKZ)) GO TO 100
6025 CAM
6026 C PHSPAC=PHSPAC*((AMX2-AMRO**2)**2+(AMRO*GAMRO)**2)/(AMRO*GAMRO)
6027 C PHSPAC=PHSPAC*(ALP2-ALP1)
6028 C
6029 C TAU-NEUTRINO MOMENTUM
6030  pn(1)=0
6031  pn(2)=0
6032  pn(4)=1./(2*amtau)*(amtau**2+amnuta**2-amx**2)
6033  pn(3)=-sqrt((pn(4)-amnuta)*(pn(4)+amnuta))
6034 C RHO MOMENTUM
6035  pr(1)=0
6036  pr(2)=0
6037  pr(4)=1./(2*amtau)*(amtau**2-amnuta**2+amx**2)
6038  pr(3)=-pn(3)
6039  phspac=phspac*(4*pi)*(2*pr(3)/amtau)
6040 C
6041 CAM
6042  enq1=(amx2+amk**2-amkz**2)/(2.*amx)
6043  enq2=(amx2-amk**2+amkz**2)/(2.*amx)
6044  pppi=sqrt((enq1-amk)*(enq1+amk))
6045  phspac=phspac*(4*pi)*(2*pppi/amx)
6046 C CHARGED PI MOMENTUM IN RHO REST FRAME
6047  CALL sphera(pppi,pkc)
6048  pkc(4)=enq1
6049 C NEUTRAL PI MOMENTUM IN RHO REST FRAME
6050  DO 20 i=1,3
6051  20 pkz(i)=-pkc(i)
6052  pkz(4)=enq2
6053  exe=(pr(4)+pr(3))/amx
6054 C PIONS BOOSTED FROM RHO REST FRAME TO TAU REST FRAME
6055  CALL bostr3(exe,pkc,pkc)
6056  CALL bostr3(exe,pkz,pkz)
6057  DO 30 i=1,4
6058  30 qq(i)=pkc(i)-pkz(i)
6059 C QQ TRANSVERSE TO PR
6060  pksd =pr(4)*pr(4)-pr(3)*pr(3)-pr(2)*pr(2)-pr(1)*pr(1)
6061  qqpks=pr(4)* qq(4)-pr(3)* qq(3)-pr(2)* qq(2)-pr(1)* qq(1)
6062  DO 40 i=1,4
6063  40 qq(i)=qq(i)-pr(i)*qqpks/pksd
6064 C AMPLITUDE
6065  prodpq=pt(4)*qq(4)
6066  prodnq=pn(4)*qq(4)-pn(1)*qq(1)-pn(2)*qq(2)-pn(3)*qq(3)
6067  prodpn=pt(4)*pn(4)
6068  qq2= qq(4)**2-qq(1)**2-qq(2)**2-qq(3)**2
6069  brak=(gv**2+ga**2)*(2*prodpq*prodnq-prodpn*qq2)
6070  + +(gv**2-ga**2)*amtau*amnuta*qq2
6071  amplit=(gfermi*ccabib)**2*brak*2*fpirk(amx)
6072  dgamt=1/(2.*amtau)*amplit*phspac
6073  DO 50 i=1,3
6074  50 hv(i)=2*gv*ga*amtau*(2*prodnq*qq(i)-qq2*pn(i))/brak
6075  DO 60 k=1,4
6076  pmult(k,1)=pkc(k)
6077  pmult(k,2)=pkz(k)
6078  60 CONTINUE
6079  RETURN
6080  END
6081 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
6082 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
6083 *-- AUTHOR :
6084  SUBROUTINE dphsro(DGAMT,HV,PN,PR,PIC,PIZ)
6085 C ----------------------------------------------------------------------
6086 C IT SIMULATES RHO DECAY IN TAU REST FRAME WITH
6087 C Z-AXIS ALONG RHO MOMENTUM
6088 C ----------------------------------------------------------------------
6089  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
6090  * ,ampiz,ampi,amro,gamro,ama1,gama1
6091  * ,amk,amkz,amkst,gamkst
6092 C
6093  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
6094  * ,ampiz,ampi,amro,gamro,ama1,gama1
6095  * ,amk,amkz,amkst,gamkst
6096  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
6097  REAL*4 gfermi,gv,ga,ccabib,scabib,gamel
6098  REAL hv(4),pt(4),pn(4),pr(4),pic(4),piz(4),qq(4)
6099  DATA pi /3.141592653589793238462643/
6100  DATA icont /0/
6101 C
6102 C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
6103  phspac=1./2**11/pi**5
6104 C TAU MOMENTUM
6105  pt(1)=0.
6106  pt(2)=0.
6107  pt(3)=0.
6108  pt(4)=amtau
6109 C MASS OF (REAL/VIRTUAL) RHO
6110  ams1=(ampi+ampiz)**2
6111  ams2=(amtau-amnuta)**2
6112 C FLAT PHASE SPACE
6113 C AMX2=AMS1+ RR1*(AMS2-AMS1)
6114 C AMX=SQRT(AMX2)
6115 C PHSPAC=PHSPAC*(AMS2-AMS1)
6116 C PHASE SPACE WITH SAMPLING FOR RHO RESONANCE
6117  alp1=atan((ams1-amro**2)/amro/gamro)
6118  alp2=atan((ams2-amro**2)/amro/gamro)
6119 CAM
6120  10 CONTINUE
6121  CALL ranmar(rr1,1)
6122  alp=alp1+rr1*(alp2-alp1)
6123  amx2=amro**2+amro*gamro*tan(alp)
6124  amx=sqrt(amx2)
6125  IF(amx.LT.2.*ampi) go to 10
6126 CAM
6127  phspac=phspac*((amx2-amro**2)**2+(amro*gamro)**2)/(amro*gamro)
6128  phspac=phspac*(alp2-alp1)
6129 C
6130 C TAU-NEUTRINO MOMENTUM
6131  pn(1)=0
6132  pn(2)=0
6133  pn(4)=1./(2*amtau)*(amtau**2+amnuta**2-amx**2)
6134  pn(3)=-sqrt((pn(4)-amnuta)*(pn(4)+amnuta))
6135 C RHO MOMENTUM
6136  pr(1)=0
6137  pr(2)=0
6138  pr(4)=1./(2*amtau)*(amtau**2-amnuta**2+amx**2)
6139  pr(3)=-pn(3)
6140  phspac=phspac*(4*pi)*(2*pr(3)/amtau)
6141 C
6142 CAM
6143  enq1=(amx2+ampi**2-ampiz**2)/(2.*amx)
6144  enq2=(amx2-ampi**2+ampiz**2)/(2.*amx)
6145  pppi=sqrt((enq1-ampi)*(enq1+ampi))
6146  phspac=phspac*(4*pi)*(2*pppi/amx)
6147 C CHARGED PI MOMENTUM IN RHO REST FRAME
6148  CALL sphera(pppi,pic)
6149  pic(4)=enq1
6150 C NEUTRAL PI MOMENTUM IN RHO REST FRAME
6151  DO 20 i=1,3
6152  20 piz(i)=-pic(i)
6153  piz(4)=enq2
6154  exe=(pr(4)+pr(3))/amx
6155 C PIONS BOOSTED FROM RHO REST FRAME TO TAU REST FRAME
6156  CALL bostr3(exe,pic,pic)
6157  CALL bostr3(exe,piz,piz)
6158  DO 30 i=1,4
6159  30 qq(i)=pic(i)-piz(i)
6160 C AMPLITUDE
6161  prodpq=pt(4)*qq(4)
6162  prodnq=pn(4)*qq(4)-pn(1)*qq(1)-pn(2)*qq(2)-pn(3)*qq(3)
6163  prodpn=pt(4)*pn(4)
6164  qq2= qq(4)**2-qq(1)**2-qq(2)**2-qq(3)**2
6165  brak=(gv**2+ga**2)*(2*prodpq*prodnq-prodpn*qq2)
6166  & +(gv**2-ga**2)*amtau*amnuta*qq2
6167  amplit=(gfermi*ccabib)**2*brak*2*fpirho(amx)
6168  dgamt=1/(2.*amtau)*amplit*phspac
6169  DO 40 i=1,3
6170  40 hv(i)=2*gv*ga*amtau*(2*prodnq*qq(i)-qq2*pn(i))/brak
6171  RETURN
6172  END
6173 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
6174 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
6175 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
6176 *-- AUTHOR :
6177  subroutine
6178  + dphtre(dgamt,hv,pn,paa,pim1,ampa,pim2,ampb,pipl,amp3,keyt,mnum)
6179 C ----------------------------------------------------------------------
6180 * IT SIMULATES A1 DECAY IN TAU REST FRAME WITH
6181 * Z-AXIS ALONG A1 MOMENTUM
6182 * IT CAN BE ALSO USED TO GENERATE K K PI AND K PI PI TAU DECAYS.
6183 * INPUT PARAMETERS
6184 * KEYT - ALGORITHM CONTROLLING SWITCH
6185 * 2 - FLAT PHASE SPACE PIM1 PIM2 SYMMETRIZED STATISTICAL FACTOR 1/2
6186 * 1 - LIKE 1 BUT PEAKED AROUND A1 AND RHO (TWO CHANNELS) MASSES.
6187 * 3 - PEAKED AROUND OMEGA, ALL PARTICLES DIFFERENT
6188 * OTHER- FLAT PHASE SPACE, ALL PARTICLES DIFFERENT
6189 * AMP1 - MASS OF FIRST PI, ETC. (1-3)
6190 * MNUM - MATRIX ELEMENT TYPE
6191 * 0 - A1 MATRIX ELEMENT
6192 * 1-6 - MATRIX ELEMENT FOR K PI PI, K K PI DECAY MODES
6193 * 7 - PI- PI0 GAMMA MATRIX ELEMENT
6194 C ----------------------------------------------------------------------
6195  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
6196  + ,ampiz,ampi,amro,gamro,ama1,gama1
6197  + ,amk,amkz,amkst,gamkst
6198 C
6199  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
6200  + ,ampiz,ampi,amro,gamro,ama1,gama1
6201  + ,amk,amkz,amkst,gamkst
6202  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
6203  REAL*4 gfermi,gv,ga,ccabib,scabib,gamel
6204  REAL hv(4),pt(4),pn(4),paa(4),pim1(4),pim2(4),pipl(4)
6205  REAL pr(4)
6206  REAL*4 rrr(5)
6207  DATA pi /3.141592653589793238462643/
6208  DATA icont /0/
6209  xlam(x,y,z)=sqrt(abs((x-y-z)**2-4.0*y*z))
6210 C AMRO, GAMRO IS ONLY A PARAMETER FOR GETING HIGHT EFFICIENCY
6211 C
6212 C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
6213 C D**3 P /2E/(2PI)**3 (2PI)**4 DELTA4(SUM P)
6214  phspac=1./2**17/pi**8
6215 C TAU MOMENTUM
6216  pt(1)=0.
6217  pt(2)=0.
6218  pt(3)=0.
6219  pt(4)=amtau
6220 C
6221  CALL ranmar(rrr,5)
6222  rr=rrr(5)
6223 C
6224  CALL choice(mnum,rr,ichan,prob1,prob2,prob3,
6225  + amrx,gamrx,amra,gamra,amrb,gamrb)
6226  IF (ichan.EQ.1) THEN
6227  amp1=ampb
6228  amp2=ampa
6229  ELSEIF (ichan.EQ.2) THEN
6230  amp1=ampa
6231  amp2=ampb
6232  ELSE
6233  amp1=ampb
6234  amp2=ampa
6235  ENDIF
6236 CAM
6237  rr1=rrr(1)
6238  ams1=(amp1+amp2+amp3)**2
6239  ams2=(amtau-amnuta)**2
6240 * PHASE SPACE WITH SAMPLING FOR A1 RESONANCE
6241  alp1=atan((ams1-amrx**2)/amrx/gamrx)
6242  alp2=atan((ams2-amrx**2)/amrx/gamrx)
6243  alp=alp1+rr1*(alp2-alp1)
6244  am3sq =amrx**2+amrx*gamrx*tan(alp)
6245  am3 =sqrt(am3sq)
6246  phspac=phspac*((am3sq-amrx**2)**2+(amrx*gamrx)**2)/(amrx*gamrx)
6247  phspac=phspac*(alp2-alp1)
6248 C MASS OF (REAL/VIRTUAL) RHO -
6249  rr2=rrr(2)
6250  ams1=(amp2+amp3)**2
6251  ams2=(am3-amp1)**2
6252  IF (ichan.LE.2) THEN
6253 * PHASE SPACE WITH SAMPLING FOR RHO RESONANCE,
6254  alp1=atan((ams1-amra**2)/amra/gamra)
6255  alp2=atan((ams2-amra**2)/amra/gamra)
6256  alp=alp1+rr2*(alp2-alp1)
6257  am2sq =amra**2+amra*gamra*tan(alp)
6258  am2 =sqrt(am2sq)
6259 C --- THIS PART OF THE JACOBIAN WILL BE RECOVERED LATER ---------------
6260 C PHSPAC=PHSPAC*(ALP2-ALP1)
6261 C PHSPAC=PHSPAC*((AM2SQ-AMRA**2)**2+(AMRA*GAMRA)**2)/(AMRA*GAMRA)
6262 C----------------------------------------------------------------------
6263  ELSE
6264 * FLAT PHASE SPACE;
6265  am2sq=ams1+ rr2*(ams2-ams1)
6266  am2 =sqrt(am2sq)
6267  phf0=(ams2-ams1)
6268  ENDIF
6269 * RHO RESTFRAME, DEFINE PIPL AND PIM1
6270  enq1=(am2sq-amp2**2+amp3**2)/(2*am2)
6271  enq2=(am2sq+amp2**2-amp3**2)/(2*am2)
6272  ppi= enq1**2-amp3**2
6273  pppi=sqrt(abs(enq1**2-amp3**2))
6274 C --- THIS PART OF JACOBIAN WILL BE RECOVERED LATER
6275  phf1=(4*pi)*(2*pppi/am2)
6276 * PI MINUS MOMENTUM IN RHO REST FRAME
6277  CALL sphera(pppi,pipl)
6278  pipl(4)=enq1
6279 * PI0 1 MOMENTUM IN RHO REST FRAME
6280  DO 10 i=1,3
6281  10 pim1(i)=-pipl(i)
6282  pim1(4)=enq2
6283 * A1 REST FRAME, DEFINE PIM2
6284 * RHO MOMENTUM
6285  pr(1)=0
6286  pr(2)=0
6287  pr(4)=1./(2*am3)*(am3**2+am2**2-amp1**2)
6288  pr(3)= sqrt(abs(pr(4)**2-am2**2))
6289  ppi = pr(4)**2-am2**2
6290 * PI0 2 MOMENTUM
6291  pim2(1)=0
6292  pim2(2)=0
6293  pim2(4)=1./(2*am3)*(am3**2-am2**2+amp1**2)
6294  pim2(3)=-pr(3)
6295  phf2=(4*pi)*(2*pr(3)/am3)
6296 * OLD PIONS BOOSTED FROM RHO REST FRAME TO A1 REST FRAME
6297  exe=(pr(4)+pr(3))/am2
6298  CALL bostr3(exe,pipl,pipl)
6299  CALL bostr3(exe,pim1,pim1)
6300  rr3=rrr(3)
6301  rr4=rrr(4)
6302 CAM THET =PI*RR3
6303  thet =acos(-1.+2*rr3)
6304  phi = 2*pi*rr4
6305  CALL rotpol(thet,phi,pipl)
6306  CALL rotpol(thet,phi,pim1)
6307  CALL rotpol(thet,phi,pim2)
6308  CALL rotpol(thet,phi,pr)
6309 C
6310 * NOW TO THE TAU REST FRAME, DEFINE A1 AND NEUTRINO MOMENTA
6311 * A1 MOMENTUM
6312  paa(1)=0
6313  paa(2)=0
6314  paa(4)=1./(2*amtau)*(amtau**2-amnuta**2+am3**2)
6315  paa(3)= sqrt(abs(paa(4)**2-am3**2))
6316  ppi = paa(4)**2-am3**2
6317  phspac=phspac*(4*pi)*(2*paa(3)/amtau)
6318 * TAU-NEUTRINO MOMENTUM
6319  pn(1)=0
6320  pn(2)=0
6321  pn(4)=1./(2*amtau)*(amtau**2+amnuta**2-am3**2)
6322  pn(3)=-paa(3)
6323 C HERE WE CORRECT FOR THE JACOBIANS OF THE TWO CHAINS
6324 C ---FIRST CHANNEL ------- PIM1+PIPL
6325  ams1=(amp2+amp3)**2
6326  ams2=(am3-amp1)**2
6327  alp1=atan((ams1-amra**2)/amra/gamra)
6328  alp2=atan((ams2-amra**2)/amra/gamra)
6329  xpro = (pim1(3)+pipl(3))**2 +(pim1(2)+pipl(2))**2+(pim1(1)+
6330  +pipl(1))**2
6331  am2sq=-xpro+(pim1(4)+pipl(4))**2
6332 C JACOBIAN OF SPEEDING
6333  ff1 = ((am2sq-amra**2)**2+(amra*gamra)**2)/(amra*gamra)
6334  ff1 =ff1 *(alp2-alp1)
6335 C LAMBDA OF RHO DECAY
6336  gg1 = (4*pi)*(xlam(am2sq,amp2**2,amp3**2)/am2sq)
6337 C LAMBDA OF A1 DECAY
6338  gg1 =gg1 *(4*pi)*sqrt(4*xpro/am3sq)
6339  xjaje=gg1*(ams2-ams1)
6340 C ---SECOND CHANNEL ------ PIM2+PIPL
6341  ams1=(amp1+amp3)**2
6342  ams2=(am3-amp2)**2
6343  alp1=atan((ams1-amrb**2)/amrb/gamrb)
6344  alp2=atan((ams2-amrb**2)/amrb/gamrb)
6345  xpro = (pim2(3)+pipl(3))**2 +(pim2(2)+pipl(2))**2+(pim2(1)+
6346  +pipl(1))**2
6347  am2sq=-xpro+(pim2(4)+pipl(4))**2
6348  ff2 = ((am2sq-amrb**2)**2+(amrb*gamrb)**2)/(amrb*gamrb)
6349  ff2 =ff2 *(alp2-alp1)
6350  gg2 = (4*pi)*(xlam(am2sq,amp1**2,amp3**2)/am2sq)
6351  gg2 =gg2 *(4*pi)*sqrt(4*xpro/am3sq)
6352  xjadw=gg2*(ams2-ams1)
6353 C
6354  a1=0.0
6355  a2=0.0
6356  a3=0.0
6357  xjac1=ff1*gg1
6358  xjac2=ff2*gg2
6359  IF (ichan.EQ.2) THEN
6360  xjac3=xjadw
6361  ELSE
6362  xjac3=xjaje
6363  ENDIF
6364  IF (xjac1.NE.0.0) a1=prob1/xjac1
6365  IF (xjac2.NE.0.0) a2=prob2/xjac2
6366  IF (xjac3.NE.0.0) a3=prob3/xjac3
6367 C
6368  IF (a1+a2+a3.NE.0.0) THEN
6369  phspac=phspac/(a1+a2+a3)
6370  ELSE
6371  phspac=0.0
6372  ENDIF
6373  IF(ichan.EQ.2) THEN
6374  DO 20 i=1,4
6375  x=pim1(i)
6376  pim1(i)=pim2(i)
6377  20 pim2(i)=x
6378  ENDIF
6379 * ALL PIONS BOOSTED FROM A1 REST FRAME TO TAU REST FRAME
6380 * Z-AXIS ANTIPARALLEL TO NEUTRINO MOMENTUM
6381  exe=(paa(4)+paa(3))/am3
6382  CALL bostr3(exe,pipl,pipl)
6383  CALL bostr3(exe,pim1,pim1)
6384  CALL bostr3(exe,pim2,pim2)
6385  CALL bostr3(exe,pr,pr)
6386 C PARTIAL WIDTH CONSISTS OF PHASE SPACE AND AMPLITUDE
6387  IF (mnum.EQ.8) THEN
6388  CALL dampog(pt,pn,pim1,pim2,pipl,amplit,hv)
6389 C ELSEIF (MNUM.EQ.0) THEN
6390 C CALL DAMPAA(PT,PN,PIM1,PIM2,PIPL,AMPLIT,HV)
6391  ELSE
6392  CALL damppk(mnum,pt,pn,pim1,pim2,pipl,amplit,hv)
6393  ENDIF
6394  IF (keyt.EQ.1.OR.keyt.EQ.2) THEN
6395 C THE STATISTICAL FACTOR FOR IDENTICAL PI'S IS CANCELLED WITH
6396 C TWO, FOR TWO MODES OF A1 DECAY NAMELLY PI+PI-PI- AND PI-PI0PI0
6397  phspac=phspac*2.0
6398  phspac=phspac/2.
6399  ENDIF
6400  dgamt=1/(2.*amtau)*amplit*phspac
6401  END
6402 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
6403 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
6404 *-- AUTHOR :
6405 C **********************************************************************
6406 
6407  FUNCTION dqcd(ICOSFI,IPART,IP,XP,ZP,Y)
6408 
6409 C...FIRST ORDER QCD MATRIX ELEMENTS FROM R.D. PECCEI AND R. RUCKL:
6410 C...NUCL. PHYS. B162 (1980) 125
6411 
6412 C...CONSTANTS C1 TO C5 ARE RESP. 2/3/PI, 1/4/PI, 4/3/PI, 1/2/PI, 1/PI
6413  DATA c1,c2,c3,c4,c5/0.2122066,0.0795775,0.4244132,0.1591549,
6414  & 0.3183099/
6415 
6416  IF(icosfi.EQ.0) THEN
6417  IF(ipart.EQ.1) THEN
6418  IF(ip.EQ.1) THEN
6419  dqcd=c1*((zp**2+xp**2)/(1.-xp)/(1.-zp)+2.*(xp*zp+1.))
6420  ELSEIF(ip.EQ.2) THEN
6421  dqcd=c1*4.*xp*zp
6422  ELSEIF(ip.EQ.3) THEN
6423  dqcd=c1*((zp**2+xp**2)/(1.-xp)/(1.-zp)+2.*(xp+zp))
6424  ELSE
6425  WRITE(6,10000) icosfi,ipart,ip
6426  ENDIF
6427  ELSEIF(ipart.EQ.2) THEN
6428  IF(ip.EQ.1) THEN
6429  dqcd=c2*(xp**2+(1.-xp)**2)*(zp**2+(1.-zp)**2)/(1.-zp)/zp
6430  ELSEIF(ip.EQ.2) THEN
6431  dqcd=c2*8.*xp*(1.-xp)
6432  ELSEIF(ip.EQ.3) THEN
6433  dqcd=c2*(xp**2+(1.-xp)**2)*(zp-(1.-zp))/(1.-zp)/zp
6434  ELSE
6435  WRITE(6,10000) icosfi,ipart,ip
6436  ENDIF
6437  ELSE
6438  WRITE(6,10000) icosfi,ipart,ip
6439  ENDIF
6440 
6441  ELSEIF(icosfi.EQ.1) THEN
6442  IF(ipart.EQ.1) THEN
6443  IF(ip.EQ.1) THEN
6444  dqcd=c3*y*sqrt((1.-y)*xp*zp/(1.-xp)/(1.-zp))*
6445  & (1.-2./y)*(1.-zp-xp+2.*xp*zp)
6446  ELSEIF(ip.EQ.3) THEN
6447  dqcd=c3*y*sqrt((1.-y)*xp*zp/(1.-xp)/(1.-zp))*
6448  & (1.-xp-zp)
6449  ELSE
6450  WRITE(6,10000) icosfi,ipart,ip
6451  ENDIF
6452  ELSEIF(ipart.EQ.2) THEN
6453  IF(ip.EQ.1) THEN
6454  dqcd=c4*y*sqrt((1.-y)*xp*(1.-xp)/zp/(1.-zp))*
6455  & (1.-2./y)*(1.-2.*zp)*(1.-2.*xp)
6456  ELSEIF(ip.EQ.3) THEN
6457  dqcd=c4*y*sqrt((1.-y)*xp*(1.-xp)/zp/(1.-zp))*
6458  & (1.-2.*xp)
6459  ELSE
6460  WRITE(6,10000) icosfi,ipart,ip
6461  ENDIF
6462  ENDIF
6463 
6464  ELSEIF(icosfi.EQ.2) THEN
6465  IF(ipart.EQ.1) THEN
6466  dqcd=c3*(1.-y)*xp*zp
6467  ELSEIF(ipart.EQ.2) THEN
6468  dqcd=c5*(1.-y)*xp*(1.-xp)
6469  ELSE
6470  WRITE(6,10000) icosfi,ipart,ip
6471  ENDIF
6472 
6473  ELSE
6474  WRITE(6,10000) icosfi,ipart,ip
6475  ENDIF
6476  RETURN
6477 
6478 10000 FORMAT(' ERROR IN ROUTINE DQCD ',
6479  &' ICOSFI, IPART, IP = ',3i10)
6480  END
6481 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
6482 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
6483 *-- AUTHOR :
6484 C **********************************************************************
6485 
6486  FUNCTION dqcdi(IPART,IP,XP,ZPMIN,ZPMAX)
6487 
6488 C...FIRST ORDER QCD MATRIX ELEMENTS AS IN FUNCTION DQCD BUT ANALYTICALLY
6489 C...INTEGRATED OVER ZP FROM ZPMIN TO ZPMAX, ALSO A FACTOR 1/(1-XP) IS
6490 C...FACTORED OUT (SINCE XP CHOSEN RANDOMLY ACCORDING TO 1/(1-XP) DISTR.)
6491 
6492  DATA c1,c2/0.2122066,0.0795775/
6493 
6494  IF(ipart.EQ.1) THEN
6495  IF(ip.EQ.1) THEN
6496  zlog=alog(zpmax/zpmin)
6497  dqcdi=c1*(xp**2*zlog+zpmin-zpmax+(zpmin**2-zpmax**2)/2.+zlog+
6498  & xp*(1.-xp)*(zpmax**2-zpmin**2)+2.*(1.-xp)*(zpmax-zpmin))
6499  ELSEIF(ip.EQ.2) THEN
6500  dqcdi=c1*2.*xp*(1.-xp)*(zpmax**2-zpmin**2)
6501  ELSEIF(ip.EQ.3) THEN
6502  zlog=alog(zpmax/zpmin)
6503  dqcdi=c1*(xp**2*zlog+zpmin-zpmax+(zpmin**2-zpmax**2)/2.+zlog+
6504  & 2.*xp*(1.-xp)*(zpmax-zpmin)+(1.-xp)*(zpmax**2-zpmin**2))
6505  ELSE
6506  WRITE(6,10000) ipart,ip
6507  ENDIF
6508 
6509  ELSEIF(ipart.EQ.2) THEN
6510  IF(ip.EQ.1) THEN
6511  dqcdi=c2*(1.-xp)*(xp**2+(1.-xp)**2)*(2.*(zpmin-zpmax)+
6512  & alog(zpmax**2/zpmin**2))
6513  ELSEIF(ip.EQ.2) THEN
6514  dqcdi=c2*8.*xp*(1.-xp)**2*(zpmax-zpmin)
6515  ELSEIF(ip.EQ.3) THEN
6516  dqcdi=0.
6517  ELSE
6518  WRITE(6,10000) ipart,ip
6519  ENDIF
6520 
6521  ELSE
6522  WRITE(6,10000) ipart,ip
6523  ENDIF
6524  RETURN
6525 
6526 10000 FORMAT(' ERROR IN ROUTINE DQCDI ',
6527  &' IPART, IP = ',2i10)
6528  END
6529 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
6530 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
6531 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
6532 *-- AUTHOR :
6533  SUBROUTINE drcmu(DGAMT,HV,PH,PAA,XA,QP,XN,IELMU)
6534  IMPLICIT REAL*8 (a-h,o-z)
6535 C ----------------------------------------------------------------------
6536 * IT SIMULATES E,MU CHANNELS OF TAU DECAY IN ITS REST FRAME WITH
6537 * QED ORDER ALPHA CORRECTIONS
6538 C ----------------------------------------------------------------------
6539  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
6540  + ,ampiz,ampi,amro,gamro,ama1,gama1
6541  + ,amk,amkz,amkst,gamkst
6542 C
6543  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
6544  + ,ampiz,ampi,amro,gamro,ama1,gama1
6545  + ,amk,amkz,amkst,gamkst
6546  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
6547  REAL*4 gfermi,gv,ga,ccabib,scabib,gamel
6548  COMMON / inout / inut,iout
6549  COMMON / taurad / xk0dec,itdkrc
6550  REAL*8 xk0dec
6551  REAL*8 hv(4),pt(4),ph(4),paa(4),xa(4),qp(4),xn(4)
6552  REAL*8 pr(4)
6553  REAL*4 rrr(6)
6554  LOGICAL ihard
6555  DATA pi /3.141592653589793238462643d0/
6556  xlam(x,y,z)=sqrt((x-y-z)**2-4.0*y*z)
6557 C AMRO, GAMRO IS ONLY A PARAMETER FOR GETING HIGHT EFFICIENCY
6558 C
6559 C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
6560 C D**3 P /2E/(2PI)**3 (2PI)**4 DELTA4(SUM P)
6561  phspac=1./2**17/pi**8
6562  amtax=amtau
6563 C TAU MOMENTUM
6564  pt(1)=0.d0
6565  pt(2)=0.d0
6566  pt(3)=0.d0
6567  pt(4)=amtax
6568 C
6569  CALL ranmar(rrr,6)
6570 C
6571  IF (ielmu.EQ.1) THEN
6572  amu=amel
6573  ELSE
6574  amu=ammu
6575  ENDIF
6576 C
6577  prhard=0.30d0
6578  IF ( itdkrc.EQ.0) prhard=0d0
6579  prsoft=1.-prhard
6580  IF(prsoft.LT.0.1) THEN
6581  print *, 'ERROR IN DRCMU; PRSOFT=',prsoft
6582  stop
6583  ENDIF
6584 C
6585  rr5=rrr(5)
6586  ihard=(rr5.GT.prsoft)
6587  IF (ihard) THEN
6588 C TAU DECAY TO `TAU+PHOTON'
6589  rr1=rrr(1)
6590  ams1=(amu+amnuta)**2
6591  ams2=(amtax)**2
6592  xk1=1-ams1/ams2
6593  xl1=log(xk1/2/xk0dec)
6594  xl0=log(2*xk0dec)
6595  xk=exp(xl1*rr1+xl0)
6596  am3sq=(1-xk)*ams2
6597  am3 =sqrt(am3sq)
6598  phspac=phspac*ams2*xl1*xk
6599  phspac=phspac/prhard
6600  ELSE
6601  am3=amtax
6602  phspac=phspac*2**6*pi**3
6603  phspac=phspac/prsoft
6604  ENDIF
6605 C MASS OF NEUTRINA SYSTEM
6606  rr2=rrr(2)
6607  ams1=(amnuta)**2
6608  ams2=(am3-amu)**2
6609 CAM
6610 CAM
6611 * FLAT PHASE SPACE;
6612  am2sq=ams1+ rr2*(ams2-ams1)
6613  am2 =sqrt(am2sq)
6614  phspac=phspac*(ams2-ams1)
6615 * NEUTRINA REST FRAME, DEFINE XN AND XA
6616  enq1=(am2sq+amnuta**2)/(2*am2)
6617  enq2=(am2sq-amnuta**2)/(2*am2)
6618  ppi= enq1**2-amnuta**2
6619  pppi=sqrt(abs(enq1**2-amnuta**2))
6620  phspac=phspac*(4*pi)*(2*pppi/am2)
6621 * NU TAU IN NUNU REST FRAME
6622  CALL spherd(pppi,xn)
6623  xn(4)=enq1
6624 * NU LIGHT IN NUNU REST FRAME
6625  DO 10 i=1,3
6626  10 xa(i)=-xn(i)
6627  xa(4)=enq2
6628 * TAU' REST FRAME, DEFINE QP (MUON
6629 * NUNU MOMENTUM
6630  pr(1)=0
6631  pr(2)=0
6632  pr(4)=1.d0/(2*am3)*(am3**2+am2**2-amu**2)
6633  pr(3)= sqrt(abs(pr(4)**2-am2**2))
6634  ppi = pr(4)**2-am2**2
6635 * MUON MOMENTUM
6636  qp(1)=0
6637  qp(2)=0
6638  qp(4)=1.d0/(2*am3)*(am3**2-am2**2+amu**2)
6639  qp(3)=-pr(3)
6640  phspac=phspac*(4*pi)*(2*pr(3)/am3)
6641 * NEUTRINA BOOSTED FROM THEIR FRAME TO TAU' REST FRAME
6642  exe=(pr(4)+pr(3))/am2
6643  CALL bostd3(exe,xn,xn)
6644  CALL bostd3(exe,xa,xa)
6645  rr3=rrr(3)
6646  rr4=rrr(4)
6647  IF (ihard) THEN
6648  eps=4*(amu/amtax)**2
6649  xl1=log((2+eps)/eps)
6650  xl0=log(eps)
6651  eta =exp(xl1*rr3+xl0)
6652  cthet=1+eps-eta
6653  thet =acos(cthet)
6654  phspac=phspac*xl1/2*eta
6655  phi = 2*pi*rr4
6656  CALL rotpox(thet,phi,xn)
6657  CALL rotpox(thet,phi,xa)
6658  CALL rotpox(thet,phi,qp)
6659  CALL rotpox(thet,phi,pr)
6660 C
6661 * NOW TO THE TAU REST FRAME, DEFINE TAU' AND GAMMA MOMENTA
6662 * TAU' MOMENTUM
6663  paa(1)=0
6664  paa(2)=0
6665  paa(4)=1/(2*amtax)*(amtax**2+am3**2)
6666  paa(3)= sqrt(abs(paa(4)**2-am3**2))
6667  ppi = paa(4)**2-am3**2
6668  phspac=phspac*(4*pi)*(2*paa(3)/amtax)
6669 * GAMMA MOMENTUM
6670  ph(1)=0
6671  ph(2)=0
6672  ph(4)=paa(3)
6673  ph(3)=-paa(3)
6674 * ALL MOMENTA BOOSTED FROM TAU' REST FRAME TO TAU REST FRAME
6675 * Z-AXIS ANTIPARALLEL TO PHOTON MOMENTUM
6676  exe=(paa(4)+paa(3))/am3
6677  CALL bostd3(exe,xn,xn)
6678  CALL bostd3(exe,xa,xa)
6679  CALL bostd3(exe,qp,qp)
6680  CALL bostd3(exe,pr,pr)
6681  ELSE
6682  thet =acos(-1.+2*rr3)
6683  phi = 2*pi*rr4
6684  CALL rotpox(thet,phi,xn)
6685  CALL rotpox(thet,phi,xa)
6686  CALL rotpox(thet,phi,qp)
6687  CALL rotpox(thet,phi,pr)
6688 C
6689 * NOW TO THE TAU REST FRAME, DEFINE TAU' AND GAMMA MOMENTA
6690 * TAU' MOMENTUM
6691  paa(1)=0
6692  paa(2)=0
6693  paa(4)=amtax
6694  paa(3)=0
6695 * GAMMA MOMENTUM
6696  ph(1)=0
6697  ph(2)=0
6698  ph(4)=0
6699  ph(3)=0
6700  ENDIF
6701 C PARTIAL WIDTH CONSISTS OF PHASE SPACE AND AMPLITUDE
6702  CALL dampry(itdkrc,xk0dec,ph,xa,qp,xn,amplit,hv)
6703  dgamt=1/(2.*amtax)*amplit*phspac
6704  END
6705 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
6706 *CMZ : 1.01/08 05/03/95 11.39.25 BY PIERO ZUCCHELLI
6707 *CMZ : 1.00/00 25/07/94 17.30.49 BY PIERO ZUCCHELLI
6708 *CMZ : 1.00/00 15/07/94 14.09.39 BY PIERO ZUCCHELLI
6709 *-- AUTHOR :
6710 C **********************************************************************
6711 
6712  FUNCTION dsigma(XP)
6713 
6714 C...DIFFERENTIAL CROSS SECTION FOR FIRST ORDER QCD PROCESSES.
6715 
6716  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
6717  COMMON /linter/ pari(40),ewqc(2,2,8),qc(8),zl(2,4),zq(2,8),pq(17)
6718  COMMON /lintrl/ psave(3,4,5),ksave(4),xmin,xmax,ymin,ymax,
6719  +q2min,q2max,w2min,w2max,ilep,inu,ig,iz
6720  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
6721  dimension xpq(-6:6),pqh(17,2)
6722 
6723  dsigma=0.
6724  DO 10 i=1,17
6725  pqh(i,1)=0.
6726  pqh(i,2)=0.
6727  10 pq(i)=0.
6728 
6729  amu=ulmass(1)
6730  IF(lst(20).EQ.0.OR.lst(17).EQ.0) THEN
6731  il=1
6732  iu=3
6733  IF(lst(23).EQ.1.OR.lst(24).EQ.3) iu=2
6734  ELSE
6735  il=lst(20)
6736  iu=lst(20)
6737  ENDIF
6738  xi=x/xp
6739  zpmin=(1.-x)*xp/(xp-x)*parl(27)
6740  IF(zpmin.GE.0.5) RETURN
6741  zpmax=1.d0-dble(zpmin)
6742  CALL lnstrf(xi,q2,xpq)
6743  IF(lst(24).EQ.3) goto 80
6744 
6745 C...GLUON BREMSSTRAHLUNG PROCESS, I.E. QG-EVENT.
6746  20 DO 60 ip=il,iu
6747  sig=dqcdi(1,ip,xp,zpmin,zpmax)
6748  sgn=sign(1.,5.-2.*ip)
6749  DO 50 ih=1,2
6750  IF(ih.EQ.1) THEN
6751  IF(parl(6).GT.0.99) goto 50
6752  IF(lst(20).EQ.0.AND.lst(30).NE.-1) goto 50
6753  ELSEIF(ih.EQ.2) THEN
6754  IF(parl(6).LT.-0.99) goto 50
6755  IF(lst(20).EQ.0.AND.lst(30).NE.1) goto 50
6756  ENDIF
6757  IF(lst(20).NE.0) lst(30)=sign(1.,ih-1.5)
6758  IF(lst(23).NE.2) THEN
6759  DO 30 i=1,lst(12)
6760  wq=xpq(i)*sig*(ewqc(1,ih,i)+sgn*ewqc(2,ih,i))
6761  wqb=xpq(-i)*sig*sgn*(ewqc(1,ih,i)+sgn*ewqc(2,ih,i))
6762 C...INCLUDE Y-DEPENDENCE.
6763  wq=wq*pari(23+ip)
6764  wqb=wqb*pari(23+ip)
6765  pqh(i,ih)=pqh(i,ih)+wq
6766  pqh(i+lst(12),ih)=pqh(i+lst(12),ih)+wqb
6767  pqh(17,ih)=pqh(17,ih)+wq+wqb
6768  30 CONTINUE
6769  ELSEIF(lst(23).EQ.2) THEN
6770 C...ZERO CC CROSS-SECTION FOR ONE HELICITY STATE.
6771  IF(ksave(1).LT.0.AND.ih.EQ.1 .OR.ksave(1).GT.0.AND.ih.EQ.2)
6772  + goto 50
6773  IF(ip.EQ.3) THEN
6774  tq=-lst(30)
6775  tqb=-tq
6776  ELSE
6777  tq=1.
6778  tqb=1.
6779  ENDIF
6780  DO 40 i=1,lst(12)
6781  t1=-k(3,2)*qc(i)
6782  IF(t1.GT.0) THEN
6783  wq=xpq(i)*sig*tq
6784  wqb=0.
6785  ELSE
6786  wqb=xpq(-i)*sig*tqb
6787  wq=0.
6788  ENDIF
6789 C...INCLUDE Y-DEPENDENCE.
6790  wq=wq*pari(23+ip)
6791  wqb=wqb*pari(23+ip)
6792  pqh(i,ih)=pqh(i,ih)+wq
6793  pqh(i+lst(12),ih)=pqh(i+lst(12),ih)+wqb
6794  pqh(17,ih)=pqh(17,ih)+wq+wqb
6795  40 CONTINUE
6796  ENDIF
6797  50 CONTINUE
6798  60 CONTINUE
6799  DO 70 i=1,17
6800  70 pq(i)=(1.-parl(6))/2.*pqh(i,1)+(1.+parl(6))/2.*pqh(i,2)
6801  IF(lst(20).EQ.0) THEN
6802 C...SIMULATION: CROSS SECTION FOR CHOSEN HELICITY STATE ONLY.
6803  ih=1
6804  IF(lst(30).EQ.1) ih=2
6805  dsigma=pqh(17,ih)
6806 * WRITE(*,*)'DSIGMA_1=',DSIGMA
6807  ELSE
6808 C...INTEGRATION: NORMALIZE AND INCLUDE ALPHA_S*1/(1-XP)
6809  dsigma=pq(17)/pari(20)*parl(25)/(1.-xp)
6810 * WRITE(*,*)'DSIGMA_2=',DSIGMA
6811  IF(lst(17).EQ.0) THEN
6812 C...FIXED BEAM ENERGY, MAX OF DSIGMA/DXP FOR L- AND R-HANDED LEPTON.
6813  IF(pqh(17,1).GT.pari(15)) pari(15)=pqh(17,1)
6814  IF(pqh(17,2).GT.pari(16)) pari(16)=pqh(17,2)
6815  ELSE
6816 C...VARIABLE BEAM ENERGY, MAX OF DSIGMA/DXP FOR S, T, I CONTRIBUTIONS.
6817  IF(pq(17)/pari(23+lst(20)).GT.pari(14+lst(20)))
6818  + pari(14+lst(20))=pq(17)/pari(23+lst(20))
6819  ENDIF
6820  ENDIF
6821  RETURN
6822 
6823 C...BOSON-GLUON FUSION, I.E. QQ-EVENT.
6824  80 s13=q2*(1.-xp)/xp
6825  IF(s13.LT.4.*amu**2) RETURN
6826  DO 120 ip=il,iu
6827  sig=xpq(0)*dqcdi(2,ip,xp,zpmin,zpmax)
6828  DO 110 ih=1,2
6829  IF(ih.EQ.1) THEN
6830  IF(parl(6).GT.0.99) goto 110
6831  IF(lst(20).EQ.0.AND.lst(30).NE.-1) goto 110
6832  ELSEIF(ih.EQ.2) THEN
6833  IF(parl(6).LT.-0.99) goto 110
6834  IF(lst(20).EQ.0.AND.lst(30).NE.1) goto 110
6835  ENDIF
6836  IF(lst(20).NE.0) lst(30)=sign(1.,ih-1.5)
6837  IF(lst(23).NE.2) THEN
6838  DO 90 i=1,lst(13)
6839  IF(s13.LT.4.*ulmass(i)**2) goto 90
6840  wq=sig/2.*(ewqc(1,ih,i)+ewqc(2,ih,i))
6841  wqb=wq
6842 C...INCLUDE Y-DEPENDENCE.
6843  wq=wq*pari(23+ip)
6844  wqb=wqb*pari(23+ip)
6845  pqh(i,ih)=pqh(i,ih)+wq
6846  pqh(i+lst(13),ih)=pqh(i+lst(13),ih)+wqb
6847  pqh(17,ih)=pqh(17,ih)+wq+wqb
6848  90 CONTINUE
6849  ELSEIF(lst(23).EQ.2) THEN
6850 C...ZERO CC CROSS-SECTION FOR ONE HELICITY STATE.
6851  IF(ksave(1).LT.0.AND.ih.EQ.1 .OR.ksave(1).GT.0.AND.ih.EQ.2)
6852  + goto 110
6853  DO 100 i=1,lst(13)
6854  IF(s13.LT.(amu+ulmass(i))**2) goto 100
6855  IF(k(3,2)*qc(i).LT.0) THEN
6856  wq=sig
6857  wqb=0.
6858  ELSE
6859  wqb=sig
6860  wq=0.
6861  ENDIF
6862 C...INCLUDE Y-DEPENDENCE.
6863  wq=wq*pari(23+ip)
6864  wqb=wqb*pari(23+ip)
6865  pqh(i,ih)=pqh(i,ih)+wq
6866  pqh(i+lst(13),ih)=pqh(i+lst(13),ih)+wqb
6867  pqh(17,ih)=pqh(17,ih)+wq+wqb
6868  100 CONTINUE
6869  ENDIF
6870  110 CONTINUE
6871  120 CONTINUE
6872  DO 130 i=1,17
6873  130 pq(i)=(1.-parl(6))/2.*pqh(i,1)+(1.+parl(6))/2.*pqh(i,2)
6874  IF(lst(20).EQ.0) THEN
6875 C...SIMULATION: CROSS SECTION FOR CHOSEN HELICITY STATE ONLY.
6876  ih=1
6877  IF(lst(30).EQ.1) ih=2
6878  dsigma=pqh(17,ih)
6879 * WRITE(*,*)'DSIGMA_3=',DSIGMA
6880  ELSE
6881 C...INTEGRATION: NORMALIZE AND INCLUDE ALPHA_S*1/(1-XP)
6882  dsigma=pq(17)/pari(20)*parl(25)/(1.-xp)
6883 * WRITE(*,*)'DSIGMA_4=',DSIGMA
6884  IF(lst(17).EQ.0) THEN
6885 C...FIXED BEAM ENERGY, MAX OF DSIGMA/DXP FOR L- AND R-HANDED LEPTON.
6886  IF(pqh(17,1).GT.pari(18)) pari(18)=pqh(17,1)
6887  IF(pqh(17,2).GT.pari(19)) pari(19)=pqh(17,2)
6888  ELSE
6889 C...VARIABLE BEAM ENERGY, MAX OF DSIGMA/DXP FOR S, T, I CONTRIBUTIONS.
6890  IF(pq(17)/pari(23+lst(20)).GT.pari(17+lst(20)))
6891  + pari(17+lst(20))=pq(17)/pari(23+lst(20))
6892  ENDIF
6893  ENDIF
6894  RETURN
6895  END
6896 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
6897 *-- AUTHOR :
6898 C **********************************************************************
6899 
6900  FUNCTION dupper(V1)
6901 
6902 C...UPPER LIMIT ON SECOND VARIABLE (Y, Q**2 OR W**2) DEPENDING ON FIRST
6903 C...VARIABLE X=V1. USED FOR INTEGRATING DIFFERENTIAL CROSS-SECTION.
6904 
6905  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
6906  COMMON /lintrl/ psave(3,4,5),ksave(4),xmin,xmax,ymin,ymax,
6907  &q2min,q2max,w2min,w2max,ilep,inu,ig,iz
6908 C...CMS ENERGY SQUARED AND TARGET NUCLEON MASS.
6909  s=parl(21)
6910  pm2=psave(3,2,5)**2
6911  IF(lst(31).EQ.1) THEN
6912  dupper=min(q2max,v1*ymax*s,(w2max-pm2)*v1/max(1.-v1,1.e-22))
6913  ELSEIF(lst(31).EQ.2) THEN
6914  dupper=min(ymax,q2max/(s*v1),(w2max-pm2)/max(s*(1.-v1),1.e-22))
6915  ELSEIF(lst(31).EQ.3) THEN
6916  dupper=min(w2max,(1.-v1)*ymax*s+pm2,
6917  & q2max*(1.-v1)/max(v1,1.e-22)+pm2)
6918  ENDIF
6919  RETURN
6920  END
6921 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
6922 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
6923 *-- AUTHOR :
6924 C **********************************************************************
6925 
6926  SUBROUTINE dvnopt
6927 
6928 C...CHANGE OF DEFAULT OPTIONS IN DIVONNE
6929 
6930  COMMON /print/ iprdiv
6931  COMMON /lpflag/ lst3
6932  iprdiv=0
6933  IF(lst3.GE.2) iprdiv=1000
6934  IF(lst3.GE.4) iprdiv=10
6935  IF(lst3.GE.4) WRITE(6,10000) iprdiv
6936  RETURN
6937 10000 FORMAT(5x,'DIVON4 PRINT FLAG CHANGED: IPRDIV =',i5)
6938  END
6939 *CMZ : 1.01/50 22/05/96 18.06.08 by Piero Zucchelli
6940 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
6941 *-- AUTHOR :
6942  SUBROUTINE dwlnew(KTO,ISGN,PNU,PWB,PNPI,MODE)
6943 C ----------------------------------------------------------------------
6944 C LORENTZ TRANSFORMATION TO CMSYSTEM AND
6945 C UPDATING OF HEPEVT RECORD
6946 C
6947 C ISGN = 1/-1 FOR TAU-/TAU+
6948 C
6949 C CALLED BY : DEXAY,(DEKAY1,DEKAY2)
6950 C ----------------------------------------------------------------------
6951 C
6952  parameter(nmode=15,nm1=0,nm2=1,nm3=8,nm4=2,nm5=1,nm6=3)
6953  COMMON / mdecomp /idffin(9,nmode),mulpik(nmode)
6954  & ,names
6955  CHARACTER names(nmode)*31
6956  REAL pnu(4),pwb(4),pnpi(4,9)
6957  REAL ppi(4)
6958 C
6959  jnpi=mode-7
6960 C POSITION OF DECAYING PARTICLE
6961  IF(kto.EQ. 1) THEN
6962  nps=3
6963  ELSE
6964  nps=4
6965  ENDIF
6966 C
6967 C TAU NEUTRINO (NU_TAU IS 16)
6968  CALL tralo4(kto,pnu,pnu,am)
6969  CALL filhep(0,1,16*isgn,nps,nps,0,0,pnu,am,.true.)
6970 C
6971 C W BOSON (W+ IS 24)
6972  CALL tralo4(kto,pwb,pwb,am)
6973  CALL filhep(0,1,-24*isgn,nps,nps,0,0,pwb,am,.true.)
6974 C
6975 C MULTI PI MODE JNPI
6976 C
6977 C GET MULTIPLICITY OF MODE JNPI
6978  nd=mulpik(jnpi)
6979  DO i=1,nd
6980  kfpi=lunpik(idffin(i,jnpi),-isgn)
6981 C FOR CHARGED CONJUGATE CASE, CHANGE CHARGED PIONS ONLY
6982 C IF(KFPI.NE.111)KFPI=KFPI*ISGN
6983  DO j=1,4
6984  ppi(j)=pnpi(j,i)
6985  END DO
6986  CALL tralo4(kto,ppi,ppi,am)
6987  CALL filhep(0,1,kfpi,-i,-i,0,0,ppi,am,.true.)
6988  END DO
6989 C
6990  RETURN
6991  END
6992 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
6993 *-- AUTHOR :
6994  SUBROUTINE dwluaa(KTO,ISGN,PNU,PAA,PIM1,PIM2,PIPL,JAA)
6995 C ----------------------------------------------------------------------
6996 C LORENTZ TRANSFORMATION TO CMSYSTEM AND
6997 C UPDATING OF HEPEVT RECORD
6998 C
6999 C ISGN = 1/-1 FOR TAU-/TAU+
7000 C JAA = 1 (2) FOR A_1- DECAY TO PI+ 2PI- (PI- 2PI0)
7001 C
7002 C CALLED BY : DEXAY,(DEKAY1,DEKAY2)
7003 C ----------------------------------------------------------------------
7004 C
7005  REAL pnu(4),paa(4),pim1(4),pim2(4),pipl(4)
7006 C
7007 C POSITION OF DECAYING PARTICLE:
7008  IF(kto.EQ. 1) THEN
7009  nps=3
7010  ELSE
7011  nps=4
7012  ENDIF
7013 C
7014 C TAU NEUTRINO (NU_TAU IS 16)
7015  CALL tralo4(kto,pnu,pnu,am)
7016  CALL filhep(0,1,16*isgn,nps,nps,0,0,pnu,am,.true.)
7017 C
7018 C CHARGED A_1 MESON (A_1+ IS 20213)
7019  CALL tralo4(kto,paa,paa,am)
7020  CALL filhep(0,1,-20213*isgn,nps,nps,0,0,paa,am,.true.)
7021 C
7022 C TWO POSSIBLE DECAYS OF THE CHARGED A1 MESON
7023  IF(jaa.EQ.1) THEN
7024 C
7025 C A1 --> PI+ PI- PI- (OR CHARGED CONJUGATE)
7026 C
7027 C PI MINUS (OR C.C.) (PI+ IS 211)
7028  CALL tralo4(kto,pim2,pim2,am)
7029  CALL filhep(0,1,-211*isgn,-1,-1,0,0,pim2,am,.true.)
7030 C
7031 C PI MINUS (OR C.C.) (PI+ IS 211)
7032  CALL tralo4(kto,pim1,pim1,am)
7033  CALL filhep(0,1,-211*isgn,-2,-2,0,0,pim1,am,.true.)
7034 C
7035 C PI PLUS (OR C.C.) (PI+ IS 211)
7036  CALL tralo4(kto,pipl,pipl,am)
7037  CALL filhep(0,1, 211*isgn,-3,-3,0,0,pipl,am,.true.)
7038 C
7039  ELSE IF (jaa.EQ.2) THEN
7040 C
7041 C A1 --> PI- PI0 PI0 (OR CHARGED CONJUGATE)
7042 C
7043 C PI ZERO (PI0 IS 111)
7044  CALL tralo4(kto,pim2,pim2,am)
7045  CALL filhep(0,1,111,-1,-1,0,0,pim2,am,.true.)
7046 C
7047 C PI ZERO (PI0 IS 111)
7048  CALL tralo4(kto,pim1,pim1,am)
7049  CALL filhep(0,1,111,-2,-2,0,0,pim1,am,.true.)
7050 C
7051 C PI MINUS (OR C.C.) (PI+ IS 211)
7052  CALL tralo4(kto,pipl,pipl,am)
7053  CALL filhep(0,1,-211*isgn,-3,-3,0,0,pipl,am,.true.)
7054 C
7055  ENDIF
7056 C
7057  RETURN
7058  END
7059 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
7060 *-- AUTHOR :
7061  SUBROUTINE dwluel(KTO,ISGN,PNU,PWB,PEL,PNE)
7062 C ----------------------------------------------------------------------
7063 C LORENTZ TRANSFORMATION TO CMSYSTEM AND
7064 C UPDATING OF HEPEVT RECORD
7065 C
7066 C ISGN = 1/-1 FOR TAU-/TAU+
7067 C
7068 C CALLED BY : DEXAY,(DEKAY1,DEKAY2)
7069 C ----------------------------------------------------------------------
7070 C
7071  REAL pnu(4),pwb(4),pel(4),pne(4)
7072 C
7073 C POSITION OF DECAYING PARTICLE:
7074  IF(kto.EQ. 1) THEN
7075  nps=3
7076  ELSE
7077  nps=4
7078  ENDIF
7079 C
7080 C TAU NEUTRINO (NU_TAU IS 16)
7081  CALL tralo4(kto,pnu,pnu,am)
7082  CALL filhep(0,1,16*isgn,nps,nps,0,0,pnu,am,.true.)
7083 C
7084 C W BOSON (W+ IS 24)
7085  CALL tralo4(kto,pwb,pwb,am)
7086 C CALL FILHEP(0,2,-24*ISGN,NPS,NPS,0,0,PWB,AM,.TRUE.)
7087 C
7088 C ELECTRON (E- IS 11)
7089  CALL tralo4(kto,pel,pel,am)
7090  CALL filhep(0,1,11*isgn,nps,nps,0,0,pel,am,.false.)
7091 C
7092 C ANTI ELECTRON NEUTRINO (NU_E IS 12)
7093  CALL tralo4(kto,pne,pne,am)
7094  CALL filhep(0,1,-12*isgn,nps,nps,0,0,pne,am,.true.)
7095 C
7096  RETURN
7097  END
7098 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
7099 *-- AUTHOR :
7100  SUBROUTINE dwlukk (KTO,ISGN,PKK,PNU)
7101 C ----------------------------------------------------------------------
7102 C LORENTZ TRANSFORMATION TO CMSYSTEM AND
7103 C UPDATING OF HEPEVT RECORD
7104 C
7105 C ISGN = 1/-1 FOR TAU-/TAU+
7106 C
7107 C ----------------------------------------------------------------------
7108 C
7109  REAL pkk(4),pnu(4)
7110 C
7111 C POSITION OF DECAYING PARTICLE
7112  IF (kto.EQ.1) THEN
7113  nps=3
7114  ELSE
7115  nps=4
7116  ENDIF
7117 C
7118 C TAU NEUTRINO (NU_TAU IS 16)
7119  CALL tralo4(kto,pnu,pnu,am)
7120  CALL filhep(0,1,16*isgn,nps,nps,0,0,pnu,am,.true.)
7121 C
7122 C K MESON (K+ IS 321)
7123  CALL tralo4(kto,pkk,pkk,am)
7124  CALL filhep(0,1,-321*isgn,nps,nps,0,0,pkk,am,.true.)
7125 C
7126  RETURN
7127  END
7128 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
7129 *-- AUTHOR :
7130  SUBROUTINE dwluks(KTO,ISGN,PNU,PKS,PKK,PPI,JKST)
7131  COMMON / taukle / bra1,brk0,brk0b,brks
7132  REAL*4 bra1,brk0,brk0b,brks
7133 C ----------------------------------------------------------------------
7134 C LORENTZ TRANSFORMATION TO CMSYSTEM AND
7135 C UPDATING OF HEPEVT RECORD
7136 C
7137 C ISGN = 1/-1 FOR TAU-/TAU+
7138 C JKST=10 (20) CORRESPONDS TO K0B PI- (K- PI0) DECAY
7139 C
7140 C ----------------------------------------------------------------------
7141 C
7142  REAL pnu(4),pks(4),pkk(4),ppi(4)
7143 C
7144 C POSITION OF DECAYING PARTICLE
7145  IF(kto.EQ. 1) THEN
7146  nps=3
7147  ELSE
7148  nps=4
7149  ENDIF
7150 C
7151 C TAU NEUTRINO (NU_TAU IS 16)
7152  CALL tralo4(kto,pnu,pnu,am)
7153  CALL filhep(0,1,16*isgn,nps,nps,0,0,pnu,am,.true.)
7154 C
7155 C CHARGED K* MESON (K*+ IS 323)
7156  CALL tralo4(kto,pks,pks,am)
7157  CALL filhep(0,1,-323*isgn,nps,nps,0,0,pks,am,.true.)
7158 C
7159 C TWO POSSIBLE DECAY MODES OF CHARGED K*
7160  IF(jkst.EQ.10) THEN
7161 C
7162 C K*- --> PI- K0B (OR CHARGED CONJUGATE)
7163 C
7164 C CHARGED PI MESON (PI+ IS 211)
7165  CALL tralo4(kto,ppi,ppi,am)
7166  CALL filhep(0,1,-211*isgn,-1,-1,0,0,ppi,am,.true.)
7167 C
7168  bran=brk0b
7169  IF (isgn.EQ.-1) bran=brk0
7170 C K0 --> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
7171  CALL ranmar(xio,1)
7172  IF(xio.GT.bran) THEN
7173  k0type = 130
7174  ELSE
7175  k0type = 310
7176  ENDIF
7177 C
7178  CALL tralo4(kto,pkk,pkk,am)
7179  CALL filhep(0,1,k0type,-2,-2,0,0,pkk,am,.true.)
7180 C
7181  ELSE IF(jkst.EQ.20) THEN
7182 C
7183 C K*- --> PI0 K-
7184 C
7185 C PI ZERO (PI0 IS 111)
7186  CALL tralo4(kto,ppi,ppi,am)
7187  CALL filhep(0,1,111,-1,-1,0,0,ppi,am,.true.)
7188 C
7189 C CHARGED K MESON (K+ IS 321)
7190  CALL tralo4(kto,pkk,pkk,am)
7191  CALL filhep(0,1,-321*isgn,-2,-2,0,0,pkk,am,.true.)
7192 C
7193  ENDIF
7194 C
7195  RETURN
7196  END
7197 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
7198 *-- AUTHOR :
7199  SUBROUTINE dwlumu(KTO,ISGN,PNU,PWB,PMU,PNM)
7200 C ----------------------------------------------------------------------
7201 C LORENTZ TRANSFORMATION TO CMSYSTEM AND
7202 C UPDATING OF HEPEVT RECORD
7203 C
7204 C ISGN = 1/-1 FOR TAU-/TAU+
7205 C
7206 C CALLED BY : DEXAY,(DEKAY1,DEKAY2)
7207 C ----------------------------------------------------------------------
7208 C
7209  REAL pnu(4),pwb(4),pmu(4),pnm(4)
7210 C
7211 C POSITION OF DECAYING PARTICLE:
7212  IF(kto.EQ. 1) THEN
7213  nps=3
7214  ELSE
7215  nps=4
7216  ENDIF
7217 C
7218 C TAU NEUTRINO (NU_TAU IS 16)
7219  CALL tralo4(kto,pnu,pnu,am)
7220  CALL filhep(0,1,16*isgn,nps,nps,0,0,pnu,am,.true.)
7221 C
7222 C W BOSON (W+ IS 24)
7223  CALL tralo4(kto,pwb,pwb,am)
7224 C CALL FILHEP(0,2,-24*ISGN,NPS,NPS,0,0,PWB,AM,.TRUE.)
7225 C
7226 C MUON (MU- IS 13)
7227  CALL tralo4(kto,pmu,pmu,am)
7228  CALL filhep(0,1,13*isgn,nps,nps,0,0,pmu,am,.false.)
7229 C
7230 C ANTI MUON NEUTRINO (NU_MU IS 14)
7231  CALL tralo4(kto,pnm,pnm,am)
7232  CALL filhep(0,1,-14*isgn,nps,nps,0,0,pnm,am,.true.)
7233 C
7234  RETURN
7235  END
7236 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
7237 *-- AUTHOR :
7238  SUBROUTINE dwluph(KTO,PHOT)
7239 C---------------------------------------------------------------------
7240 C LORENTZ TRANSFORMATION TO CMSYSTEM AND
7241 C UPDATING OF HEPEVT RECORD
7242 C
7243 C CALLED BY : DEXAY1,(DEKAY1,DEKAY2)
7244 C
7245 C USED WHEN RADIATIVE CORRECTIONS IN DECAYS ARE GENERATED
7246 C---------------------------------------------------------------------
7247 C
7248  REAL phot(4)
7249 C
7250 C CHECK ENERGY
7251  IF (phot(4).LE.0.0) RETURN
7252 C
7253 C POSITION OF DECAYING PARTICLE:
7254  IF((kto.EQ. 1).OR.(kto.EQ.11)) THEN
7255  nps=3
7256  ELSE
7257  nps=4
7258  ENDIF
7259 C
7260  ktos=kto
7261  IF(ktos.GT.10) ktos=ktos-10
7262 C BOOST AND APPEND PHOTON (GAMMA IS 22)
7263  CALL tralo4(ktos,phot,phot,am)
7264  CALL filhep(0,1,22,nps,nps,0,0,phot,0.0,.true.)
7265 C
7266  RETURN
7267  END
7268 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
7269 *-- AUTHOR :
7270  SUBROUTINE dwlupi(KTO,ISGN,PPI,PNU)
7271 C ----------------------------------------------------------------------
7272 C LORENTZ TRANSFORMATION TO CMSYSTEM AND
7273 C UPDATING OF HEPEVT RECORD
7274 C
7275 C ISGN = 1/-1 FOR TAU-/TAU+
7276 C
7277 C CALLED BY : DEXAY,(DEKAY1,DEKAY2)
7278 C ----------------------------------------------------------------------
7279 C
7280  REAL pnu(4),ppi(4)
7281 C
7282 C POSITION OF DECAYING PARTICLE:
7283  IF(kto.EQ. 1) THEN
7284  nps=3
7285  ELSE
7286  nps=4
7287  ENDIF
7288 C
7289 C TAU NEUTRINO (NU_TAU IS 16)
7290  CALL tralo4(kto,pnu,pnu,am)
7291  CALL filhep(0,1,16*isgn,nps,nps,0,0,pnu,am,.true.)
7292 C
7293 C CHARGED PI MESON (PI+ IS 211)
7294  CALL tralo4(kto,ppi,ppi,am)
7295  CALL filhep(0,1,-211*isgn,nps,nps,0,0,ppi,am,.true.)
7296 C
7297  RETURN
7298  END
7299 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
7300 *-- AUTHOR :
7301  SUBROUTINE dwluro(KTO,ISGN,PNU,PRHO,PIC,PIZ)
7302 C ----------------------------------------------------------------------
7303 C LORENTZ TRANSFORMATION TO CMSYSTEM AND
7304 C UPDATING OF HEPEVT RECORD
7305 C
7306 C ISGN = 1/-1 FOR TAU-/TAU+
7307 C
7308 C CALLED BY : DEXAY,(DEKAY1,DEKAY2)
7309 C ----------------------------------------------------------------------
7310 C
7311  REAL pnu(4),prho(4),pic(4),piz(4)
7312 C
7313 C POSITION OF DECAYING PARTICLE:
7314  IF(kto.EQ. 1) THEN
7315  nps=3
7316  ELSE
7317  nps=4
7318  ENDIF
7319 C
7320 C TAU NEUTRINO (NU_TAU IS 16)
7321  CALL tralo4(kto,pnu,pnu,am)
7322  CALL filhep(0,1,16*isgn,nps,nps,0,0,pnu,am,.true.)
7323 C
7324 C CHARGED RHO MESON (RHO+ IS 213)
7325  CALL tralo4(kto,prho,prho,am)
7326  CALL filhep(0,2,-213*isgn,nps,nps,0,0,prho,am,.true.)
7327 C
7328 C CHARGED PI MESON (PI+ IS 211)
7329  CALL tralo4(kto,pic,pic,am)
7330  CALL filhep(0,1,-211*isgn,-1,-1,0,0,pic,am,.true.)
7331 C
7332 C PI0 MESON (PI0 IS 111)
7333  CALL tralo4(kto,piz,piz,am)
7334  CALL filhep(0,1,111,-2,-2,0,0,piz,am,.true.)
7335 C
7336  RETURN
7337  END
7338 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
7339 *CMZ : 1.01/08 05/03/95 11.39.27 BY PIERO ZUCCHELLI
7340 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
7341 *-- AUTHOR :
7342  SUBROUTINE dwrph(KTO,PHX)
7343 C
7344 C -------------------------
7345 C
7346  IMPLICIT REAL*8 (a-h,o-z)
7347  REAL*4 phx(4)
7348  REAL*4 qhot(4)
7349 C
7350  DO 10 k=1,4
7351  qhot(k) =0.0
7352  10 CONTINUE
7353 C CASE OF TAU RADIATIVE DECAYS.
7354 C FILLING OF THE LUND COMMON BLOCK.
7355  DO 20 i=1,4
7356  20 qhot(i)=phx(i)
7357  IF (qhot(4).GT.1.e-5) CALL dwluph(kto,qhot)
7358  RETURN
7359  END
7360 *CMZ : 1.02/04 13/01/97 14.47.40 by P. Zucchelli
7361 *CMZ : 1.02/02 12/01/97 17.44.36 by P. Zucchelli
7362 *CMZ : 1.01/50 19/04/96 11.22.32 by Piero Zucchelli
7363 *CMZ : 1.01/47 11/01/96 09.25.42 by Piero Zucchelli
7364 *CMZ : 1.01/45 08/01/96 14.21.55 by Piero Zucchelli
7365 *CMZ : 1.01/44 05/01/96 18.04.38 by Piero Zucchelli
7366 *CMZ : 1.01/40 09/11/95 16.12.24 by Piero Zucchelli
7367 *-- Author : Piero Zucchelli 09/11/95
7368  SUBROUTINE evtinfo
7369 
7370  CHARACTER*8 title,versqq
7371  CHARACTER*80 cookie
7372  INTEGER ititle(2)
7373 *KEEP,zebra.
7374 
7375  parameter(nnq=1000000)
7376 *
7377  dimension lq(nnq),iq(nnq),q(nnq)
7378  equivalence(q(1),iq(1),lq(9),jstruc(8))
7379  COMMON /quest/iquest(100)
7380  COMMON /xqstor/ixevt,ifence(16),jgeev,jstruc(99),jrefer(100),
7381  +div12(nnq)
7382  COMMON /fzlun/lunfz
7383  common/mzioall/iogenf
7384 
7385 *KEEP,info.
7386  common/infonew/irdate,irtime
7387 *KEEP,KEYS.
7388  common/cfread/space(5000)
7389  common/mykeys/ievar,if5cc,ineut,iinte,iferm,iflat,icoun,
7390  & refix,imudo,ikat1,ikat2,ikat3,ikat4,ikat5,ikat6,
7391  & inevt,ijak1,ijak2,iitdk,rptau,rxk0d,ntgr,idimuon,iglu,
7392  & iqden,lome(2),ifiles,iccha,iseed,idsubs,ionem,ehac,ipsel,
7393  & ihist
7394 
7395 
7396 *KEEP,VIDQQ.
7397  CHARACTER*66 vidqq
7398  DATA vidqq/
7399  +'@(#)JETTA 1.02/13 15/01/97 23.59.31 C: 21/05/97 10.31.11'/
7400 *KEND.
7401  IF (jgeev.EQ.0) RETURN
7402  CALL mzbook(ixevt,jgenf,jgeev,-1,'GENF',1,1,7,iogenf,0)
7403 *KEEP,VERSQQ.
7404  versqq = ' 1.02/13'
7405  iversq = 10213
7406 *KEEP,DATEQQ.
7407  idatqq = 970521
7408 *KEEP,TIMEQQ.
7409  itimqq = 1031
7410 *KEND.
7411  iq(jgenf+1)=idatqq
7412  iq(jgenf+2)=itimqq
7413  iq(jgenf+3)=iversq
7414  iq(jgenf+4)=irdate
7415  iq(jgenf+5)=irtime
7416  title=
7417 *KEEP,QFTITLCH,N= 8.
7418  + 'JETTA '
7419 *KEND.
7420  CALL uctoh(title,ititle,4,8)
7421  iq(jgenf+6)=ititle(1)
7422  iq(jgenf+7)=ititle(2)
7423  CALL mzbook(ixevt,jgecr,jgenf,-1,'GECR',0,0,31,3,0)
7424  q(jgecr+1)=iseed
7425  q(jgecr+2)=iglu
7426  q(jgecr+3)=ievar
7427  q(jgecr+4)=if5cc
7428  q(jgecr+5)=ineut
7429  q(jgecr+6)=iinte
7430  q(jgecr+7)=iferm
7431  q(jgecr+8)=iflat
7432  q(jgecr+9)=icoun
7433  q(jgecr+10)=refix
7434  q(jgecr+11)=iqden
7435  q(jgecr+12)=imudo
7436  q(jgecr+13)=ntgr
7437  q(jgecr+14)=idimuon
7438  q(jgecr+15)=iccha
7439  q(jgecr+16)=lome(1)
7440  q(jgecr+17)=ifiles
7441  q(jgecr+18)=ikat1
7442  q(jgecr+19)=ikat2
7443  q(jgecr+20)=ikat3
7444  q(jgecr+21)=ikat4
7445  q(jgecr+22)=ikat5
7446  q(jgecr+23)=ikat6
7447  q(jgecr+24)=inevt
7448  q(jgecr+25)=ijak1
7449  q(jgecr+26)=ijak2
7450  q(jgecr+27)=iitdk
7451  q(jgecr+28)=rptau
7452  q(jgecr+29)=rxkod
7453  q(jgecr+30)=lome(2)
7454  q(jgecr+31)=ihist
7455 
7456  RETURN
7457  END
7458 *CMZ : 1.01/44 15/12/95 18.07.48 by Piero Zucchelli
7459 *CMZ : 1.01/43 15/12/95 18.01.58 by Piero Zucchelli
7460 *CMZ : 1.01/22 27/05/95 16.23.58 BY PIERO ZUCCHELLI
7461 *CMZ : 1.01/14 14/05/95 11.26.28 BY PIERO ZUCCHELLI
7462 *CMZ : 1.01/08 05/03/95 11.35.13 BY PIERO ZUCCHELLI
7463 *CMZ : 1.01/03 05/03/95 00.19.19 BY PIERO ZUCCHELLI
7464 *CMZ : 1.00/00 25/07/94 14.29.34 BY PIERO ZUCCHELLI
7465 *CMZ : 1.00/00 19/07/94 15.47.28 BY PIERO ZUCCHELLI
7466 *-- AUTHOR :
7467  SUBROUTINE fermii(F)
7468 *KEEP,KEYS.
7469  common/cfread/space(5000)
7470  common/mykeys/ievar,if5cc,ineut,iinte,iferm,iflat,icoun,
7471  & refix,imudo,ikat1,ikat2,ikat3,ikat4,ikat5,ikat6,
7472  & inevt,ijak1,ijak2,iitdk,rptau,rxk0d,ntgr,idimuon,iglu,
7473  & iqden,lome(2),ifiles,iccha,iseed,idsubs,ionem,ehac,ipsel,
7474  & ihist
7475 
7476 
7477 *KEND.
7478 C.
7479 C.
7480 C.
7481  dimension f(3)
7482  REAL*4 f,eci,ptr,cs,sn,phi,ferm,fnuc,tmpx,tmpy,the
7483 C.
7484  DATA ferm/.027/
7485  DATA fnuc/.939/
7486 
7487  10 CONTINUE
7488  tmpx=rndmm(iseed)*ferm
7489  tmpy=rndmm(iseed)*sqrt(ferm)
7490 
7491  IF (sqrt(tmpx).GT.tmpy) THEN
7492  eci=tmpx
7493  ELSE
7494  goto 10
7495  ENDIF
7496 
7497 
7498 
7499 
7500  ptr = sqrt(eci*fnuc*2.)
7501 
7502  cs = 2.*rndmm(iseed)-1.
7503  sn = sqrt(1.-cs**2)
7504  phi = 6.2832*rndmm(iseed)
7505 
7506 
7507  f(1) = ptr*sn*cos(phi)
7508  f(2) = ptr*sn*sin(phi)
7509  f(3) = ptr*cs
7510  RETURN
7511  END
7512 *CMZ : 1.02/03 13/01/97 13.40.31 by P. Zucchelli
7513 *CMZ : 1.01/50 23/05/96 10.19.16 by Piero Zucchelli
7514 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
7515 *-- AUTHOR :
7516  SUBROUTINE filhep(N,IST,ID,JMO1,JMO2,JDA1,JDA2,P4,PINV,PHFLAG)
7517 C ----------------------------------------------------------------------
7518 C THIS SUBROUTINE FILLS ONE ENTRY INTO THE HEPEVT COMMON
7519 C AND UPDATES THE INFORMATION FOR AFFECTED MOTHER ENTRIES
7520 C
7521 C WRITTEN BY MARTIN W. GRUENEWALD (91/01/28)
7522 C
7523 C CALLED BY : ZTOHEP,BTOHEP,DWLUXY
7524 C ----------------------------------------------------------------------
7525 C
7526  parameter(nmxhep=2000)
7527 *KEEP,HEPEVT.
7528  DOUBLE PRECISION phep,vhep
7529  common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),
7530  &jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)
7531  SAVE /hepevt/
7532 
7533 *KEND.
7534  common/phoqed/qedrad(nmxhep)
7535  LOGICAL qedrad
7536  SAVE /phoqed/
7537  LOGICAL phflag
7538 C
7539  REAL*4 p4(4)
7540 C
7541 C CHECK ADDRESS MODE
7542  IF (n.EQ.0) THEN
7543 C
7544 C APPEND MODE
7545  ihep=nhep+1
7546  ELSE IF (n.GT.0) THEN
7547 C
7548 C ABSOLUTE POSITION
7549  ihep=n
7550  ELSE
7551 C
7552 C RELATIVE POSITION
7553  ihep=nhep+n
7554  END IF
7555 C
7556 C CHECK ON IHEP
7557  IF ((ihep.LE.0).OR.(ihep.GT.nmxhep)) RETURN
7558 C
7559 C ADD ENTRY
7560  nhep=ihep
7561  isthep(ihep)=ist
7562  idhep(ihep)=id
7563  jmohep(1,ihep)=jmo1
7564  IF(jmo1.LT.0)jmohep(1,ihep)=jmohep(1,ihep)+ihep
7565  jmohep(2,ihep)=jmo2
7566  IF(jmo2.LT.0)jmohep(2,ihep)=jmohep(2,ihep)+ihep
7567  jdahep(1,ihep)=jda1
7568  jdahep(2,ihep)=jda2
7569 C
7570  DO i=1,4
7571  phep(i,ihep)=p4(i)
7572 C
7573 C KORAL-B AND KORAL-Z DO NOT PROVIDE VERTEX AND/OR LIFETIME INFORMATIONS
7574  vhep(i,ihep)=0.0
7575  END DO
7576  phep(5,ihep)=pinv
7577 C FLAG FOR PHOTOS...
7578  qedrad(ihep)=phflag
7579 C
7580 C UPDATE PROCESS:
7581  DO ip=jmohep(1,ihep),jmohep(2,ihep)
7582  IF(ip.GT.0)THEN
7583 C
7584 C IF THERE IS A DAUGHTER AT IHEP, MOTHER ENTRY AT IP HAS DECAYED
7585  IF(isthep(ip).EQ.1)isthep(ip)=2
7586 C
7587 C AND DAUGHTER POINTERS OF MOTHER ENTRY MUST BE UPDATED
7588  IF(jdahep(1,ip).EQ.0)THEN
7589  jdahep(1,ip)=ihep
7590  jdahep(2,ip)=ihep
7591  ELSE
7592  jdahep(2,ip)=max(ihep,jdahep(2,ip))
7593  END IF
7594  END IF
7595  END DO
7596 C
7597  RETURN
7598  END
7599 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
7600 *-- AUTHOR :
7601 C **********************************************************************
7602 
7603  FUNCTION flgint(Z)
7604 
7605 C...GLUON CONTRIBUTION INTEGRAND TO QCD LONGITUDINAL STRUCTURE FUNCTION.
7606 
7607  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
7608  COMMON /linter/ pari(40),ewqc(2,2,8),qc(8),zl(2,4),zq(2,8),pq(17)
7609  COMMON /linteg/ ntot,npass
7610  dimension xpq(-6:6)
7611  DATA pi/3.14159/
7612  ntot=ntot+1
7613  CALL lnstrf(z,q2,xpq)
7614  flgint=20./9.*parl(25)/pi*(x/z)**2*(1.-x/z)/z*xpq(0)
7615  npass=npass+1
7616 
7617  RETURN
7618  END
7619 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
7620 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
7621 *-- AUTHOR :
7622 C **********************************************************************
7623 
7624  SUBROUTINE flintg(CFLQ,CFLG,CFLM)
7625 
7626 C...EVENT-BY-EVENT CALCULATION OF CONTRIBUTION TO LONGITUDINAL
7627 C...STRUCTURE FUNCTION FROM QCD AND TARGET MASS EFFECTS.
7628 
7629  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
7630  COMMON /linteg/ ntot,npass
7631  EXTERNAL flqint,flgint,fltint
7632 
7633  lqcd=mod(lst(11),10)
7634  ltm=mod(lst(11)/10,10)
7635  lht=lst(11)/100
7636  parl(25)=ulalps(q2)
7637  IF(lqcd.EQ.2) THEN
7638 C...FL FROM QCD, QUARK AND GLUON CONTRIBUTIONS.
7639  accur=parl(11)
7640  it=0
7641  10 it=it+1
7642  ntot=0
7643  npass=0
7644  eps=accur
7645  CALL gadap(x,1.,flqint,eps,cflq)
7646  IF(cflq.LT.1) THEN
7647  accur=cflq*parl(11)
7648  IF(it.LT.2) goto 10
7649  ENDIF
7650  accur=parl(11)
7651  it=0
7652  20 it=it+1
7653  ntot=0
7654  npass=0
7655  eps=accur
7656  CALL gadap(x,1.,flgint,eps,cflg)
7657  IF(cflg.LT.1.) THEN
7658  accur=cflg*parl(11)
7659  IF(it.LT.2) goto 20
7660  ENDIF
7661  ENDIF
7662  IF(ltm.EQ.2) THEN
7663  accur=parl(11)
7664  it=0
7665  30 it=it+1
7666  ntot=0
7667  npass=0
7668  eps=accur
7669  CALL gadap(x,1.,fltint,eps,cflm)
7670  IF(cflm.LT.1.) THEN
7671  accur=cflm*parl(11)
7672  IF(it.LT.2) goto 30
7673  ENDIF
7674  ENDIF
7675 
7676  RETURN
7677  END
7678 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
7679 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
7680 *-- AUTHOR :
7681 C **********************************************************************
7682 
7683  SUBROUTINE flipol(FLQ,FLG,FLM)
7684 
7685 C...QCD AND TARGET MASS CONTRIBUTIONS TO LONGITUDINAL STRUCTURE FUNCTION
7686 C...FROM INTERPOLATION ON X,Q2 GRID.
7687 
7688  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
7689  COMMON /flgrid/ nfx,nfq,xr(2),qr(2),flqt(41,16),flgt(41,16),
7690  &flmt(41,16)
7691  DATA nout/0/,nwarn/10/
7692 
7693  lqcd=mod(lst(11),10)
7694  ltm=mod(lst(11)/10,10)
7695  lht=lst(11)/100
7696  xp=x
7697  q2p=q2
7698 C...NOTE: TINY MISMATCH BETWEEN PRESENT X-VALUE AND THOSE ON GRID.
7699  qr(2)=x*parl(21)
7700  IF(qr(1).GT.qr(2)) RETURN
7701  IF(x.LT.xr(1).OR.x.GT.xr(2).OR.
7702  +q2.LT.qr(1).OR.q2.GT.qr(2)) THEN
7703 C...X AND/OR Q2 OUTSIDE GRID LIMITS, WRITE WARNING FOR FIRST NWARN CASES
7704  IF(lst(2).GE.0) THEN
7705  nout=nout+1
7706  IF(lst(3).GE.1.AND.nout.LE.nwarn) WRITE(6,10000) x,q2,nwarn
7707  ENDIF
7708  IF(x.LT.xr(1)) xp=xr(1)
7709  IF(x.GT.xr(2)) xp=xr(2)
7710  IF(q2.LT.qr(1)) q2p=qr(1)
7711  IF(q2.GT.qr(2)) q2p=qr(2)
7712  ENDIF
7713 
7714  ix=(alog10(xp)-alog10(xr(1)))/
7715  &(alog10(xr(2))-alog10(xr(1)))*(nfx-1)+1
7716  iq=(alog10(q2p)-alog10(qr(1)))/
7717  &(alog10(qr(2))-alog10(qr(1)))*(nfq-1)+1
7718  ix=min(ix,nfx-1)
7719  iq=min(iq,nfq-1)
7720  q2l=10**(alog10(qr(1))+(alog10(qr(2))-alog10(qr(1)))*
7721  &(iq-1)/(nfq-1))
7722  q2h=10**(alog10(qr(1))+(alog10(qr(2))-alog10(qr(1)))*
7723  &(iq )/(nfq-1))
7724  xl=10**(alog10(xr(1))+(alog10(xr(2))-alog10(xr(1)))*
7725  &(ix-1)/(nfx-1))
7726  xh=10**(alog10(xr(1))+(alog10(xr(2))-alog10(xr(1)))*
7727  &(ix )/(nfx-1))
7728  qd=(q2p-q2l)/(q2h-q2l)
7729  xd=(xp-xl)/(xh-xl)
7730 
7731  IF(lqcd.EQ.1) THEN
7732  x1p=(flqt(ix+1,iq)-flqt(ix,iq))*xd+flqt(ix,iq)
7733  x2p=(flqt(ix+1,iq+1)-flqt(ix,iq+1))*xd+flqt(ix,iq+1)
7734  flq=(x2p-x1p)*qd+x1p
7735  x1p=(flgt(ix+1,iq)-flgt(ix,iq))*xd+flgt(ix,iq)
7736  x2p=(flgt(ix+1,iq+1)-flgt(ix,iq+1))*xd+flgt(ix,iq+1)
7737  flg=(x2p-x1p)*qd+x1p
7738  ENDIF
7739  IF(ltm.EQ.1) THEN
7740  x1p=(flmt(ix+1,iq)-flmt(ix,iq))*xd+flmt(ix,iq)
7741  x2p=(flmt(ix+1,iq+1)-flmt(ix,iq+1))*xd+flmt(ix,iq+1)
7742  flm=(x2p-x1p)*qd+x1p
7743  ENDIF
7744 
7745  RETURN
7746 10000 FORMAT(' WARNING: X=',f7.4,' OR Q2=',f6.1,' OUTSIDE GRID,',
7747  &' FOR FL INTERPOLATION',/,10x,'VALUE ON GRID LIMIT USED.',
7748  &' ONLY FIRST',i5,' WARNINGS PRINTED.',/)
7749  END
7750 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
7751 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
7752 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
7753 *-- AUTHOR :
7754 C **********************************************************************
7755 
7756  FUNCTION flqint(Z)
7757 
7758 C...QUARK CONTRIBUTION INTEGRAND TO QCD LONGITUDINAL STRUCTURE FUNCTION.
7759 
7760  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
7761  COMMON /linter/ pari(40),ewqc(2,2,8),qc(8),zl(2,4),zq(2,8),pq(17)
7762  COMMON /linteg/ ntot,npass
7763  dimension xpq(-6:6)
7764  DATA pi/3.14159/
7765  ntot=ntot+1
7766  CALL lnstrf(z,q2,xpq)
7767  flqint=0.
7768  DO 10 i=-lst(12),lst(12)
7769  IF(i.EQ.0) goto 10
7770  flqint=flqint+qc(iabs(i))**2*xpq(i)
7771  10 CONTINUE
7772  flqint=4./3.*parl(25)/pi*(x/z)**2*flqint/z
7773  npass=npass+1
7774 
7775  RETURN
7776  END
7777 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
7778 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
7779 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
7780 *-- AUTHOR :
7781 C **********************************************************************
7782 
7783  SUBROUTINE fltabl
7784 
7785 C...INTEGRATES THE LONGITUDINAL STRUCTURE FUNCTION, STORE ON GRID
7786 C...IN X, Q**2.
7787 
7788  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
7789  COMMON /lintrl/ psave(3,4,5),ksave(4),xmin,xmax,ymin,ymax,
7790  +q2min,q2max,w2min,w2max,ilep,inu,ig,iz
7791  COMMON /linteg/ ntot,npass
7792  COMMON /flgrid/ nfx,nfq,xr(2),qr(2),flqt(41,16),flgt(41,16),
7793  +flmt(41,16)
7794  EXTERNAL flqint,flgint,fltint
7795 
7796  lqcd=mod(lst(11),10)
7797  ltm=mod(lst(11)/10,10)
7798  lht=lst(11)/100
7799  IF(lst(3).GE.3) WRITE(6,10000) lst(11),lqcd,ltm,lht
7800  IF(lqcd.LT.1.AND.ltm.LT.1) RETURN
7801  CALL ltimex(t1)
7802  DO 10 ix=1,nfx
7803  DO 10 iq=1,nfq
7804  flqt(ix,iq)=0.
7805  flgt(ix,iq)=0.
7806  10 flmt(ix,iq)=0.
7807  qr(1)=q2min
7808  xr(1)=xmin
7809  xr(2)=xmax
7810  DO 60 ix=1,nfx
7811  x=10**(alog10(xr(1))+(alog10(xr(2))-alog10(xr(1)))*(ix-1)/(nfx-
7812  + 1))
7813  qr(2)=x*parl(21)
7814  IF(qr(1).GT.qr(2)) goto 60
7815  lq=0
7816  DO 50 iq=1,nfq
7817  q2=10**(alog10(qr(1))+(alog10(qr(2))-alog10(qr(1)))* (iq-1)/
7818  + (nfq-1))
7819 CTEST IF(LQ.GT.0) GOTO 500
7820  IF(q2.GT.parl(21)) lq=lq+1
7821  y=q2/(parl(21)*x)
7822  IF(y.LT.0.0.OR.y.GT.1.0) lq=lq+1
7823  parl(25)=ulalps(q2)
7824  IF(lqcd.EQ.1) THEN
7825 C...QUARK PART.
7826  accur=parl(11)
7827  it=0
7828  20 it=it+1
7829  ntot=0
7830  npass=0
7831  eps=accur
7832  CALL gadap(x,1.,flqint,eps,flq)
7833  IF(flq.LT.1) THEN
7834  accur=flq*parl(11)
7835  IF(it.LT.2) goto 20
7836  ENDIF
7837  flqt(ix,iq)=flq
7838 C...GLUON PART.
7839  accur=parl(11)
7840  it=0
7841  30 it=it+1
7842  ntot=0
7843  npass=0
7844  eps=accur
7845  CALL gadap(x,1.,flgint,eps,flg)
7846  IF(flg.LT.1.) THEN
7847  accur=flg*parl(11)
7848  IF(it.LT.2) goto 30
7849  ENDIF
7850  flgt(ix,iq)=flg
7851  ENDIF
7852  IF(ltm.EQ.1) THEN
7853 C...TARGET MASS PART.
7854  accur=parl(11)
7855  it=0
7856  40 it=it+1
7857  ntot=0
7858  npass=0
7859  eps=accur
7860  CALL gadap(x,1.,fltint,eps,flm)
7861  IF(flm.LT.1) THEN
7862  accur=flm*parl(11)
7863  IF(it.LT.2) goto 40
7864  ENDIF
7865  flmt(ix,iq)=flm
7866  ENDIF
7867  50 CONTINUE
7868  60 CONTINUE
7869  70 CONTINUE
7870  CALL ltimex(t2)
7871  IF(lst(3).GE.3) WRITE(6,10100) t2-t1
7872  RETURN
7873 
7874 10000 FORMAT(' INITIALISATION FOR FL; QCD, TARGET MASS, HIGHER TWIST: ',
7875  +/,' LST(11) =',i5,' --> LQCD, LTM, LHT =',3i3)
7876 10100 FORMAT(' FL INTEGRATIONS PERFORMED IF LQCD=1 AND/OR LTM=1, ',
7877  +'RESULTS ON GRID.'/,' TIME FOR FL INTEGRATIONS IS ',f7.1,' SEC.')
7878  END
7879 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
7880 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
7881 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
7882 *-- AUTHOR :
7883 C **********************************************************************
7884 
7885  FUNCTION fltint(Z)
7886 
7887 C...INTEGRAND FOR TARGET MASS CORRECTION CONTRIBUTION TO
7888 C...QUARK LONGITUDINAL STRUCTURE FUNCTION
7889 
7890  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
7891  COMMON /linter/ pari(40),ewqc(2,2,8),qc(8),zl(2,4),zq(2,8),pq(17)
7892  COMMON /linteg/ ntot,npass
7893  dimension xpq(-6:6)
7894  DATA pm2/0.8804/
7895  ntot=ntot+1
7896  CALL lnstrf(z,q2,xpq)
7897  fltint=0.
7898  DO 10 i=-lst(12),lst(12)
7899  IF(i.EQ.0) goto 10
7900  fltint=fltint+qc(iabs(i))**2*xpq(i)
7901  10 CONTINUE
7902  fltint=4.*pm2/q2*(x/z)**2*x*fltint
7903  npass=npass+1
7904 
7905  RETURN
7906  END
7907 *CMZ : 1.02/01 12/01/97 16.42.39 by J. Brunner
7908 *CMZ : 1.01/50 23/05/96 12.34.50 by Piero Zucchelli
7909 *-- Author :
7910  SUBROUTINE forced_decay(NUFORCE,ISTATUS)
7911 
7912  common/ntupl10/ nutype,iparent,eparent,xdecay,ydecay,zdecay,
7913  + pxpar,pypar,pzpar,xdet,ydet,xl,pxnu,pynu,pznu,
7914  + nprot
7915 
7916  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000), kfdp(2000,5)
7917  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
7918  REAL bratkp(10)
7919  REAL bratk0(10)
7920  DATA zdetc/82342.0/
7921  DATA detx/250./
7922  DATA dety/250./
7923 
7924  istatus=3
7925  IF (nuforce.LE.50) THEN
7926 
7927  r1=0
7928  r2=0
7929 
7930 * R1= other K CHARGED decays Br's
7931  DO io=361,366
7932  bratkp(io-360)=brat(io)
7933  ENDDO
7934  DO io=361,364
7935  mdme(io,1)=0
7936  r1=r1+brat(io)
7937  ENDDO
7938  mdme(366,1)=0
7939  r1=r1+brat(366)
7940 
7941 * R2= other K NEUTRAL decays Br's
7942  DO io=958,965
7943  bratk0(io-957)=brat(io)
7944  ENDDO
7945  DO io=958,959
7946  mdme(io,1)=0
7947  r2=r2+brat(io)
7948  ENDDO
7949  DO io=962,965
7950  mdme(io,1)=0
7951  r2=r2+brat(io)
7952  ENDDO
7953 
7954 * k+ nu e decays branching ratio
7955  edeckp=1-r1
7956  edeck0=1-r2
7957  ema=max(edeckp,edeck0)
7958  e1=edeckp/ema
7959  e2=edeck0/ema
7960 * now restore BRAT for charged kaon
7961  brat(361)=1-e1
7962  mdme(361,1)=1
7963  DO io=365,365
7964  brat(io)=brat(io)*e1/edeckp
7965  ENDDO
7966  brat(958)=1-e2
7967  mdme(958,1)=1
7968  DO io=960,961
7969  brat(io)=brat(io)*e2/edeck0
7970  ENDDO
7971  xfact=1/ema
7972 
7973 
7974  ENDIF
7975 
7976  IF (isfirst.EQ.0) THEN
7977  isfirst=1
7978  WRITE(*,*)' +++IMPORTANT!! GBEAM ENHANCED MODE:'
7979  WRITE(*,*)' +++STATISTICAL AMPLIFICATION OF'
7980  WRITE(*,*)' +++NEUTRINOS OF TYPE ',nuforce
7981  WRITE(*,*)' +++BY FACTOR ',xfact
7982  CALL lulist(12)
7983  ENDIF
7984 
7985 
7986  IF (iparent.EQ.9) THEN
7987  lparent=-211
7988  ELSEIF(iparent.EQ.8) THEN
7989  lparent=211
7990  ELSEIF(iparent.EQ.11) THEN
7991  lparent=321
7992  ELSEIF(iparent.EQ.12) THEN
7993  lparent=-321
7994  ELSEIF(iparent.EQ.5) THEN
7995  lparent=-13
7996  ELSEIF(iparent.EQ.6) THEN
7997  lparent=13
7998  ELSEIF(iparent.EQ.10) THEN
7999  lparent=130
8000  ELSE
8001  WRITE(*,*)'WARNING: UNKNOWN GEANT PARENT ID=',iparent
8002  istatus=1
8003  ENDIF
8004 
8005  IF (nuforce.EQ.51) THEN
8006  luforce=14
8007  ELSEIF(nuforce.EQ.52) THEN
8008  luforce=-14
8009  ELSEIF(nuforce.EQ.49) THEN
8010  luforce=12
8011  ELSEIF(nuforce.EQ.50) THEN
8012  luforce=-12
8013  ENDIF
8014 
8015 
8016  10 CONTINUE
8017  n=1
8018  k(1,1)=5
8019  k(1,2)=lparent
8020 
8021  p(1,1)=pxpar
8022  p(1,2)=pypar
8023  p(1,3)=pzpar
8024  p(1,5)=ulmass(lparent)
8025  p(1,4)=sqrt(p(1,1)**2+p(1,2)**2+p(1,3)**2+p(1,5)**2)
8026 
8027 * WRITE(*,*)'BEFORE:'
8028 * CALL LULIST(3)
8029  CALL ludecy(1)
8030 * WRITE(*,*)'AFTER:'
8031 * CALL LULIST(3)
8032 
8033  DO i=2,n
8034  IF (k(i,2).EQ.luforce) THEN
8035  tmpxl=zdetc-zdecay
8036  tmpxdet=tmpxl*p(i,1)/p(i,3)+xdecay
8037  tmpydet=tmpxl*p(i,2)/p(i,3)+ydecay
8038 * following line is wrong!!! for debugging
8039  IF (abs(tmpxdet).GT.detx.OR.abs(tmpydet).GT.dety) goto 10
8040  xl=tmpxl
8041  xdet=tmpxdet
8042  ydet=tmpydet
8043  pxnu=p(i,1)
8044  pynu=p(i,2)
8045  pznu=p(i,3)
8046  nutype=nuforce
8047  istatus=0
8048  ENDIF
8049  ENDDO
8050 
8051  DO io=958,965
8052  mdme(io,1)=1
8053  brat(io)=bratk0(io-957)
8054  ENDDO
8055  DO io=361,366
8056  mdme(io,1)=1
8057  brat(io)=bratkp(io-360)
8058  ENDDO
8059 
8060  RETURN
8061  END
8062 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
8063 *CMZ : 1.00/00 10/08/94 16.29.32 BY PIERO ZUCCHELLI
8064 *-- AUTHOR :
8065  FUNCTION form1(MNUM,QQ,S1,SDWA)
8066 C ==================================================================
8067 C FORMFACTORFOR F1 FOR 3 SCALAR FINAL STATE
8068 C R. FISHER, J. WESS AND F. WAGNER Z. PHYS C3 (1980) 313
8069 C H. GEORGI, WEAK INTERACTIONS AND MODERN PARTICLE THEORY,
8070 C THE BENJAMIN/CUMMINGS PUB. CO., INC. 1984.
8071 C R. DECKER, E. MIRKES, R. SAUER, Z. WAS KARLSRUHE PREPRINT TTP92-25
8072 C AND ERRATUM !!!!!!
8073 C ==================================================================
8074 C
8075  COMPLEX form1,wigner,wigfor,fpikm,bwigm
8076  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
8077  + ,ampiz,ampi,amro,gamro,ama1,gama1
8078  + ,amk,amkz,amkst,gamkst
8079 C
8080  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
8081  + ,ampiz,ampi,amro,gamro,ama1,gama1
8082  + ,amk,amkz,amkst,gamkst
8083  wigner(a,b,c)= cmplx(1.0,0.0)/cmplx(a-b**2,b*c)
8084  IF (mnum.EQ.0) THEN
8085 C ------------ 3 PI HADRONIC STATE (A1)
8086  gamax=gama1*gfun(qq)/gfun(ama1**2)
8087  form1=ama1**2*wigner(qq,ama1,gamax)*fpikm(sqrt(s1),ampi,ampi)
8088  ELSEIF (mnum.EQ.1) THEN
8089 C ------------ K- PI- K+
8090  form1=bwigm(s1,amkst,gamkst,ampi,amk)
8091  gamax=gama1*gfun(qq)/gfun(ama1**2)
8092  form1=ama1**2*wigner(qq,ama1,gamax)*form1
8093  ELSEIF (mnum.EQ.2) THEN
8094 C ------------ K0 PI- K0B
8095  form1=bwigm(s1,amkst,gamkst,ampi,amk)
8096  gamax=gama1*gfun(qq)/gfun(ama1**2)
8097  form1=ama1**2*wigner(qq,ama1,gamax)*form1
8098  ELSEIF (mnum.EQ.3) THEN
8099 C ------------ K- K0 PI0
8100  form1=0.0
8101  gamax=gama1*gfun(qq)/gfun(ama1**2)
8102  form1=ama1**2*wigner(qq,ama1,gamax)*form1
8103  ELSEIF (mnum.EQ.4) THEN
8104 C ------------ PI0 PI0 K-
8105  xm2=1.402
8106  gam2=0.174
8107  form1=bwigm(s1,amkst,gamkst,amk,ampi)
8108  form1=wigfor(qq,xm2,gam2)*form1
8109  ELSEIF (mnum.EQ.5) THEN
8110 C ------------ K- PI- PI+
8111  xm2=1.402
8112  gam2=0.174
8113  form1=wigfor(qq,xm2,gam2)*fpikm(sqrt(s1),ampi,ampi)
8114  ELSEIF (mnum.EQ.6) THEN
8115  form1=0.0
8116  ELSEIF (mnum.EQ.7) THEN
8117 C -------------- ETA PI- PI0 FINAL STATE
8118  form1=0.0
8119  ENDIF
8120 C
8121  END
8122 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
8123 *CMZ : 1.00/00 10/08/94 16.29.32 BY PIERO ZUCCHELLI
8124 *-- AUTHOR :
8125  FUNCTION form2(MNUM,QQ,S1,SDWA)
8126 C ==================================================================
8127 C FORMFACTORFOR F2 FOR 3 SCALAR FINAL STATE
8128 C R. FISHER, J. WESS AND F. WAGNER Z. PHYS C3 (1980) 313
8129 C H. GEORGI, WEAK INTERACTIONS AND MODERN PARTICLE THEORY,
8130 C THE BENJAMIN/CUMMINGS PUB. CO., INC. 1984.
8131 C R. DECKER, E. MIRKES, R. SAUER, Z. WAS KARLSRUHE PREPRINT TTP92-25
8132 C AND ERRATUM !!!!!!
8133 C ==================================================================
8134 C
8135  COMPLEX form2,wigner,wigfor,fpikm,bwigm
8136  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
8137  + ,ampiz,ampi,amro,gamro,ama1,gama1
8138  + ,amk,amkz,amkst,gamkst
8139 C
8140  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
8141  + ,ampiz,ampi,amro,gamro,ama1,gama1
8142  + ,amk,amkz,amkst,gamkst
8143  wigner(a,b,c)= cmplx(1.0,0.0)/cmplx(a-b**2,b*c)
8144  IF (mnum.EQ.0) THEN
8145 C ------------ 3 PI HADRONIC STATE (A1)
8146  gamax=gama1*gfun(qq)/gfun(ama1**2)
8147  form2=ama1**2*wigner(qq,ama1,gamax)*fpikm(sqrt(s1),ampi,ampi)
8148  ELSEIF (mnum.EQ.1) THEN
8149 C ------------ K- PI- K+
8150  gamax=gama1*gfun(qq)/gfun(ama1**2)
8151  form2=ama1**2*wigner(qq,ama1,gamax)*fpikm(sqrt(s1),ampi,ampi)
8152  ELSEIF (mnum.EQ.2) THEN
8153 C ------------ K0 PI- K0B
8154  gamax=gama1*gfun(qq)/gfun(ama1**2)
8155  form2=ama1**2*wigner(qq,ama1,gamax)*fpikm(sqrt(s1),ampi,ampi)
8156  ELSEIF (mnum.EQ.3) THEN
8157 C ------------ K- K0 PI0
8158  gamax=gama1*gfun(qq)/gfun(ama1**2)
8159  form2=ama1**2*wigner(qq,ama1,gamax)*fpikm(sqrt(s1),ampi,ampi)
8160  ELSEIF (mnum.EQ.4) THEN
8161 C ------------ PI0 PI0 K-
8162  xm2=1.402
8163  gam2=0.174
8164  form2=bwigm(s1,amkst,gamkst,amk,ampi)
8165  form2=wigfor(qq,xm2,gam2)*form2
8166  ELSEIF (mnum.EQ.5) THEN
8167 C ------------ K- PI- PI+
8168  xm2=1.402
8169  gam2=0.174
8170  form2=bwigm(s1,amkst,gamkst,amk,ampi)
8171  form2=wigfor(qq,xm2,gam2)*form2
8172 C
8173  ELSEIF (mnum.EQ.6) THEN
8174  xm2=1.402
8175  gam2=0.174
8176  form2=wigfor(qq,xm2,gam2)*fpikm(sqrt(s1),ampi,ampi)
8177 C
8178  ELSEIF (mnum.EQ.7) THEN
8179 C -------------- ETA PI- PI0 FINAL STATE
8180  form2=0.0
8181  ENDIF
8182 C
8183  END
8184 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
8185 *CMZ : 1.00/00 10/08/94 16.29.32 BY PIERO ZUCCHELLI
8186 *-- AUTHOR :
8187  FUNCTION form3(MNUM,QQ,S1,SDWA)
8188 C ==================================================================
8189 C FORMFACTORFOR F3 FOR 3 SCALAR FINAL STATE
8190 C R. FISHER, J. WESS AND F. WAGNER Z. PHYS C3 (1980) 313
8191 C H. GEORGI, WEAK INTERACTIONS AND MODERN PARTICLE THEORY,
8192 C THE BENJAMIN/CUMMINGS PUB. CO., INC. 1984.
8193 C R. DECKER, E. MIRKES, R. SAUER, Z. WAS KARLSRUHE PREPRINT TTP92-25
8194 C AND ERRATUM !!!!!!
8195 C ==================================================================
8196 C
8197  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
8198  + ,ampiz,ampi,amro,gamro,ama1,gama1
8199  + ,amk,amkz,amkst,gamkst
8200 C
8201  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
8202  + ,ampiz,ampi,amro,gamro,ama1,gama1
8203  + ,amk,amkz,amkst,gamkst
8204  COMPLEX form3
8205  IF (mnum.EQ.6) THEN
8206  form3=cmplx(0.0)
8207  ELSE
8208  form3=cmplx(0.0)
8209  ENDIF
8210  form3=0
8211  END
8212 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
8213 *CMZ : 1.00/00 10/08/94 16.29.32 BY PIERO ZUCCHELLI
8214 *-- AUTHOR :
8215  FUNCTION form4(MNUM,QQ,S1,S2,S3)
8216 C ==================================================================
8217 C FORMFACTORFOR F4 FOR 3 SCALAR FINAL STATE
8218 C R. DECKER, IN PREPARATION
8219 C R. DECKER, E. MIRKES, R. SAUER, Z. WAS KARLSRUHE PREPRINT TTP92-25
8220 C AND ERRATUM !!!!!!
8221 C ==================================================================
8222 C
8223  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
8224  + ,ampiz,ampi,amro,gamro,ama1,gama1
8225  + ,amk,amkz,amkst,gamkst
8226 C
8227  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
8228  + ,ampiz,ampi,amro,gamro,ama1,gama1
8229  + ,amk,amkz,amkst,gamkst
8230  COMPLEX form4,wigner,fpikm
8231  REAL*4 m
8232  wigner(a,b,c)=cmplx(1.0,0.0) /cmplx(a-b**2,b*c)
8233  IF (mnum.EQ.0) THEN
8234 C ------------ 3 PI HADRONIC STATE (A1)
8235  g1=5.8
8236  g2=6.08
8237  fpip=0.02
8238  ampip=1.3
8239  gampip=0.3
8240  s=qq
8241  g=gampip
8242  xm1=ampiz
8243  xm2=amro
8244  m =ampip
8245  IF (s.GT.(xm1+xm2)**2) THEN
8246  qs=sqrt(abs((s -(xm1+xm2)**2)*(s -(xm1-xm2)**2)))/sqrt(s)
8247  qm=sqrt(abs((m**2-(xm1+xm2)**2)*(m**2-(xm1-xm2)**2)))/m
8248  w=sqrt(s)
8249  gs=g*(m/w)**2*(qs/qm)**5
8250  ELSE
8251  gs=0.0
8252  ENDIF
8253  gamx=gs*w/m
8254  form4=g1*g2*fpip/amro**4/ampip**2
8255  + *ampip**2*wigner(qq,ampip,gamx)
8256  + *( s1*(s2-s3)*fpikm(sqrt(s1),ampiz,ampiz)
8257  + +s2*(s1-s3)*fpikm(sqrt(s2),ampiz,ampiz) )
8258  ELSEIF (mnum.EQ.1) THEN
8259 C ------------ 3 PI HADRONIC STATE (A1)
8260  g1=5.8
8261  g2=6.08
8262  fpip=0.02
8263  ampip=1.3
8264  gampip=0.3
8265  s=qq
8266  g=gampip
8267  xm1=ampiz
8268  xm2=amro
8269  m =ampip
8270  IF (s.GT.(xm1+xm2)**2) THEN
8271  qs=sqrt(abs((s -(xm1+xm2)**2)*(s -(xm1-xm2)**2)))/sqrt(s)
8272  qm=sqrt(abs((m**2-(xm1+xm2)**2)*(m**2-(xm1-xm2)**2)))/m
8273  w=sqrt(s)
8274  gs=g*(m/w)**2*(qs/qm)**5
8275  ELSE
8276  gs=0.0
8277  ENDIF
8278  gamx=gs*w/m
8279  form4=g1*g2*fpip/amro**4/ampip**2
8280  + *ampip**2*wigner(qq,ampip,gamx)
8281  + *( s1*(s2-s3)*fpikm(sqrt(s1),ampiz,ampiz)
8282  + +s2*(s1-s3)*fpikm(sqrt(s2),ampiz,ampiz) )
8283  ELSE
8284  form4=cmplx(0.0,0.0)
8285  ENDIF
8286 C ---- THIS FORMFACTOR IS SWITCHED OFF .. .
8287  form4=cmplx(0.0,0.0)
8288  END
8289 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
8290 *CMZ : 1.00/00 10/08/94 16.29.32 BY PIERO ZUCCHELLI
8291 *-- AUTHOR :
8292  FUNCTION form5(MNUM,QQ,S1,S2)
8293 C ==================================================================
8294 C FORMFACTORFOR F5 FOR 3 SCALAR FINAL STATE
8295 C G. KRAMER, W. PALMER, S. PINSKY, PHYS. REV. D30 (1984) 89.
8296 C G. KRAMER, W. PALMER Z. PHYS. C25 (1984) 195.
8297 C R. DECKER, E. MIRKES, R. SAUER, Z. WAS KARLSRUHE PREPRINT TTP92-25
8298 C AND ERRATUM !!!!!!
8299 C ==================================================================
8300 C
8301  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
8302  + ,ampiz,ampi,amro,gamro,ama1,gama1
8303  + ,amk,amkz,amkst,gamkst
8304 C
8305  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
8306  + ,ampiz,ampi,amro,gamro,ama1,gama1
8307  + ,amk,amkz,amkst,gamkst
8308  COMPLEX form5,wigner,fpikm,fpikmd,bwigm
8309  wigner(a,b,c)=cmplx(1.0,0.0)/cmplx(a-b**2,b*c)
8310  IF (mnum.EQ.0) THEN
8311 C ------------ 3 PI HADRONIC STATE (A1)
8312  form5=0.0
8313  ELSEIF (mnum.EQ.1) THEN
8314 C ------------ K- PI- K+
8315  elpha=-0.2
8316  form5=fpikmd(sqrt(qq),ampi,ampi)/(1+elpha) *( fpikm(sqrt(s2),
8317  + ampi,ampi) +elpha*bwigm(s1,amkst,gamkst,ampi,amk))
8318  ELSEIF (mnum.EQ.2) THEN
8319 C ------------ K0 PI- K0B
8320  elpha=-0.2
8321  form5=fpikmd(sqrt(qq),ampi,ampi)/(1+elpha) *( fpikm(sqrt(s2),
8322  + ampi,ampi) +elpha*bwigm(s1,amkst,gamkst,ampi,amk))
8323  ELSEIF (mnum.EQ.3) THEN
8324 C ------------ K- K0 PI0
8325  form5=0.0
8326  ELSEIF (mnum.EQ.4) THEN
8327 C ------------ PI0 PI0 K-
8328  form5=0.0
8329  ELSEIF (mnum.EQ.5) THEN
8330 C ------------ K- PI- PI+
8331  elpha=-0.2
8332  form5=bwigm(qq,amkst,gamkst,ampi,amk)/(1+elpha)
8333  + *( fpikm(sqrt(s1),ampi,ampi)
8334  + +elpha*bwigm(s2,amkst,gamkst,ampi,amk))
8335  ELSEIF (mnum.EQ.6) THEN
8336 C ------------ PI- K0B PI0
8337  elpha=-0.2
8338  form5=bwigm(qq,amkst,gamkst,ampi,amkz)/(1+elpha)
8339  + *( fpikm(sqrt(s2),ampi,ampi)
8340  + +elpha*bwigm(s1,amkst,gamkst,ampi,amk))
8341  ELSEIF (mnum.EQ.7) THEN
8342 C -------------- ETA PI- PI0 FINAL STATE
8343  form5=fpikmd(sqrt(qq),ampi,ampi)*fpikm(sqrt(s1),ampi,ampi)
8344  ENDIF
8345 C
8346  END
8347 *CMZ : 1.00/00 10/08/94 16.29.32 BY PIERO ZUCCHELLI
8348 *-- AUTHOR :
8349  FUNCTION formom(XMAA,XMOM)
8350 C ==================================================================
8351 C FORMFACTORFOR PI-PI0 GAMMA FINAL STATE
8352 C R. DECKER, Z. PHYS C36 (1987) 487.
8353 C ==================================================================
8354  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
8355  * ,ampiz,ampi,amro,gamro,ama1,gama1
8356  * ,amk,amkz,amkst,gamkst
8357 C
8358  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
8359  * ,ampiz,ampi,amro,gamro,ama1,gama1
8360  * ,amk,amkz,amkst,gamkst
8361  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
8362  REAL*4 gfermi,gv,ga,ccabib,scabib,gamel
8363  COMMON /testa1/ keya1
8364  COMPLEX bwign,formom
8365  DATA icont /1/
8366 * THIS INLINE FUNCT. CALCULATES THE SCALAR PART OF THE PROPAGATOR
8367  bwign(xm,am,gamma)=1./cmplx(xm**2-am**2,gamma*am)
8368 * HADRON CURRENT
8369  fro =0.266*amro**2
8370  elpha=- 0.1
8371  amrop = 1.7
8372  gamrop= 0.26
8373  amom =0.782
8374  gamom =0.0085
8375  aromeg= 1.0
8376  gcoup=12.924
8377  gcoup=gcoup*aromeg
8378  fqed =sqrt(4.0*3.1415926535/137.03604)
8379  formom=fqed*fro**2/sqrt(2.0)*gcoup**2*bwign(xmom,amom,gamom)
8380  $ *(bwign(xmaa,amro,gamro)+elpha*bwign(xmaa,amrop,gamrop))
8381  $ *(bwign( 0.0,amro,gamro)+elpha*bwign( 0.0,amrop,gamrop))
8382  END
8383 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
8384 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
8385 *-- AUTHOR :
8386  COMPLEX FUNCTION fpik(W)
8387 C **********************************************************
8388 C PION FORM FACTOR
8389 C **********************************************************
8390  COMPLEX bwig
8391  REAL rom,rog,rom1,rog1,beta1,pi,pim,s,w
8392  EXTERNAL bwig
8393  DATA init /0/
8394 C
8395 C ------------ PARAMETERS --------------------
8396  IF (init.EQ.0 ) THEN
8397  init=1
8398  pi=3.141592654
8399  pim=.140
8400  rom=0.773
8401  rog=0.145
8402  rom1=1.370
8403  rog1=0.510
8404  beta1=-0.145
8405  ENDIF
8406 C -----------------------------------------------
8407  s=w**2
8408  fpik= (bwig(s,rom,rog)+beta1*bwig(s,rom1,rog1))
8409  + /(1+beta1)
8410  RETURN
8411  END
8412 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
8413 *CMZ : 1.00/00 10/08/94 16.29.32 BY PIERO ZUCCHELLI
8414 *-- AUTHOR :
8415  COMPLEX FUNCTION fpikm(W,XM1,XM2)
8416 C **********************************************************
8417 C PION FORM FACTOR
8418 C **********************************************************
8419  COMPLEX bwigm
8420  REAL rom,rog,rom1,rog1,beta1,pi,pim,s,w
8421  EXTERNAL bwig
8422  DATA init /0/
8423 C
8424 C ------------ PARAMETERS --------------------
8425  IF (init.EQ.0 ) THEN
8426  init=1
8427  pi=3.141592654
8428  pim=.140
8429  rom=0.773
8430  rog=0.145
8431  rom1=1.370
8432  rog1=0.510
8433  beta1=-0.145
8434  ENDIF
8435 C -----------------------------------------------
8436  s=w**2
8437  fpikm=(bwigm(s,rom,rog,xm1,xm2)+beta1*bwigm(s,rom1,rog1,xm1,xm2))
8438  + /(1+beta1)
8439  RETURN
8440  END
8441 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
8442 *CMZ : 1.00/00 10/08/94 16.29.32 BY PIERO ZUCCHELLI
8443 *-- AUTHOR :
8444  COMPLEX FUNCTION fpikmd(W,XM1,XM2)
8445 C **********************************************************
8446 C PION FORM FACTOR
8447 C **********************************************************
8448  COMPLEX bwigm
8449  REAL rom,rog,rom1,rog1,pi,pim,s,w
8450  EXTERNAL bwig
8451  DATA init /0/
8452 C
8453 C ------------ PARAMETERS --------------------
8454  IF (init.EQ.0 ) THEN
8455  init=1
8456  pi=3.141592654
8457  pim=.140
8458  rom=0.773
8459  rog=0.145
8460  rom1=1.500
8461  rog1=0.220
8462  rom2=1.750
8463  rog2=0.120
8464  beta=6.5
8465  delta=-26.0
8466  ENDIF
8467 C -----------------------------------------------
8468  s=w**2
8469  fpikmd=(delta*bwigm(s,rom,rog,xm1,xm2)
8470  + +beta*bwigm(s,rom1,rog1,xm1,xm2)
8471  + + bwigm(s,rom2,rog2,xm1,xm2))
8472  + /(1+beta+delta)
8473  RETURN
8474  END
8475 *CMZ : 1.01/08 05/03/95 11.39.27 BY PIERO ZUCCHELLI
8476 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
8477 *-- AUTHOR :
8478  COMPLEX FUNCTION fpikmk(W,XM1,XM2)
8479 C **********************************************************
8480 C KAON FORM FACTOR
8481 C **********************************************************
8482  COMPLEX bwigm
8483  REAL rom,rog,rom1,rog1,beta1,pi,pim,s,w
8484  EXTERNAL bwig
8485  DATA init /0/
8486 C
8487 C ------------ PARAMETERS --------------------
8488  IF (init.EQ.0 ) THEN
8489  init=1
8490  pi=3.141592654
8491  pim=.140
8492  rom=0.773
8493  rog=0.145
8494  rom1=1.570
8495  rog1=0.510
8496 C BETA1=-0.111
8497  beta1=-0.221
8498  ENDIF
8499 C -----------------------------------------------
8500  s=w**2
8501  fpikmk=(bwigm(s,rom,rog,xm1,xm2)+beta1*bwigm(s,rom1,rog1,xm1,xm2))
8502  + /(1+beta1)
8503  RETURN
8504  END
8505 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
8506 *-- AUTHOR :
8507  FUNCTION fpirho(W)
8508 C **********************************************************
8509 C SQUARE OF PION FORM FACTOR
8510 C **********************************************************
8511  COMPLEX fpik
8512  fpirho=cabs(fpik(w))**2
8513  END
8514 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
8515 *-- AUTHOR :
8516  FUNCTION fpirk(W)
8517 C ----------------------------------------------------------
8518 C SQUARE OF PION FORM FACTOR
8519 C ----------------------------------------------------------
8520  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
8521  * ,ampiz,ampi,amro,gamro,ama1,gama1
8522  * ,amk,amkz,amkst,gamkst
8523 C
8524  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
8525  * ,ampiz,ampi,amro,gamro,ama1,gama1
8526  * ,amk,amkz,amkst,gamkst
8527 C COMPLEX FPIKMK
8528  COMPLEX fpikm
8529  fpirk=cabs(fpikm(w,amk,amkz))**2
8530 C FPIRK=CABS(FPIKMK(W,AMK,AMKZ))**2
8531  END
8532 *CMZ : 1.01/44 05/01/96 16.53.44 by Piero Zucchelli
8533 *CMZ : 1.01/40 09/11/95 14.58.06 by Piero Zucchelli
8534 *-- Author :
8535  SUBROUTINE fzclos
8536 *-----------------------------------------------------*
8537 * *
8538 * CLOSE FZ-FILE *
8539 * *
8540 *-----------------------------------------------------*
8541 *KEEP,zebra.
8542 
8543  parameter(nnq=1000000)
8544 *
8545  dimension lq(nnq),iq(nnq),q(nnq)
8546  equivalence(q(1),iq(1),lq(9),jstruc(8))
8547  COMMON /quest/iquest(100)
8548  COMMON /xqstor/ixevt,ifence(16),jgeev,jstruc(99),jrefer(100),
8549  +div12(nnq)
8550  COMMON /fzlun/lunfz
8551  common/mzioall/iogenf
8552 
8553 *KEND.
8554 *
8555  CALL fzendo(lunfz,'TX')
8556 *
8557  END
8558 *CMZ : 1.01/44 05/01/96 16.06.50 by Piero Zucchelli
8559 *CMZ : 1.01/40 10/11/95 19.03.13 by Piero Zucchelli
8560 *-- Author :
8561  SUBROUTINE fzini
8562 *-----------------------------------------------------*
8563 * *
8564 * INITIALIZE ZEBRA *
8565 * *
8566 *-----------------------------------------------------*
8567 *KEEP,zebra.
8568 
8569  parameter(nnq=1000000)
8570 *
8571  dimension lq(nnq),iq(nnq),q(nnq)
8572  equivalence(q(1),iq(1),lq(9),jstruc(8))
8573  COMMON /quest/iquest(100)
8574  COMMON /xqstor/ixevt,ifence(16),jgeev,jstruc(99),jrefer(100),
8575  +div12(nnq)
8576  COMMON /fzlun/lunfz
8577  common/mzioall/iogenf
8578 
8579 *KEEP,info.
8580  common/infonew/irdate,irtime
8581 *KEND.
8582 *
8583 *--- INITIALISATION OF ZEBRA
8584 *
8585  CALL datime(irdate,irtime)
8586 C CALL MZEBRA(-3)
8587  CALL mzebra( -1 )
8588 *
8589 *--- INITIALISATION OF DYNAMIC STORE
8590 *
8591  nlim=nnq/2
8592  ixstor=10
8593  CALL mzstor(ixstor,'/XQSTOR/','.',ifence,jgeev,jrefer(1),
8594  + div12(1),div12(nlim),div12(nnq))
8595 
8596  ndiv=nnq/10
8597  ndivm=ndiv*5
8598  CALL mzdiv(ixstor,ixevt,'EVT_DIV',ndiv,ndivm,'.')
8599  CALL dzveri('After init.',ixevt,'CLSU')
8600 
8601  CALL fzopn('jetta.rfz')
8602  CALL fzrun(lunfz,99999,0,0)
8603  END
8604 *CMZ : 1.01/45 08/01/96 11.11.53 by Piero Zucchelli
8605 *CMZ : 1.01/40 10/11/95 16.07.03 by Piero Zucchelli
8606 *-- Author :
8607  SUBROUTINE fzopn(CHNAME)
8608 *-----------------------------------------------------*
8609 * *
8610 * OPEN FZ-FILE WITH NAME CHNAME *
8611 * *
8612 *-----------------------------------------------------*
8613 *KEEP,zebra.
8614 
8615  parameter(nnq=1000000)
8616 *
8617  dimension lq(nnq),iq(nnq),q(nnq)
8618  equivalence(q(1),iq(1),lq(9),jstruc(8))
8619  COMMON /quest/iquest(100)
8620  COMMON /xqstor/ixevt,ifence(16),jgeev,jstruc(99),jrefer(100),
8621  +div12(nnq)
8622  COMMON /fzlun/lunfz
8623  common/mzioall/iogenf
8624 
8625 *KEND.
8626 *
8627  CHARACTER chname*(*)
8628  CHARACTER opt*4
8629  lunfz = 17
8630  opt = 'XLO'
8631  med = 0
8632 *
8633  IF (chname(1:3).EQ.'exa') THEN
8634  chname = '/dev/rmt0'
8635  opt = opt(1:3)//'T'
8636  med = 1
8637  ENDIF
8638 
8639  CALL cfopen(lunptr,med,8100,'w',0,chname,istat)
8640  IF (istat.NE.0) THEN
8641  WRITE(lpunit,10020) istat,lunfz
8642  stop
8643  ENDIF
8644  iquest(1) = lunptr
8645  CALL fzfile(lunfz,8100,opt)
8646  IF (iquest(1).NE.0) THEN
8647  WRITE (lpunit,10010) iquest(1),lunfz
8648  stop
8649  ENDIF
8650 10010 FORMAT (//' +++FILOPN - fatal error no. =',i5,' returned from',
8651  +' FZFILE, LUN = ',i5,' ++++++++')
8652 10020 FORMAT (//' +++FILOPN - fatal error no. =',i5,' returned from',
8653  +' CFOPEN, LUN = ',i5,' ++++++++')
8654  END
8655 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
8656 *CMZ : 1.00/00 04/07/94 15.02.28 BY PIERO ZUCCHELLI
8657 *-- AUTHOR :
8658 C#######################################################################
8659 C
8660 C ONE- AND TWO-DIMENSIONAL ADAPTIVE GAUSSIAN INTEGRATION ROUTINES.
8661 C
8662 C **********************************************************************
8663 
8664  SUBROUTINE gadap(A0,B0,F,EPS,SUM)
8665 C
8666 C PURPOSE - INTEGRATE A FUNCTION F(X)
8667 C METHOD - ADAPTIVE GAUSSIAN
8668 C USAGE - CALL GADAP(A0,B0,F,EPS,SUM)
8669 C PARAMETERS A0 - LOWER LIMIT (INPUT,REAL)
8670 C B0 - UPPER LIMIT (INPUT,REAL)
8671 C F - FUNCTION F(X) TO BE INTEGRATED. MUST BE
8672 C SUPPLIED BY THE USER. (INPUT,REAL FUNCTION)
8673 C EPS - DESIRED RELATIVE ACCURACY. IF SUM IS SMALL EPS
8674 C WILL BE ABSOLUTE ACCURACY INSTEAD. (INPUT,REAL)
8675 C SUM - CALCULATED VALUE FOR THE INTEGRAL (OUTPUT,REAL)
8676 C PRECISION - SINGLE
8677 C REQ'D PROG'S - F
8678 C AUTHOR - T. JOHANSSON, LUND UNIV. COMPUTER CENTER, 1973
8679 C REFERENCE(S) - THE AUSTRALIAN COMPUTER JOURNAL,3 P.126 AUG. -71
8680 C
8681  common/gadap1/ num,ifu
8682  EXTERNAL f
8683  dimension a(300),b(300),f1(300),f2(300),f3(300),s(300),n(300)
8684 10000 FORMAT(16h gadap:i too big)
8685  dsum(f1f,f2f,f3f,aa,bb)=5./18.*(bb-aa)*(f1f+1.6*f2f+f3f)
8686  IF(eps.LT.1.0e-8) eps=1.0e-8
8687  red=1.3
8688  l=1
8689  i=1
8690  sum=0.
8691  c=sqrt(15.)/5.
8692  a(1)=a0
8693  b(1)=b0
8694  f1(1)=f(0.5*(1+c)*a0+0.5*(1-c)*b0)
8695  f2(1)=f(0.5*(a0+b0))
8696  f3(1)=f(0.5*(1-c)*a0+0.5*(1+c)*b0)
8697  ifu=3
8698  s(1)= dsum(f1(1),f2(1),f3(1),a0,b0)
8699  10 CONTINUE
8700  l=l+1
8701  n(l)=3
8702  eps=eps*red
8703  a(i+1)=a(i)+c*(b(i)-a(i))
8704  b(i+1)=b(i)
8705  a(i+2)=a(i)+b(i)-a(i+1)
8706  b(i+2)=a(i+1)
8707  a(i+3)=a(i)
8708  b(i+3)=a(i+2)
8709  w1=a(i)+(b(i)-a(i))/5.
8710  u2=2.*w1-(a(i)+a(i+2))/2.
8711  f1(i+1)=f(a(i)+b(i)-w1)
8712  f2(i+1)=f3(i)
8713  f3(i+1)=f(b(i)-a(i+2)+w1)
8714  f1(i+2)=f(u2)
8715  f2(i+2)=f2(i)
8716  f3(i+2)=f(b(i+2)+a(i+2)-u2)
8717  f1(i+3)=f(a(i)+a(i+2)-w1)
8718  f2(i+3)=f1(i)
8719  f3(i+3)=f(w1)
8720  ifu=ifu+6
8721  IF(ifu.GT.5000) goto 40
8722  s(i+1)= dsum(f1(i+1),f2(i+1),f3(i+1),a(i+1),b(i+1))
8723  s(i+2)= dsum(f1(i+2),f2(i+2),f3(i+2),a(i+2),b(i+2))
8724  s(i+3)= dsum(f1(i+3),f2(i+3),f3(i+3),a(i+3),b(i+3))
8725  ss=s(i+1)+s(i+2)+s(i+3)
8726  i=i+3
8727  IF(i.GT.300)goto 30
8728  sold=s(i-3)
8729  IF(abs(sold-ss).GT.eps*(1.+abs(ss))/2.) goto 10
8730  sum=sum+ss
8731  i=i-4
8732  n(l)=0
8733  l=l-1
8734  20 CONTINUE
8735  IF(l.EQ.1) goto 40
8736  n(l)=n(l)-1
8737  eps=eps/red
8738  IF(n(l).NE.0) goto 10
8739  i=i-1
8740  l=l-1
8741  goto 20
8742  30 WRITE(6,10000)
8743  40 RETURN
8744  END
8745 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
8746 *CMZ : 1.00/00 04/07/94 15.02.28 BY PIERO ZUCCHELLI
8747 *-- AUTHOR :
8748 C **********************************************************************
8749 
8750  SUBROUTINE gadap2(A0,B0,FL,FU,F,EPS,SUM)
8751 C
8752 C PURPOSE - INTEGRATE A FUNCTION F(X,Y) OF TWO VARIABLES
8753 C METHOD - ADAPTIVE GAUSSIAN IN BOTH DIRECTIONS
8754 C USAGE - CALL GADAP2(A0,B0,FL,FU,F,EPS,SUM)
8755 C PARAMETERS A0 - LOWER X-LIMIT (INPUT,REAL)
8756 C B0 - UPPER X-LIMIT (INPUT,REAL)
8757 C FL - USER SUPPLIED FUNCTION FL(X) GIVING THE LOWER
8758 C Y-LIMIT FOR A GIVEN X-VALUE
8759 C (INPUT,REAL FUNCTION)
8760 C FU - USER SUPPLIED FUNCTION FU(X) GIVING THE UPPER
8761 C Y-LIMIT FOR A GIVEN X-VALUE
8762 C (INPUT,REAL FUNCTION)
8763 C F - USER SUPPLIED FUNCTION F(X,Y) TO BE INTEGRATED
8764 C (INPUT,REAL FUNCTION)
8765 C EPS - DESIRED ACCURACY (INPUT,REAL)
8766 C SUM - CALCULATED VALUE FOR THE INTEGRAL (OUTPUT,REAL)
8767 C PRECISION - SINGLE
8768 C REQ'D PROG'S - FL,FU,F,GADAPF
8769 C AUTHOR - THOMAS JOHANSSON, LDC,1973
8770 C
8771  common/gadap1/ num,ifu
8772  EXTERNAL f,fl,fu
8773  dimension a(300),b(300),f1(300),f2(300),f3(300),s(300),n(300)
8774 10000 FORMAT(16h gadap:i too big)
8775  dsum(f1f,f2f,f3f,aa,bb)=5./18.*(bb-aa)*(f1f+1.6*f2f+f3f)
8776  IF(eps.LT.1.0e-8) eps=1.0e-8
8777  red=1.4
8778  l=1
8779  i=1
8780  sum=0.
8781  c=sqrt(15.)/5.
8782  a(1)=a0
8783  b(1)=b0
8784  x=0.5*(1+c)*a0+0.5*(1-c)*b0
8785  ay=fl(x)
8786  by=fu(x)
8787  f1(1)=gadapf(x,ay,by,f,eps)
8788  x=0.5*(a0+b0)
8789  ay=fl(x)
8790  by=fu(x)
8791  f2(1)=gadapf(x,ay,by,f,eps)
8792  x=0.5*(1-c)*a0+0.5*(1+c)*b0
8793  ay=fl(x)
8794  by=fu(x)
8795  f3(1)=gadapf(x,ay,by,f,eps)
8796  ifu=3
8797  s(1)= dsum(f1(1),f2(1),f3(1),a0,b0)
8798  10 CONTINUE
8799  l=l+1
8800  n(l)=3
8801  eps=eps*red
8802  a(i+1)=a(i)+c*(b(i)-a(i))
8803  b(i+1)=b(i)
8804  a(i+2)=a(i)+b(i)-a(i+1)
8805  b(i+2)=a(i+1)
8806  a(i+3)=a(i)
8807  b(i+3)=a(i+2)
8808  w1=a(i)+(b(i)-a(i))/5.
8809  u2=2.*w1-(a(i)+a(i+2))/2.
8810  x=a(i)+b(i)-w1
8811  ay=fl(x)
8812  by=fu(x)
8813  f1(i+1)=gadapf(x,ay,by,f,eps)
8814  f2(i+1)=f3(i)
8815  x=b(i)-a(i+2)+w1
8816  ay=fl(x)
8817  by=fu(x)
8818  f3(i+1)=gadapf(x,ay,by,f,eps)
8819  x=u2
8820  ay=fl(x)
8821  by=fu(x)
8822  f1(i+2)=gadapf(x,ay,by,f,eps)
8823  f2(i+2)=f2(i)
8824  x=b(i+2)+a(i+2)-u2
8825  ay=fl(x)
8826  by=fu(x)
8827  f3(i+2)=gadapf(x,ay,by,f,eps)
8828  x=a(i)+a(i+2)-w1
8829  ay=fl(x)
8830  by=fu(x)
8831  f1(i+3)=gadapf(x,ay,by,f,eps)
8832  f2(i+3)=f1(i)
8833  x=w1
8834  ay=fl(x)
8835  by=fu(x)
8836  f3(i+3)=gadapf(x,ay,by,f,eps)
8837  ifu=ifu+6
8838  IF(ifu.GT.5000) goto 40
8839  s(i+1)= dsum(f1(i+1),f2(i+1),f3(i+1),a(i+1),b(i+1))
8840  s(i+2)= dsum(f1(i+2),f2(i+2),f3(i+2),a(i+2),b(i+2))
8841  s(i+3)= dsum(f1(i+3),f2(i+3),f3(i+3),a(i+3),b(i+3))
8842  ss=s(i+1)+s(i+2)+s(i+3)
8843  i=i+3
8844  IF(i.GT.300)goto 30
8845  sold=s(i-3)
8846  IF(abs(sold-ss).GT.eps*(1.+abs(ss))/2.) goto 10
8847  sum=sum+ss
8848  i=i-4
8849  n(l)=0
8850  l=l-1
8851  20 CONTINUE
8852  IF(l.EQ.1) goto 40
8853  n(l)=n(l)-1
8854  eps=eps/red
8855  IF(n(l).NE.0) goto 10
8856  i=i-1
8857  l=l-1
8858  goto 20
8859  30 WRITE(6,10000)
8860  40 RETURN
8861  END
8862 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
8863 *CMZ : 1.00/00 04/07/94 15.02.28 BY PIERO ZUCCHELLI
8864 *-- AUTHOR :
8865 C **********************************************************************
8866 
8867 
8868  FUNCTION gadapf(X,A0,B0,F,EPS)
8869  common/gadap1/ num,ifu
8870  EXTERNAL f
8871  dimension a(300),b(300),f1(300),f2(300),f3(300),s(300),n(300)
8872 10000 FORMAT(16h gadap:i too big)
8873  dsum(f1f,f2f,f3f,aa,bb)=5./18.*(bb-aa)*(f1f+1.6*f2f+f3f)
8874  IF(eps.LT.1.0e-8) eps=1.0e-8
8875  red=1.4
8876  l=1
8877  i=1
8878  sum=0.
8879  c=sqrt(15.)/5.
8880  a(1)=a0
8881  b(1)=b0
8882  f1(1)=f(x,0.5*(1+c)*a0+0.5*(1-c)*b0)
8883  f2(1)=f(x,0.5*(a0+b0))
8884  f3(1)=f(x,0.5*(1-c)*a0+0.5*(1+c)*b0)
8885  ifu=3
8886  s(1)= dsum(f1(1),f2(1),f3(1),a0,b0)
8887  10 CONTINUE
8888  l=l+1
8889  n(l)=3
8890  eps=eps*red
8891  a(i+1)=a(i)+c*(b(i)-a(i))
8892  b(i+1)=b(i)
8893  a(i+2)=a(i)+b(i)-a(i+1)
8894  b(i+2)=a(i+1)
8895  a(i+3)=a(i)
8896  b(i+3)=a(i+2)
8897  w1=a(i)+(b(i)-a(i))/5.
8898  u2=2.*w1-(a(i)+a(i+2))/2.
8899  f1(i+1)=f(x,a(i)+b(i)-w1)
8900  f2(i+1)=f3(i)
8901  f3(i+1)=f(x,b(i)-a(i+2)+w1)
8902  f1(i+2)=f(x,u2)
8903  f2(i+2)=f2(i)
8904  f3(i+2)=f(x,b(i+2)+a(i+2)-u2)
8905  f1(i+3)=f(x,a(i)+a(i+2)-w1)
8906  f2(i+3)=f1(i)
8907  f3(i+3)=f(x,w1)
8908  ifu=ifu+6
8909  IF(ifu.GT.5000) goto 40
8910  s(i+1)= dsum(f1(i+1),f2(i+1),f3(i+1),a(i+1),b(i+1))
8911  s(i+2)= dsum(f1(i+2),f2(i+2),f3(i+2),a(i+2),b(i+2))
8912  s(i+3)= dsum(f1(i+3),f2(i+3),f3(i+3),a(i+3),b(i+3))
8913  ss=s(i+1)+s(i+2)+s(i+3)
8914  i=i+3
8915  IF(i.GT.300)goto 30
8916  sold=s(i-3)
8917  IF(abs(sold-ss).GT.eps*(1.+abs(ss))/2.) goto 10
8918  sum=sum+ss
8919  i=i-4
8920  n(l)=0
8921  l=l-1
8922  20 CONTINUE
8923  IF(l.EQ.1) goto 40
8924  n(l)=n(l)-1
8925  eps=eps/red
8926  IF(n(l).NE.0) goto 10
8927  i=i-1
8928  l=l-1
8929  goto 20
8930  30 WRITE(6,10000)
8931  40 gadapf=sum
8932  eps=eps/red
8933  RETURN
8934  END
8935 *CMZ : 1.01/15 14/05/95 11.30.16 BY PIERO ZUCCHELLI
8936 *CMZ : 1.01/14 14/05/95 11.26.28 BY PIERO ZUCCHELLI
8937 *CMZ : 1.01/08 05/03/95 11.35.13 BY PIERO ZUCCHELLI
8938 *CMZ : 1.00/00 08/07/94 16.07.34 BY PIERO ZUCCHELLI
8939 *CMZ : 1.00/01 17/03/92 18.04.44 BY UNKNOWN
8940 *-- AUTHOR :
8941  SUBROUTINE gbinit
8942 *KEEP,CDEBEAM.
8943 C--
8944  COMMON /contro/ binit,lunb,npneut,npanti,cpnorm,xpsour,sigdiv
8945  COMMON /fluxes/ fluxd(80000),weight(8),specd(800),specn(800)
8946  COMMON /input/ iall(80000),ncount(8)
8947  LOGICAL binit
8948 
8949 
8950 C-
8951 *KEND.
8952  dimension ibuf(16)
8953  lunb = 10
8954  npneut = 800000
8955  npanti = 800000
8956  cpnorm = 1.e9
8957  xpsour = 67860.
8958  sigdiv = 0.0004
8959  binit = .false.
8960 C
8961 C- READ MONTE CARLO BEAM SPECTRA FROM FILE
8962 C
8963  DO i=1,5000
8964  READ(unit=lunb,fmt=101,end=10) (ibuf(j),j=1,16)
8965  DO j=1,16
8966  ii = (i-1)*16+j
8967  iall(ii) = ibuf(j)
8968  ENDDO
8969  ENDDO
8970  10 CONTINUE
8971 C
8972 C- INTEGRATE SPECTRA
8973 C
8974  DO i=1,8
8975  ncount(i) = 0
8976  DO j=1,10000
8977  ii = (i-1)*10000+j
8978  ncount(i) = ncount(i)+iall(ii)
8979  ENDDO
8980  ENDDO
8981 C
8982 C- NORMALISE SPECTRA
8983 C
8984  cneut = cpnorm/1.e3/float(npneut)
8985  canti = cpnorm/1.e3/float(npanti)
8986  DO i=1,40000
8987  fluxd(i) = cneut*float(iall(i))
8988  fluxd(40000+i) = canti*float(iall(40000+i))
8989  ENDDO
8990 C
8991 C- NORMALISE INTEGRALS, PREPARE CUMULATIVE DISTRIBUTION
8992 C
8993  DO i=1,4
8994  weight(i) = cneut*ncount(i)
8995  weight(4+i) = canti*ncount(4+i)
8996  ENDDO
8997  DO i=2,4
8998  weight(i) = weight(i)+weight(i-1)
8999  weight(4+i) = weight(4+i)+weight(3+i)
9000  ENDDO
9001 C
9002 C- INTEGRATE OVER RADIUS, PREPARE CUMULATIVE SPECTRA
9003 C
9004  CALL vzero(specd,800)
9005  CALL vzero(specn,800)
9006  DO i=1,8
9007  DO j=1,100
9008  ii = (i-1)*100+j
9009  DO k=1,100
9010  jj = (i-1)*10000+j+(k-1)*100
9011  specd(ii) = specd(ii)+fluxd(jj)
9012  specn(ii) = specd(ii)
9013  ENDDO
9014  ENDDO
9015  ENDDO
9016  DO i=1,8
9017  DO j=2,100
9018  ii = (i-1)*100+j
9019  specn(ii) = specn(ii)+specn(ii-1)
9020  ENDDO
9021  ENDDO
9022 C
9023  binit = .true.
9024  RETURN
9025 101 FORMAT(16i5)
9026  END
9027 *CMZ : 1.01/14 14/05/95 11.26.28 BY PIERO ZUCCHELLI
9028 *CMZ : 1.01/08 05/03/95 11.35.13 BY PIERO ZUCCHELLI
9029 *CMZ : 1.00/00 10/07/94 14.12.00 BY PIERO ZUCCHELLI
9030 *CMZ : 1.00/01 17/03/92 18.04.44 BY UNKNOWN
9031 *-- AUTHOR :
9032  SUBROUTINE gbspec(BEAM,IFLAV,RADIUS,SPEC)
9033 *KEEP,CDEBEAM.
9034 C--
9035  COMMON /contro/ binit,lunb,npneut,npanti,cpnorm,xpsour,sigdiv
9036  COMMON /fluxes/ fluxd(80000),weight(8),specd(800),specn(800)
9037  COMMON /input/ iall(80000),ncount(8)
9038  LOGICAL binit
9039 
9040 
9041 C-
9042 *KEND.
9043  CHARACTER*4 beam
9044  dimension spec(100)
9045  common/maxspec/rmaxspec,rintspec
9046 C
9047  IF(.NOT.binit) CALL gbinit
9048 C
9049  IF(beam.EQ.'NEUT') THEN
9050  ibeam=0
9051  ELSEIF(beam.EQ.'ANTI') THEN
9052  ibeam=4
9053  ELSE
9054  goto 10
9055  ENDIF
9056 C
9057  IF(iflav.LT.1.OR.iflav.GT.4) goto 10
9058  IF(radius.LE.0.0.OR.radius.GE.300.0) goto 10
9059  iflav = iflav+ibeam
9060 C
9061  CALL vzero(spec,100)
9062  rad2 = radius**2/900.+1.
9063  iradiu = rad2
9064  frac = rad2-float(iradiu)*900.
9065  DO i=1,100
9066  DO j=1,iradiu-1
9067  ip = (iflav-1)*10000+i+(j-1)*100
9068  spec(i) = spec(i)+fluxd(ip)
9069  ENDDO
9070  ii = (iflav-1)*10000+i+(iradiu-1)*100
9071  IF(frac.GT.0.0) spec(i) = spec(i)+frac*fluxd(ii)
9072  ENDDO
9073 C
9074  rintspec=0
9075  DO i=1,100
9076  rmaxspec=max(rmaxspec,spec(i))
9077  rintspec=rintspec+spec(i)
9078  END DO
9079 * WRITE(*,*)'RMAXSPEC=',RMAXSPEC
9080  iflav = iflav-ibeam
9081  RETURN
9082 C
9083  10 WRITE(6,10000)
9084 10000 FORMAT(1x,' GBSPEC: ERROR IN INPUT VARIABLES!')
9085  RETURN
9086  END
9087 *CMZ : 1.02/05 13/01/97 15.02.17 by P. Zucchelli
9088 *CMZ : 1.02/04 13/01/97 14.41.19 by P. Zucchelli
9089 *CMZ : 1.02/00 12/01/97 16.15.37 by J. Brunner
9090 *CMZ : 1.01/50 17/04/96 21.39.11 by Piero Zucchelli
9091 *CMZ : 1.01/41 12/12/95 17.03.06 by Piero Zucchelli
9092 *CMZ : 1.01/39 20/10/95 14.40.20 by Piero Zucchelli
9093 *CMZ : 1.01/38 18/10/95 18.27.55 by Piero Zucchelli
9094 *CMZ : 1.01/37 18/10/95 18.21.26 BY PIERO ZUCCHELLI
9095 *CMZ : 1.01/34 25/07/95 12.04.18 BY PIERO ZUCCHELLI
9096 *CMZ : 1.01/31 02/06/95 20.18.22 BY PIERO ZUCCHELLI
9097 *CMZ : 1.01/30 02/06/95 20.08.19 BY PIERO ZUCCHELLI
9098 *CMZ : 1.01/14 14/05/95 11.26.28 BY PIERO ZUCCHELLI
9099 *CMZ : 1.01/08 05/03/95 11.35.13 BY PIERO ZUCCHELLI
9100 *CMZ : 1.01/01 23/09/94 12.01.45 BY PIERO ZUCCHELLI
9101 *-- AUTHOR : PIERO ZUCCHELLI 11/09/94
9102  SUBROUTINE gentable(LFILE,LEPIN,ENERGY_FIX,PPZ,INTERACTION)
9103 *KEEP,JETTA.
9104 C--
9105  parameter(icento=100)
9106  parameter(isiz=93)
9107  parameter(iof1=32)
9108  parameter(iof2=83)
9109  parameter(lux_level=4)
9110  INTEGER*4 jtau(100),jpri(100),jstro(100)
9111  REAL*4 ftuple(isiz)
9112  common/jettagl/jtau,jpri,jstro
9113  common/ntupla/ftuple,isfirst
9114  common/beam/spec(icento)
9115  COMMON /maxspec/rmaxspec,rintspec
9116  common/sav/xminsav(icento),xmaxsav(icento),yminsav(icento),
9117  & ymaxsav(icento),q2minsav(icento),q2maxsav(icento),
9118  & w2minsav(icento),w2maxsav(icento),parimax(icento),
9119  & ppsave(icento,3,4,5),paricor(icento),index,sigmasav(icento),
9120  & xmsigma,xsect
9121 
9122 *KEEP,KEYS.
9123  common/cfread/space(5000)
9124  common/mykeys/ievar,if5cc,ineut,iinte,iferm,iflat,icoun,
9125  & refix,imudo,ikat1,ikat2,ikat3,ikat4,ikat5,ikat6,
9126  & inevt,ijak1,ijak2,iitdk,rptau,rxk0d,ntgr,idimuon,iglu,
9127  & iqden,lome(2),ifiles,iccha,iseed,idsubs,ionem,ehac,ipsel,
9128  & ihist
9129 
9130 
9131 *KEND.
9132  REAL vect(3),gkin(3),g4mes(4)
9133  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
9134  COMMON /lintrl/ psave(3,4,5),ksave(4),xmin,xmax,ymin,ymax,
9135  +q2min,q2max,w2min,w2max,ilep,inu,ig,iz
9136  COMMON /linter/ pari(40),ewqc(2,2,8),qc(8),zl(2,4),zq(2,8),pq(17)
9137  common/runcom/imode
9138 
9139  imode=0
9140  CALL getneu(ipnum,neutype,vect,gkin,
9141  + mestype,g4mes,neuforce,imode)
9142  IF (lst(17).EQ.0) THEN
9143  CALL linit(lfile,lepin,energy_fix,ppz,interaction)
9144  WRITE(55,*)energy_fix,parl(23),xmin,xmax,ymin,ymax,q2min,q2max,1.
9145  CLOSE(55)
9146  ELSE
9147 * 5 PERCENT ON DSIGMA/DE LOOKS REASONABLE
9148 * PARL(15)=0.05
9149  rmaxspec=0.
9150  DO ii=1,100
9151  i=ii
9152  ene=(i-1)*3. + 1.5
9153 
9154  CALL cats
9155 
9156  CALL linit(lfile,lepin,ene,ppz,interaction)
9157 
9158  paricor(i)=pari(32)
9159  parimax(i)=pari(lst(23))*1.5
9160  xminsav(i)=xmin
9161  xmaxsav(i)=xmax
9162  yminsav(i)=ymin
9163  ymaxsav(i)=ymax
9164  q2minsav(i)=q2min
9165  q2maxsav(i)=q2max
9166  w2minsav(i)=w2min
9167  w2maxsav(i)=w2max
9168  sigmasav(i)=parl(23)
9169  xmsigma=max(parl(23),xmsigma)
9170  DO 10 ia=1,2
9171  DO 10 ja=1,5
9172  10 ppsave(i,3,ia,ja)=psave(3,ia,ja)
9173 
9174  IF (lst(37).EQ.0) rmaxspec=max(rmaxspec,spec(i))
9175  WRITE(*,*)'X-SECTION AT',ene,' GEV=',parl(23),
9176  + 'PB BEAM WEIGHTED:',spec(i)
9177  WRITE(55,*)ene,parl(23),xmin,xmax,ymin,
9178  + ymax,q2min,q2max,spec(i),pari(lst(23))
9179  END DO
9180  CLOSE(55)
9181  CALL linit(lfile,lepin,100.,ppz,interaction)
9182  ENDIF
9183  RETURN
9184  END
9185 *CMZ : 1.02/09 14/01/97 15.14.45 by P. Zucchelli
9186 *CMZ : 1.02/08 14/01/97 11.55.37 by P. Zucchelli
9187 *CMZ : 1.02/07 14/01/97 11.11.46 by P. Zucchelli
9188 *CMZ : 1.02/06 13/01/97 18.51.57 by P. Zucchelli
9189 *CMZ : 1.02/04 13/01/97 14.54.54 by P. Zucchelli
9190 *CMZ : 1.02/00 12/01/97 16.23.16 by J. Brunner
9191 *CMZ : 1.01/51 04/07/96 10.20.58 by Piero Zucchelli
9192 *CMZ : 1.01/50 23/05/96 12.34.50 by Piero Zucchelli
9193 *-- Author :
9194 C======================================================================
9195 C======================================================================
9196 C
9197  SUBROUTINE gethneu(IPNUM,NEUTYPE,VECT,GKIN,
9198  + mestype,g4mes,neuforce,imode)
9199 
9200 C IPNUM=protons number (back)
9201 C NEUTYPE=neutrino type (back)
9202 C VECT=position of creation of neutrino (back)
9203 C GKIN=neutrino 3-momentum
9204 C MESTYPE=parent meson type (back)
9205 C G4MES=meson 4 momentum
9206 C NEUFORCE=to force particular decays (to be implemented)
9207 C IMODE=0 to start (input), 2 to get neutrinos (input),
9208 C it is set to 4 by the routine when the input files are completed;
9209 C to continue, set it to 2 again.
9210 C
9211 C
9212  parameter(nbin=100)
9213  CHARACTER*80 filname
9214  CHARACTER chvar(16)*8
9215 C
9216  dimension vect(3),gkin(3),yarr(100)
9217  dimension g4mes(4),ihis(4)
9218 C
9219  common/ntupl10/ nutype,iparent,eparent,xdecay,ydecay,zdecay,
9220  + pxpar,pypar,pzpar,xdet,ydet,xl,pxnu,pynu,pznu,
9221  + nprot
9222  common/runcom/imodeold,ifiles,irun
9223 C
9224  DATA ihis/3001,4001,1001,2001/
9225  DATA chvar/'NUTYPE', 'IPARENT', 'EPARENT', 'XDECAY ',
9226  + 'YDECAY', 'ZDECAY', 'PXPAR', 'PYPAR',
9227  + 'PZPAR', 'XDET', 'YDET', 'XL',
9228  + 'PXNU', 'PYNU', 'PZNU', 'NPROT'/
9229 C
9230 C -----------------------------------------------------------------
9231  IF (imode.EQ.0) THEN
9232 C
9233 C Global initialization (IMODE=0)
9234 C Start with Neutrino Run Number 1
9235 C
9236  irun =1
9237  icount =0
9238  number =0
9239  idiff =0
9240  ifiles =0
9241  nbase=0
9242 C
9243 C Zero Neutrino Counter and Return
9244 C
9245  RETURN
9246  ENDIF
9247 C -----------------------------------------------------------------
9248 C -----------------------------------------------------------------
9249  IF (imode.EQ.2) THEN
9250 C
9251 C Event Processing (IMODE=2)
9252 C ---------------------------------------------------------------
9253 C
9254  IF(icount.EQ.0)THEN
9255  WRITE(filname,1)'../beam/histos.rz'
9256  1 FORMAT(a)
9257 C
9258 C
9259 
9260  lrec = 0
9261  CALL hropen(2,'BDIR',filname,' ',lrec,istat)
9262 * PZ LOOP
9263  index=neuforce-48
9264  ihi=ihis(index)
9265 *e mo`?
9266 * something like:
9267 
9268  CALL hcdir('//BDIR',' ')
9269  CALL hrin(ihi,9999,0)
9270  CALL hunpak(ihi,yarr,' ',0)
9271 
9272 * put IHI histogram into YARR
9273  CALL hispre(yarr,nbin)
9274  IF (istat.NE.0) THEN
9275  stop 'HROPEN ERROR'
9276  ENDIF
9277 
9278 
9279 *up to here
9280  IF (imode.NE.4) THEN
9281  WRITE(6,55) filname
9282  ENDIF
9283  55 FORMAT(1x,'OPENING HISTOS FILE ',a)
9284 C
9285  ENDIF
9286 C
9287 * here play with dices...
9288 
9289  nutype=neuforce
9290 * here extract gkin(3) according to the histogram distribution....
9291 
9292  CALL hisran(yarr,nbin,0.,3.,xran)
9293  gkin(3)=xran
9294  IF (nutype.EQ.53) nutype=49
9295  IF (nutype.EQ.54) nutype=50
9296 c
9297  IF(ierr.NE.0)THEN
9298  print *, 'ERROR', icount
9299  ELSE
9300  icount=icount+1
9301  ENDIF
9302 
9303  IF (neuforce.NE.0) THEN
9304 * CALL FORCED_DECAY(NEUFORCE,ISTATUS)
9305  ENDIF
9306 
9307 
9308 C
9309  g4mes(1)=0.
9310  g4mes(2)=0.
9311  g4mes(3)=0.
9312  g4mes(4)=0.
9313  mestype=0.
9314  vect(1) =0.
9315  vect(2) =0.
9316  vect(3) =0.
9317  gkin(1) =0.
9318  gkin(2) =0.
9319  gkin(3) =xran
9320  ipnum = nbase+1
9321  neutype = nutype
9322 
9323 
9324 C
9325 C
9326 C
9327 C IF(ICOUNT.LE.1.AND.IMODE.EQ.2)THEN
9328 C WRITE(6,500)NPROT,NUTYPE, VECT(1),VECT(2),VECT(3), GKIN(1),
9329 C + GKIN(2),GKIN(3)
9330 C END IF
9331 C
9332  500 FORMAT(1x,'POT=',i10,1x,
9333  + 'NEUT=',i3 ,1x,' x =',e15.9
9334  + ,1x,' y =',e15.9
9335  + ,1x,' z =',e15.9
9336  + ,1x,' px=',e15.9
9337  + ,1x,' py=',e15.9
9338  + ,1x,' pz=',e15.9)
9339 C
9340  ENDIF
9341  IF (imode.EQ.4) THEN
9342  WRITE(*,*)' END OF NEUTRINO STATISTICS ...REWINDING...'
9343  WRITE(*,*)' TO CONTINUE, you have to SET IMODE=2'
9344  ENDIF
9345 C
9346  RETURN
9347  END
9348 *CMZ : 1.02/09 14/01/97 15.14.45 by P. Zucchelli
9349 *CMZ : 1.02/06 13/01/97 17.18.47 by P. Zucchelli
9350 *CMZ : 1.02/00 12/01/97 16.23.16 by J. Brunner
9351 *CMZ : 1.01/51 04/07/96 10.20.58 by Piero Zucchelli
9352 *CMZ : 1.01/50 23/05/96 12.34.50 by Piero Zucchelli
9353 *-- Author :
9354 C======================================================================
9355 C======================================================================
9356 C
9357  SUBROUTINE getneu(IPNUM,NEUTYPE,VECT,GKIN,
9358  + mestype,g4mes,neuforce,imode)
9359 
9360 C IPNUM=protons number (back)
9361 C NEUTYPE=neutrino type (back)
9362 C VECT=position of creation of neutrino (back)
9363 C GKIN=neutrino 3-momentum
9364 C MESTYPE=parent meson type (back)
9365 C G4MES=meson 4 momentum
9366 C NEUFORCE=to force particular decays (to be implemented)
9367 C IMODE=0 to start (input), 2 to get neutrinos (input),
9368 C it is set to 4 by the routine when the input files are completed;
9369 C to continue, set it to 2 again.
9370 C
9371 C
9372  CHARACTER*80 filname
9373  CHARACTER chvar(16)*8
9374 C
9375  dimension vect(3),gkin(3)
9376  dimension g4mes(4)
9377 C
9378  common/ntupl10/ nutype,iparent,eparent,xdecay,ydecay,zdecay,
9379  + pxpar,pypar,pzpar,xdet,ydet,xl,pxnu,pynu,pznu,
9380  + nprot
9381  common/runcom/imodeold,ifiles,irun
9382 C
9383  DATA chvar/'NUTYPE', 'IPARENT', 'EPARENT', 'XDECAY ',
9384  + 'YDECAY', 'ZDECAY', 'PXPAR', 'PYPAR',
9385  + 'PZPAR', 'XDET', 'YDET', 'XL',
9386  + 'PXNU', 'PYNU', 'PZNU', 'NPROT'/
9387 C
9388 C -----------------------------------------------------------------
9389  IF (imode.EQ.0) THEN
9390 C
9391 C Global initialization (IMODE=0)
9392 C Start with Neutrino Run Number 1
9393 C
9394  irun =1
9395  icount =0
9396  number =0
9397  idiff =0
9398  ifiles =0
9399  nbase=0
9400 C
9401 C Zero Neutrino Counter and Return
9402 C
9403  RETURN
9404  ENDIF
9405 C -----------------------------------------------------------------
9406 C -----------------------------------------------------------------
9407  IF (imode.EQ.2) THEN
9408 C
9409 C Event Processing (IMODE=2)
9410 C ---------------------------------------------------------------
9411 C
9412  IF(icount.EQ.0)THEN
9413 C
9414 C if end-of file
9415 C
9416 C OPEN next RZ file of neutrino
9417 C
9418  IF(irun.LT.10)THEN
9419  WRITE(filname,1)irun
9420  1 FORMAT('../beam/neutrino',i1,'.rz')
9421  ELSE IF (irun.LT.100)THEN
9422  WRITE(filname,2)irun
9423  2 FORMAT('../beam/neutrino',i2,'.rz')
9424  ELSE IF (irun.LT.1000)THEN
9425  WRITE(filname,3)irun
9426  3 FORMAT('../beam/neutrino',i3,'.rz')
9427  END IF
9428 C
9429 C
9430  lrec = 0
9431  CALL hropen(2,'BDIR',filname,'X',lrec,istat)
9432 * PZ LOOP
9433  IF (istat .NE. 0) THEN
9434  imode=4
9435  irun=1
9436  WRITE(filname,1)irun
9437  lrec = 0
9438  CALL hropen(2,'BDIR',filname,'X',lrec,istat)
9439  IF (istat.NE.0) THEN
9440  stop 'HROPEN ERROR'
9441  ENDIF
9442  ENDIF
9443 
9444 
9445  CALL hrin(0, 999, 0)
9446  CALL hnoent(1,imax)
9447  IF (imode.NE.4) THEN
9448  WRITE(6,55) imax,filname
9449  ENDIF
9450  55 FORMAT(1x,'OPENING ',i8,' EVENTS FROM FILE ',a)
9451 C
9452 C ---------------------------------------------------------------
9453 C COMMON/NTUPL10/ NUTYPE,IPARENT,EPARENT,XDECAY,YDECAY,ZDECAY,
9454 C + PXPAR,PYPAR,PZPAR,XDET,YDET,XL,PXNU,PYNU,PZNU,
9455 C + NPROT
9456  CALL hbname(1,' ',0,'$CLEAR')
9457  CALL hbname(1, 'XNUMU', nutype,'$SET:NUTYPE')
9458  CALL hbname(1, 'XNUMU', iparent,'$SET:IPARENT')
9459  CALL hbname(1, 'XNUMU', eparent,'$SET:EPARENT')
9460  CALL hbname(1, 'XNUMU', xdecay,'$SET:XDECAY')
9461  CALL hbname(1, 'XNUMU', ydecay,'$SET:YDECAY')
9462  CALL hbname(1, 'XNUMU', zdecay,'$SET:ZDECAY')
9463  CALL hbname(1, 'XNUMU', pxpar,'$SET:PXPAR')
9464  CALL hbname(1, 'XNUMU', pypar,'$SET:PYPAR')
9465  CALL hbname(1, 'XNUMU', pzpar,'$SET:PZPAR')
9466  CALL hbname(1, 'XNUMU', xdet, '$SET:XDET')
9467  CALL hbname(1, 'XNUMU', ydet, '$SET:YDET')
9468  CALL hbname(1, 'XNUMU', xl, '$SET:XL')
9469  CALL hbname(1, 'XNUMU', pxnu, '$SET:PXNU')
9470  CALL hbname(1, 'XNUMU', pynu, '$SET:PYNU')
9471  CALL hbname(1, 'XNUMU', pznu, '$SET:PZNU')
9472  CALL hbname(1, 'XNUMU', nprot, '$SET:NPROT')
9473  ENDIF
9474 C
9475 C READ next neutrinos parameters
9476 C
9477 
9478 C
9479  CALL hgntv(1, chvar, 16, icount+1, ierr)
9480 * gbeam patch!!!
9481  IF (nutype.EQ.53) nutype=49
9482  IF (nutype.EQ.54) nutype=50
9483 c
9484  IF(ierr.NE.0)THEN
9485  print *, 'ERROR', icount
9486  ELSE
9487  icount=icount+1
9488  ENDIF
9489 
9490  IF (neuforce.NE.0) THEN
9491 * CALL FORCED_DECAY(NEUFORCE,ISTATUS)
9492  ENDIF
9493 
9494 
9495 C
9496  g4mes(1)=pxpar
9497  g4mes(2)=pypar
9498  g4mes(3)=pzpar
9499  g4mes(4)=epar
9500  mestype=iparent
9501  vect(1) =xdecay
9502  vect(2) =ydecay
9503  vect(3) =zdecay
9504  gkin(1) = pxnu
9505  gkin(2) = pynu
9506  gkin(3) = pznu
9507  ipnum = nbase+nprot
9508  neutype = nutype
9509 
9510 
9511 C
9512 C
9513 C
9514 C IF(ICOUNT.LE.1.AND.IMODE.EQ.2)THEN
9515 C WRITE(6,500)NPROT,NUTYPE, VECT(1),VECT(2),VECT(3), GKIN(1),
9516 C + GKIN(2),GKIN(3)
9517 C END IF
9518 C
9519  500 FORMAT(1x,'POT=',i10,1x,
9520  + 'NEUT=',i3 ,1x,' x =',e15.9
9521  + ,1x,' y =',e15.9
9522  + ,1x,' z =',e15.9
9523  + ,1x,' px=',e15.9
9524  + ,1x,' py=',e15.9
9525  + ,1x,' pz=',e15.9)
9526 C
9527 C
9528 
9529  IF(icount.EQ.imax)THEN
9530  icount=0
9531  nbase=nbase+nprot
9532  irun=irun+1
9533  CALL hrend('BDIR')
9534  WRITE(6,56)filname
9535  56 FORMAT(1x,'CLOSING FILE',1x,a)
9536 C
9537  ENDIF
9538 C
9539  ENDIF
9540  IF (imode.EQ.4) THEN
9541  WRITE(*,*)' END OF NEUTRINO STATISTICS ...REWINDING...'
9542  WRITE(*,*)' TO CONTINUE, you have to SET IMODE=2'
9543  ENDIF
9544 C
9545  RETURN
9546  END
9547 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
9548 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
9549 *-- AUTHOR :
9550  FUNCTION gfun(QKWA)
9551 C ****************************************************************
9552 C G-FUNCTION USED TO INRODUCE ENERGY DEPENDENCE IN A1 WIDTH
9553 C ****************************************************************
9554  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
9555  + ,ampiz,ampi,amro,gamro,ama1,gama1
9556  + ,amk,amkz,amkst,gamkst
9557 C
9558  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
9559  + ,ampiz,ampi,amro,gamro,ama1,gama1
9560  + ,amk,amkz,amkst,gamkst
9561 C
9562  IF (qkwa.LT.(amro+ampi)**2) THEN
9563  gfun=4.1*(qkwa-9*ampiz**2)**3 *(1.-3.3*(qkwa-9*ampiz**2)+5.8*
9564  + (qkwa-9*ampiz**2)**2)
9565  ELSE
9566  gfun=qkwa*(1.623+10.38/qkwa-9.32/qkwa**2+0.65/qkwa**3)
9567  ENDIF
9568  END
9569 *CMZ : 1.01/17 14/05/95 11.47.38 BY PIERO ZUCCHELLI
9570 *CMZ : 1.00/00 14/08/94 03.47.49 BY PIERO ZUCCHELLI
9571 *-- AUTHOR :
9572  SUBROUTINE inimas
9573 C ----------------------------------------------------------------------
9574 C INITIALISATION OF MASSES
9575 C
9576 C CALLED BY : KORALZ
9577 C ----------------------------------------------------------------------
9578  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
9579  * ,ampiz,ampi,amro,gamro,ama1,gama1
9580  * ,amk,amkz,amkst,gamkst
9581 C
9582  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
9583  * ,ampiz,ampi,amro,gamro,ama1,gama1
9584  * ,amk,amkz,amkst,gamkst
9585 C
9586 C IN-COMING / OUT-GOING FERMION MASSES
9587  amtau = 1.7771
9588 C AMNUTA = 0.010
9589  amnuta = 0.0
9590  amel = 0.0005111
9591  amnue = 0.0
9592  ammu = 0.105659
9593  amnumu = 0.0
9594 C
9595 C MASSES USED IN TAU DECAYS
9596  ampiz = 0.134964
9597  ampi = 0.139568
9598  amro = 0.773
9599  gamro = 0.145
9600 CC GAMRO = 0.666
9601  ama1 = 1.251
9602  gama1 = 0.599
9603  amk = 0.493667
9604  amkz = 0.49772
9605  amkst = 0.8921
9606  gamkst = 0.0513
9607 C
9608  RETURN
9609  END
9610 *CMZ : 1.00/00 09/08/94 17.43.59 BY PIERO ZUCCHELLI
9611 *-- AUTHOR :
9612  SUBROUTINE iniphy(XK00)
9613 C ----------------------------------------------------------------------
9614 C INITIALISATION OF PARAMETERS
9615 C USED IN QED AND/OR GSW ROUTINES
9616 C ----------------------------------------------------------------------
9617  COMMON / qedprm /alfinv,alfpi,xk0
9618  REAL*8 alfinv,alfpi,xk0
9619  REAL*8 pi8,xk00
9620 C
9621  pi8 = 4.d0*datan(1.d0)
9622  alfinv = 137.03604d0
9623  alfpi = 1d0/(alfinv*pi8)
9624  xk0=xk00
9625  END
9626 *CMZ : 1.01/50 22/05/96 18.06.09 by Piero Zucchelli
9627 *CMZ : 1.01/26 29/05/95 19.08.20 BY PIERO ZUCCHELLI
9628 *CMZ : 1.01/25 29/05/95 16.05.52 BY PIERO ZUCCHELLI
9629 *CMZ : 1.01/14 14/05/95 11.26.28 BY PIERO ZUCCHELLI
9630 *CMZ : 1.01/11 13/05/95 19.10.40 BY PIERO ZUCCHELLI
9631 *CMZ : 1.01/08 05/03/95 11.39.27 BY PIERO ZUCCHELLI
9632 *CMZ : 1.00/00 09/08/94 17.43.59 BY PIERO ZUCCHELLI
9633 *-- AUTHOR :
9634  SUBROUTINE initdk
9635 C ----------------------------------------------------------------------
9636 C INITIALISATION OF TAU DECAY PARAMETERS AND ROUTINES
9637 C
9638 C CALLED BY : KORALZ
9639 C ----------------------------------------------------------------------
9640  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
9641  REAL*4 gfermi,gv,ga,ccabib,scabib,gamel
9642  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
9643  + ,ampiz,ampi,amro,gamro,ama1,gama1
9644  + ,amk,amkz,amkst,gamkst
9645 C
9646  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
9647  + ,ampiz,ampi,amro,gamro,ama1,gama1
9648  + ,amk,amkz,amkst,gamkst
9649  COMMON / taubra / gamprt(30),jlist(30),nchan
9650  COMMON / taukle / bra1,brk0,brk0b,brks
9651  REAL*4 bra1,brk0,brk0b,brks
9652  parameter(nmode=15,nm1=0,nm2=1,nm3=8,nm4=2,nm5=1,nm6=3)
9653  COMMON / mdecomp /idffin(9,nmode),mulpik(nmode)
9654  + ,names
9655  CHARACTER names(nmode)*31
9656  REAL*4 pi
9657 C
9658 C LIST OF BRANCHING RATIOS
9659 CAM NORMALISED TO E NU NUTAU CHANNEL
9660 CAM ENU MUNU PINU RHONU A1NU KNU K*NU PI'
9661 CAM DATA JLIST / 1, 2, 3, 4, 5, 6, 7,
9662 CAM DATA GAMPRT /1.000,0.9730,0.6054,1.2432,0.8432,0.0432,O.O811,0.616
9663 CAM
9664 CAM MULTIPION DECAYS
9665 C
9666 C CONVENTIONS OF PARTICLES NAMES
9667 C K-,P-,K+, K0,P-,KB, K-,P0,K0
9668 C 3, 1,-3 , 4, 1,-4 , 3, 2, 4 ,
9669 C P0,P0,K-, K-,P-,P+, P-,KB,P0
9670 C 2, 2, 3 , 3, 1,-1 , 1,-4, 2 ,
9671 C ET,P-,P0 P-,P0,GM
9672 C 9, 1, 2 , 1, 2, 8
9673 C
9674  dimension nopik(6,nmode),npik(nmode)
9675 CAM OUTGOING MULTIPLICITY AND FLAVORS OF MULTI-PION /MULTI-K MODES
9676  DATA npik / 4, 4,
9677  + 5, 5,
9678  + 6, 6,
9679  + 3, 3,
9680  + 3, 3,
9681  + 3, 3,
9682  + 3, 3,
9683  + 2 /
9684  DATA nopik / -1,-1, 1, 2, 0, 0, 2, 2, 2,-1, 0, 0,
9685  + -1,-1, 1, 2, 2, 0, -1,-1,-1, 1, 1, 0,
9686  + -1,-1,-1, 1, 1, 2, -1,-1, 1, 2, 2, 2,
9687  + -3,-1, 3, 0, 0, 0, -4,-1, 4, 0, 0, 0,
9688  + -3, 2,-4, 0, 0, 0, 2, 2,-3, 0, 0, 0,
9689  + -3,-1, 1, 0, 0, 0, -1, 4, 2, 0, 0, 0,
9690  + 9,-1, 2, 0, 0, 0, -1, 2, 8, 0, 0, 0,
9691  + -3, 4, 0, 0, 0, 0 /
9692 C LIST OF BRANCHING RATIOS
9693  nchan = nmode + 7
9694  DO 10 i = 1,30
9695  IF (i.LE.nchan) THEN
9696  jlist(i) = i
9697  IF(i.EQ. 1) gamprt(i) = 1.00000
9698  IF(i.EQ. 2) gamprt(i) = 0.97980
9699  IF(i.EQ. 3) gamprt(i) = 0.64960
9700 * EX 1.3405,
9701  IF(i.EQ. 4) gamprt(i) = 1.3405
9702  IF(i.EQ. 5) gamprt(i) = 1.2
9703  IF(i.EQ. 6) gamprt(i) = 0.0397
9704  IF(i.EQ. 7) gamprt(i) = 0.0696
9705 * CHANGED FOR INCREASING 3 PROG DECAYS
9706  IF(i.EQ. 8) gamprt(i) = 0.0835
9707  IF(i.EQ. 9) gamprt(i) = 0.0170
9708  IF(i.EQ.10) gamprt(i) = 0.0641
9709  IF(i.EQ.11) gamprt(i) = 0.00286
9710  IF(i.EQ.12) gamprt(i) = 0.0043
9711  IF(i.EQ.13) gamprt(i) = 0.0042
9712  IF(i.EQ.14) gamprt(i) = 0.0061
9713  IF(i.EQ.15) gamprt(i) = 0.0056
9714  IF(i.EQ.16) gamprt(i) = 0.0005
9715  IF(i.EQ.17) gamprt(i) = 0.0059
9716  IF(i.EQ.18) gamprt(i) = 0.0321
9717  IF(i.EQ.19) gamprt(i) = 0.0320
9718  IF(i.EQ.20) gamprt(i) = 0.0110
9719  IF(i.EQ.21) gamprt(i) = 0.0031
9720  IF(i.EQ.22) gamprt(i) = 0.0181
9721  IF(i.EQ. 8) names(i-7)=' TAU- --> 2PI-, PI0, PI+ '
9722  IF(i.EQ. 9) names(i-7)=' TAU- --> 3PI0, PI- '
9723  IF(i.EQ.10) names(i-7)=' TAU- --> 2PI-, PI+, 2PI0 '
9724  IF(i.EQ.11) names(i-7)=' TAU- --> 3PI-, 2PI+, '
9725  IF(i.EQ.12) names(i-7)=' TAU- --> 3PI-, 2PI+, PI0 '
9726  IF(i.EQ.13) names(i-7)=' TAU- --> 2PI-, PI+, 3PI0 '
9727  IF(i.EQ.14) names(i-7)=' TAU- --> K-, PI-, K+ '
9728  IF(i.EQ.15) names(i-7)=' TAU- --> K0, PI-, K0B '
9729  IF(i.EQ.16) names(i-7)=' TAU- --> K-, K0, PI0 '
9730  IF(i.EQ.17) names(i-7)=' TAU- --> PI0, PI0, K- '
9731  IF(i.EQ.18) names(i-7)=' TAU- --> K-, PI-, PI+ '
9732  IF(i.EQ.19) names(i-7)=' TAU- --> PI-, K0B, PI0 '
9733  IF(i.EQ.20) names(i-7)=' TAU- --> ETA, PI-, PI0 '
9734  IF(i.EQ.21) names(i-7)=' TAU- --> PI-, PI0, GAM '
9735  IF(i.EQ.22) names(i-7)=' TAU- --> K-, K0 '
9736  ELSE
9737  jlist(i) = 0
9738  gamprt(i) = 0.
9739  ENDIF
9740  10 CONTINUE
9741  DO i=1,nmode
9742  mulpik(i)=npik(i)
9743  DO j=1,mulpik(i)
9744  idffin(j,i)=nopik(j,i)
9745  ENDDO
9746  ENDDO
9747 C
9748 C
9749 C --- COEFFICIENTS TO FIX RATIO OF:
9750 C --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
9751 C --- PROBABILITY OF K0 TO BE KS
9752 C --- PROBABILITY OF K0B TO BE KS
9753 C --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
9754 C --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
9755 C --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
9756 C --- NEGLECTS MASS-PHASE SPACE EFFECTS
9757  bra1=0.5
9758  brk0=0.5
9759  brk0b=0.5
9760  brks=0.6667
9761 C
9762 C --- REMAINING CONSTANTS
9763  pi =4.*atan(1.)
9764  gfermi = 1.16637e-5
9765  ccabib = 0.975
9766  gv = 1.0
9767  ga =-1.0
9768 C ZW 13.04.89 HERE WAS AN ERROR
9769  scabib = sqrt(1.-ccabib**2)
9770  gamel = gfermi**2*amtau**5/(192*pi**3)
9771 C
9772 C CALL DEXAY(-1)
9773 C
9774  RETURN
9775  END
9776 
9777 *CMZ : 1.01/50 22/05/96 18.06.09 by Piero Zucchelli
9778 *CMZ : 1.01/22 29/05/95 15.21.25 BY PIERO ZUCCHELLI
9779 *CMZ : 1.01/14 14/05/95 11.26.28 BY PIERO ZUCCHELLI
9780 *CMZ : 1.01/11 13/05/95 19.10.40 BY PIERO ZUCCHELLI
9781 *CMZ : 1.01/08 05/03/95 11.39.27 BY PIERO ZUCCHELLI
9782 *CMZ : 1.00/00 09/08/94 17.43.59 BY PIERO ZUCCHELLI
9783 *-- AUTHOR :
9784  SUBROUTINE initdk_new
9785 C ----------------------------------------------------------------------
9786 C INITIALISATION OF TAU DECAY PARAMETERS AND ROUTINES
9787 C
9788 C CALLED BY : KORALZ
9789 C ----------------------------------------------------------------------
9790  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
9791  REAL*4 gfermi,gv,ga,ccabib,scabib,gamel
9792  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
9793  + ,ampiz,ampi,amro,gamro,ama1,gama1
9794  + ,amk,amkz,amkst,gamkst
9795 C
9796  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
9797  + ,ampiz,ampi,amro,gamro,ama1,gama1
9798  + ,amk,amkz,amkst,gamkst
9799  COMMON / taubra / gamprt(30),jlist(30),nchan
9800  COMMON / taukle / bra1,brk0,brk0b,brks
9801  REAL*4 bra1,brk0,brk0b,brks
9802  parameter(nmode=15,nm1=0,nm2=1,nm3=8,nm4=2,nm5=1,nm6=3)
9803  COMMON / mdecomp /idffin(9,nmode),mulpik(nmode)
9804  + ,names
9805  CHARACTER names(nmode)*31
9806  REAL*4 pi
9807 C
9808 C LIST OF BRANCHING RATIOS
9809 CAM NORMALISED TO E NU NUTAU CHANNEL
9810 CAM ENU MUNU PINU RHONU A1NU KNU K*NU PI'
9811 CAM DATA JLIST / 1, 2, 3, 4, 5, 6, 7,
9812 CAM DATA GAMPRT /1.000,0.9730,0.6054,1.2432,0.8432,0.0432,O.O811,0.616
9813 CAM
9814 CAM MULTIPION DECAYS
9815 C
9816 C CONVENTIONS OF PARTICLES NAMES
9817 C K-,P-,K+, K0,P-,KB, K-,P0,K0
9818 C 3, 1,-3 , 4, 1,-4 , 3, 2, 4 ,
9819 C P0,P0,K-, K-,P-,P+, P-,KB,P0
9820 C 2, 2, 3 , 3, 1,-1 , 1,-4, 2 ,
9821 C ET,P-,P0 P-,P0,GM
9822 C 9, 1, 2 , 1, 2, 8
9823 C
9824  dimension nopik(6,nmode),npik(nmode)
9825 CAM OUTGOING MULTIPLICITY AND FLAVORS OF MULTI-PION /MULTI-K MODES
9826  DATA npik / 4, 4,
9827  + 5, 5,
9828  + 6, 6,
9829  + 3, 3,
9830  + 3, 3,
9831  + 3, 3,
9832  + 3, 3,
9833  + 2 /
9834  DATA nopik / -1,-1, 1, 2, 0, 0, 2, 2, 2,-1, 0, 0,
9835  + -1,-1, 1, 2, 2, 0, -1,-1,-1, 1, 1, 0,
9836  + -1,-1,-1, 1, 1, 2, -1,-1, 1, 2, 2, 2,
9837  + -3,-1, 3, 0, 0, 0, -4,-1, 4, 0, 0, 0,
9838  + -3, 2,-4, 0, 0, 0, 2, 2,-3, 0, 0, 0,
9839  + -3,-1, 1, 0, 0, 0, -1, 4, 2, 0, 0, 0,
9840  + 9,-1, 2, 0, 0, 0, -1, 2, 8, 0, 0, 0,
9841  + -3, 4, 0, 0, 0, 0 /
9842 C LIST OF BRANCHING RATIOS
9843  nchan = nmode + 7
9844  DO 10 i = 1,30
9845  IF (i.LE.nchan) THEN
9846  jlist(i) = i
9847  IF(i.EQ. 1) gamprt(i) = 1.00000
9848  IF(i.EQ. 2) gamprt(i) = 0.98001
9849  IF(i.EQ. 3) gamprt(i) = 0.64964
9850  IF(i.EQ. 4) gamprt(i) = 1.39922
9851  IF(i.EQ. 5) gamprt(i) = 0.8432
9852  IF(i.EQ. 6) gamprt(i) = 0.03720
9853  IF(i.EQ. 7) gamprt(i) = 0.08051
9854  IF(i.EQ. 8) gamprt(i) = 0.0835
9855  IF(i.EQ. 9) gamprt(i) = 0.0170
9856  IF(i.EQ.10) gamprt(i) = 0.0641
9857  IF(i.EQ.11) gamprt(i) = 0.0286
9858  IF(i.EQ.12) gamprt(i) = 0.0043
9859  IF(i.EQ.13) gamprt(i) = 0.0042
9860  IF(i.EQ.14) gamprt(i) = 0.01222
9861  IF(i.EQ.15) gamprt(i) = 0.0056
9862  IF(i.EQ.16) gamprt(i) = 0.0005
9863  IF(i.EQ.17) gamprt(i) = 0.0059
9864  IF(i.EQ.18) gamprt(i) = 0.0321
9865  IF(i.EQ.19) gamprt(i) = 0.0320
9866  IF(i.EQ.20) gamprt(i) = 0.0110
9867  IF(i.EQ.21) gamprt(i) = 0.0031
9868  IF(i.EQ.22) gamprt(i) = 0.0181
9869  IF(i.EQ. 8) names(i-7)=' TAU- --> 2PI-, PI0, PI+ '
9870  IF(i.EQ. 9) names(i-7)=' TAU- --> 3PI0, PI- '
9871  IF(i.EQ.10) names(i-7)=' TAU- --> 2PI-, PI+, 2PI0 '
9872  IF(i.EQ.11) names(i-7)=' TAU- --> 3PI-, 2PI+, '
9873  IF(i.EQ.12) names(i-7)=' TAU- --> 3PI-, 2PI+, PI0 '
9874  IF(i.EQ.13) names(i-7)=' TAU- --> 2PI-, PI+, 3PI0 '
9875  IF(i.EQ.14) names(i-7)=' TAU- --> K-, PI-, K+ '
9876  IF(i.EQ.15) names(i-7)=' TAU- --> K0, PI-, K0B '
9877  IF(i.EQ.16) names(i-7)=' TAU- --> K-, K0, PI0 '
9878  IF(i.EQ.17) names(i-7)=' TAU- --> PI0, PI0, K- '
9879  IF(i.EQ.18) names(i-7)=' TAU- --> K-, PI-, PI+ '
9880  IF(i.EQ.19) names(i-7)=' TAU- --> PI-, K0B, PI0 '
9881  IF(i.EQ.20) names(i-7)=' TAU- --> ETA, PI-, PI0 '
9882  IF(i.EQ.21) names(i-7)=' TAU- --> PI-, PI0, GAM '
9883  IF(i.EQ.22) names(i-7)=' TAU- --> K-, K0 '
9884  ELSE
9885  jlist(i) = 0
9886  gamprt(i) = 0.
9887  ENDIF
9888  10 CONTINUE
9889  DO i=1,nmode
9890  mulpik(i)=npik(i)
9891  DO j=1,mulpik(i)
9892  idffin(j,i)=nopik(j,i)
9893  ENDDO
9894  ENDDO
9895 C
9896 C
9897 C --- COEFFICIENTS TO FIX RATIO OF:
9898 C --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
9899 C --- PROBABILITY OF K0 TO BE KS
9900 C --- PROBABILITY OF K0B TO BE KS
9901 C --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
9902 C --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
9903 C --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
9904 C --- NEGLECTS MASS-PHASE SPACE EFFECTS
9905  bra1=0.5
9906  brk0=0.5
9907  brk0b=0.5
9908  brks=0.6667
9909 C
9910 C --- REMAINING CONSTANTS
9911  pi =4.*atan(1.)
9912  gfermi = 1.16637e-5
9913  ccabib = 0.975
9914  gv = 1.0
9915  ga =-1.0
9916 C ZW 13.04.89 HERE WAS AN ERROR
9917  scabib = sqrt(1.-ccabib**2)
9918  gamel = gfermi**2*amtau**5/(192*pi**3)
9919 C
9920 C CALL DEXAY(-1)
9921 C
9922  RETURN
9923  END
9924 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
9925 *CMZ : 1.01/11 13/05/95 18.27.58 BY PIERO ZUCCHELLI
9926 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
9927 *CMZ : 1.00/00 10/08/94 16.29.39 BY PIERO ZUCCHELLI
9928 *-- AUTHOR :
9929  SUBROUTINE jaker(JAK)
9930 C *********************
9931 C
9932 C **********************************************************************
9933 C *
9934 C *********TAUOLA LIBRARY: VERSION 2.5 ******** *
9935 C **************JUNE 1994****************** *
9936 C ** AUTHORS: S.JADACH, Z.WAS ***** *
9937 C ** R. DECKER, M. JEZABEK, J.H.KUEHN, ***** *
9938 C ********AVAILABLE FROM: WASM AT CERNVM ****** *
9939 C *******PUBLISHED IN COMP. PHYS. COMM.******** *
9940 C *** PREPRINT CERN-TH-5856 SEPTEMBER 1990 **** *
9941 C *** PREPRINT CERN-TH-6195 OCTOBER 1991 **** *
9942 C *** PREPRINT CERN-TH-6793 NOVEMBER 1992 **** *
9943 C **********************************************************************
9944 C
9945 C ----------------------------------------------------------------------
9946 C SUBROUTINE JAKER,
9947 C CHOOSES DECAY MODE ACCORDING TO LIST OF BRANCHING RATIOS
9948 C JAK=1 ELECTRON MODE
9949 C JAK=2 MUON MODE
9950 C JAK=3 PION MODE
9951 C JAK=4 RHO MODE
9952 C JAK=5 A1 MODE
9953 C JAK=6 K MODE
9954 C JAK=7 K* MODE
9955 C JAK=8 NPI MODE
9956 C
9957 C CALLED BY : DEXAY
9958 C ----------------------------------------------------------------------
9959  COMMON / taubra / gamprt(30),jlist(30),nchan
9960  common/beri/jally,jein
9961 C REAL CUMUL(20)
9962  REAL cumul(30)
9963  INTEGER jally(30)
9964 C
9965  IF(nchan.LE.0.OR.nchan.GT.30) goto 30
9966  CALL ranmar(rrr,1)
9967  sum=0
9968  DO 10 i=1,nchan
9969  sum=sum+gamprt(i)
9970  10 cumul(i)=sum
9971  DO 20 i=nchan,1,-1
9972  IF(rrr.LT.cumul(i)/cumul(nchan)) ji=i
9973  20 CONTINUE
9974  jak=jlist(ji)
9975  jein=jak
9976  jally(jak)=jally(jak)+1
9977  RETURN
9978  30 print 10000
9979 10000 FORMAT(' ----- JAKER: WRONG NCHAN')
9980  stop
9981  END
9982 *CMZ : 13/03/97 16.01.10 by Unknown
9983 *CMZ : 1.02/09 14/01/97 15.08.05 by P. Zucchelli
9984 *CMZ : 1.01/37 01/08/95 15.05.38 BY PIERO ZUCCHELLI
9985 *CMZ : 1.01/36 31/07/95 17.54.39 BY PIERO ZUCCHELLI
9986 *CMZ : 1.01/34 12/07/95 11.32.39 BY PIERO ZUCCHELLI
9987 *CMZ : 1.01/33 12/07/95 10.47.16 BY PIERO ZUCCHELLI
9988 *CMZ : 1.01/08 05/03/95 11.35.13 BY PIERO ZUCCHELLI
9989 *CMZ : 1.01/01 08/09/94 12.44.55 BY PIERO ZUCCHELLI
9990 *CMZ : 1.01/00 08/09/94 09.48.55 BY PIERO ZUCCHELLI
9991 *CMZ : 1.00/00 15/08/94 07.06.13 BY PIERO ZUCCHELLI
9992 *CMZ : 1.00/00 20/07/94 12.08.20 BY PIERO ZUCCHELLI
9993 *-- AUTHOR :
9994  SUBROUTINE jetmc
9995 *KEEP,CDEBEAM.
9996 C--
9997  COMMON /contro/ binit,lunb,npneut,npanti,cpnorm,xpsour,sigdiv
9998  COMMON /fluxes/ fluxd(80000),weight(8),specd(800),specn(800)
9999  COMMON /input/ iall(80000),ncount(8)
10000  LOGICAL binit
10001 
10002 
10003 C-
10004 *KEEP,POLAR.
10005 C--
10006  COMMON /polariz/pol(4000,3)
10007  REAL polarx(4)
10008 *KEEP,LUDAT1.
10009  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
10010  SAVE /ludat1/
10011 *KEEP,LUJETS.
10012  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
10013  SAVE /lujets/
10014 *KEEP,FOREFI.
10015 C--
10016  INTEGER*4 ievt
10017  common/foreficass/ievt
10018 
10019 
10020 *KEEP,JETTA.
10021 C--
10022  parameter(icento=100)
10023  parameter(isiz=93)
10024  parameter(iof1=32)
10025  parameter(iof2=83)
10026  parameter(lux_level=4)
10027  INTEGER*4 jtau(100),jpri(100),jstro(100)
10028  REAL*4 ftuple(isiz)
10029  common/jettagl/jtau,jpri,jstro
10030  common/ntupla/ftuple,isfirst
10031  common/beam/spec(icento)
10032  COMMON /maxspec/rmaxspec,rintspec
10033  common/sav/xminsav(icento),xmaxsav(icento),yminsav(icento),
10034  & ymaxsav(icento),q2minsav(icento),q2maxsav(icento),
10035  & w2minsav(icento),w2maxsav(icento),parimax(icento),
10036  & ppsave(icento,3,4,5),paricor(icento),index,sigmasav(icento),
10037  & xmsigma,xsect
10038 
10039 *KEND.
10040 
10041  CALL vzero(jtau,100)
10042  CALL vzero(jpri,100)
10043  CALL vzero(jstro,100)
10044 
10045  i=4
10046  DO i=4,n
10047  ipa2=i
10048  11 CONTINUE
10049  IF(k(ipa2,2).EQ.92) jstro(i)=1
10050  igpa=k(ipa2,3)
10051  IF (igpa.NE.0) THEN
10052  ipa2=igpa
10053  goto 11
10054  ENDIF
10055 
10056 * SEARCH FOR UNDECAYED PARTICLES
10057  IF(k(i,4).EQ.0.AND.k(i,1).LE.10.AND.k(i,3).NE.0.AND. abs(k(i,2)
10058  + ).NE.12.AND.abs(k(i,2)).NE.14.AND. abs(k(i,2)).NE.16) THEN
10059 
10060 * WRITE(88,*)'PT:',IEVT,I
10061 * LET'S FILL IN THE INTERESTING CALORIMETER INFORMATIONS:
10062  icharge=luchge(k(i,2))
10063  ismissed=0
10064  ftuple(65)=ftuple(65)+p(i,4)
10065  ftuple(68)=ftuple(68)+1
10066  IF (icharge.EQ.0) ftuple(71)=ftuple(71)+1
10067  IF (abs(k(i,2)).EQ.11.OR.abs(k(i,2)).EQ.22) THEN
10068 * PHOTON,E ARE CONSIDERED EM ENERGY DEPOSIT
10069  ftuple(66)=ftuple(66)+p(i,4)
10070  ftuple(69)=ftuple(69)+1
10071  IF (icharge.EQ.0) ftuple(72)=ftuple(72)+1
10072  ismissed=1
10073  ENDIF
10074 
10075  IF (abs(k(i,2)).GE.100.and.k(i,1).le.10.and.
10076  + k(i,1).ge.1) THEN
10077 * STABLE PARTICLES WITH QUARKS RELEASE HADRONIC ENERGY, SO...
10078  ftuple(67)=ftuple(67)+p(i,4)
10079  ftuple(70)=ftuple(70)+1
10080  IF (icharge.EQ.0) ftuple(73)=ftuple(73)+1
10081  ismissed=1
10082  ENDIF
10083 
10084  IF (ismissed.EQ.0.AND.abs(k(i,2)).NE.13) THEN
10085  WRITE(*,*)' MISSED EM/HAD/MU PARTICLE:',k(i,2)
10086  ENDIF
10087 
10088 * NOW SEARCH FOR TAU ANCESTOR
10089  ipa=i
10090  10 CONTINUE
10091  igrandpa=k(ipa,3)
10092  IF (igrandpa.NE.0) THEN
10093  ipa=igrandpa
10094  goto 10
10095  ENDIF
10096  etot=p(i,4)
10097 * WRITE(*,*)'I,IPA,CHG E=',I,IPA,LUCHGE(K(I,2))/3,ETOT
10098 
10099  IF (ipa.EQ.1) THEN
10100  jtau(i)=1
10101  ELSE
10102  jpri(i)=1
10103  ENDIF
10104 
10105  ENDIF
10106 
10107  END DO
10108 
10109  RETURN
10110  END
10111 *CMZ : 1.02/09 14/01/97 15.58.27 by P. Zucchelli
10112 *CMZ : 1.01/52 19/11/96 17.37.58 by Piero Zucchelli
10113 *CMZ : 1.01/51 05/08/96 09.01.24 by Piero Zucchelli
10114 *CMZ : 1.01/50 23/05/96 12.34.50 by Piero Zucchelli
10115 *CMZ : 1.01/49 29/01/96 16.02.04 by Piero Zucchelli
10116 *CMZ : 1.01/48 15/01/96 15.30.50 by Piero Zucchelli
10117 *CMZ : 1.01/47 11/01/96 10.11.37 by Piero Zucchelli
10118 *CMZ : 1.01/46 09/01/96 11.47.50 by Piero Zucchelli
10119 *CMZ : 1.01/45 08/01/96 14.22.55 by Piero Zucchelli
10120 *CMZ : 1.01/43 15/12/95 18.03.32 by Piero Zucchelli
10121 *CMZ : 1.01/40 11/12/95 12.39.22 by Piero Zucchelli
10122 *CMZ : 1.01/39 06/11/95 14.45.27 by Piero Zucchelli
10123 *CMZ : 1.01/37 21/09/95 12.47.07 BY PIERO ZUCCHELLI
10124 *CMZ : 1.01/36 31/07/95 18.03.46 BY PIERO ZUCCHELLI
10125 *CMZ : 1.01/35 26/07/95 15.13.48 BY PIERO ZUCCHELLI
10126 *CMZ : 1.01/34 25/07/95 11.31.42 BY PIERO ZUCCHELLI
10127 *CMZ : 1.01/33 12/07/95 11.18.32 BY PIERO ZUCCHELLI
10128 *CMZ : 1.01/21 27/05/95 15.58.38 BY PIERO ZUCCHELLI
10129 *CMZ : 1.01/20 21/05/95 14.50.37 BY PIERO ZUCCHELLI
10130 *CMZ : 1.01/19 16/05/95 08.23.30 BY UNKNOWN
10131 *CMZ : 1.01/18 14/05/95 16.16.54 BY PIERO ZUCCHELLI
10132 *CMZ : 1.01/14 14/05/95 11.26.28 BY PIERO ZUCCHELLI
10133 *CMZ : 1.01/13 14/05/95 11.22.22 BY PIERO ZUCCHELLI
10134 *CMZ : 1.01/11 14/05/95 11.17.15 BY PIERO ZUCCHELLI
10135 *CMZ : 1.01/10 13/05/95 10.26.44 BY PIERO ZUCCHELLI
10136 *CMZ : 1.01/09 20/04/95 12.52.49 BY PIERO ZUCCHELLI
10137 *CMZ : 1.01/08 05/03/95 11.39.27 BY PIERO ZUCCHELLI
10138 *CMZ : 1.01/07 05/03/95 11.34.14 BY PIERO ZUCCHELLI
10139 *CMZ : 1.01/06 05/03/95 11.20.39 BY PIERO ZUCCHELLI
10140 *CMZ : 1.01/03 04/03/95 23.35.00 BY PIERO ZUCCHELLI
10141 *CMZ : 1.01/02 04/03/95 21.38.55 BY PIERO ZUCCHELLI
10142 *CMZ : 1.01/01 04/03/95 21.18.20 BY PIERO ZUCCHELLI
10143 *CMZ : 1.00/00 21/08/94 11.05.12 BY PIERO ZUCCHELLI
10144 *-- AUTHOR : PIERO ZUCCHELLI 29/07/94
10145 
10146  SUBROUTINE jettout
10147 *KEEP,FOREFI.
10148 C--
10149  INTEGER*4 ievt
10150  common/foreficass/ievt
10151 
10152 
10153 *KEEP,JETTA.
10154 C--
10155  parameter(icento=100)
10156  parameter(isiz=93)
10157  parameter(iof1=32)
10158  parameter(iof2=83)
10159  parameter(lux_level=4)
10160  INTEGER*4 jtau(100),jpri(100),jstro(100)
10161  REAL*4 ftuple(isiz)
10162  common/jettagl/jtau,jpri,jstro
10163  common/ntupla/ftuple,isfirst
10164  common/beam/spec(icento)
10165  COMMON /maxspec/rmaxspec,rintspec
10166  common/sav/xminsav(icento),xmaxsav(icento),yminsav(icento),
10167  & ymaxsav(icento),q2minsav(icento),q2maxsav(icento),
10168  & w2minsav(icento),w2maxsav(icento),parimax(icento),
10169  & ppsave(icento,3,4,5),paricor(icento),index,sigmasav(icento),
10170  & xmsigma,xsect
10171 
10172 *KEEP,LUDAT1.
10173  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
10174  SAVE /ludat1/
10175 *KEEP,LUJETS.
10176  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
10177  SAVE /lujets/
10178 *KEEP,KEYS.
10179  common/cfread/space(5000)
10180  common/mykeys/ievar,if5cc,ineut,iinte,iferm,iflat,icoun,
10181  & refix,imudo,ikat1,ikat2,ikat3,ikat4,ikat5,ikat6,
10182  & inevt,ijak1,ijak2,iitdk,rptau,rxk0d,ntgr,idimuon,iglu,
10183  & iqden,lome(2),ifiles,iccha,iseed,idsubs,ionem,ehac,ipsel,
10184  & ihist
10185 
10186 
10187 *KEEP,zebra.
10188 
10189  parameter(nnq=1000000)
10190 *
10191  dimension lq(nnq),iq(nnq),q(nnq)
10192  equivalence(q(1),iq(1),lq(9),jstruc(8))
10193  COMMON /quest/iquest(100)
10194  COMMON /xqstor/ixevt,ifence(16),jgeev,jstruc(99),jrefer(100),
10195  +div12(nnq)
10196  COMMON /fzlun/lunfz
10197  common/mzioall/iogenf
10198 
10199 *KEND.
10200  parameter(maxv=20)
10201  parameter(maxt=50)
10202  REAL*4 vert(maxv,3)
10203  REAL*4 wa59(maxt,9),vec(8)
10204  REAL*4 tmpar(3),vstr(3),pm(3),ph(3)
10205  INTEGER ntrv(maxv)
10206  INTEGER lbea(maxv)
10207  INTEGER ntbeam(maxv)
10208  INTEGER ipart(maxv,maxt)
10209  INTEGER lpart(maxv,maxt)
10210  INTEGER lstrfrom(maxv,maxt)
10211  INTEGER lstrda(maxv,maxt)
10212  INTEGER ktrk(maxv,maxt)
10213  REAL*4 plab(maxv,maxt,3)
10214  REAL*4 ubuft(maxv,maxt,7)
10215  INTEGER unouno
10216  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
10217  common/sbeam/ pnumber,neutype,vect(3),gkin(3),mestype,g4mes(4)
10218  REAL*4 beamft(7)
10219  INTEGER*4 daluaef(200)
10220  common/dalua/daluaef
10221 
10222  CALL vzero(lstrfrom,maxv*maxt)
10223  CALL vzero(lstrda,maxv*maxt)
10224 
10225 
10226  lout=12
10227  IF (unouno.EQ.0) THEN
10228  unouno=1
10229 * OPEN(UNIT=LOUT,ERR=9191,ACCESS='SEQUENTIAL',FORM='UNFORMATTED')
10230  ENDIF
10231 
10232  emin=.000000
10233 * 5 MEV CUTOFF,SORRY ABOUT THIS....
10234 
10235 
10236  idevt=ievt
10237  lnu =lutoge(k(1,2))
10238  llep=lutoge(k(4,2))
10239  lcha=0
10240  ntrk=0
10241  nvtx=0
10242  enu=p(1,4)
10243  ilastd=0
10244 
10245  curvz=-1.
10246 
10247  lcha=0.
10248  CALL vzero(daluaef,200)
10249 
10250  DO i=1,n
10251 
10252  IF (k(i,2).EQ.92) THEN
10253  str=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
10254  DO ib=1,3
10255  vstr(ib)=p(i,ib)/str
10256  ENDDO
10257  ENDIF
10258 
10259 
10260  IF ((k(i,1).LE.10.OR.(k(i,1).GT.10.AND.
10261  + k(i,4).GT.0.AND.v(i,5).NE.0).AND.p(i,4)
10262  + .GT.emin).OR.i.EQ.4) THEN
10263 
10264  ltmp =lutoge(k(i,2))
10265 
10266 *DETECT CHARM DECAY, KEEP INDEX IN ILASTD
10267  IF((abs(k(i,2)).GT.400.AND.abs(k(i,2)).LT.500)
10268  + .OR.abs(k(i,2)).EQ.4122) THEN
10269  lcha=lutoge(k(i,2))
10270  ftuple(iof1+7)=ftuple(iof1+7)+1
10271  ilastd=i
10272  ENDIF
10273 
10274 * ASSUME 1ST ORDER THAT LUND DECAY VERTEX ARE ORDERED BY Z DIRECTION
10275  IF (v(i,3).NE.curvz) THEN
10276 * HAVE WE FOUND A NEW DECAY VERTEX ?
10277  isfound=1
10278 * TO BE SURE, CHECK ALL THE VERTEX FOUND
10279  DO jj=1,nvtx
10280  IF (v(i,3).EQ.vert(jj,3)) THEN
10281 * SORRY , I WAS WRONG
10282  isfound=0
10283  ENDIF
10284  END DO
10285  IF (isfound.EQ.1) THEN
10286 * THIS IS A NEW VERTEX....
10287  nvtx=nvtx+1
10288 * UPDATE CURVZ
10289  curvz=v(i,3)
10290 * FILL VERT INFORMATIONS
10291  DO j=1,3
10292  vert(nvtx,j)=v(i,j)
10293  END DO
10294 * AND TAKE A "CANDIDATE" PARENT
10295  iparent=k(i,3)
10296 
10297  10 CONTINUE
10298 
10299  IF (iparent.NE.0) THEN
10300 * IF IT'S NOT DIRECTLY COMING FROM THE BEAM,
10301  idt=k(iparent,2)
10302 * NOW WE HAVE THE ID OF THE PARENT CANDIDATE
10303 * AND WE ASK IT TO BE A TRACK (I.E. CTAU>0) WHICH HAS ACTUALLY DECAYED
10304  IF (k(iparent,4).GT.0..AND.
10305  + v(iparent,5).NE.0.AND.k(iparent,1).GT.10) THEN
10306  lbea(nvtx)=lutoge(idt)
10307  ELSE
10308 * GO UP AND LOOK FOR IT
10309  iparent=k(iparent,3)
10310  goto 10
10311  ENDIF
10312 
10313 
10314  ELSE
10315  lbea(nvtx)=4
10316  ENDIF
10317 * DEBUG
10318  IF (ievt.GE.lome(1).AND.ievt.LE.lome(2)) THEN
10319  WRITE(*,*)' VERTEX PARENT FOR PARTICLE NUMBER',
10320  + i,' = ', rent,ipa
10321  ENDIF
10322  ntbeam(nvtx)=iparent
10323  ENDIF
10324  ENDIF
10325 
10326  ENDIF
10327  END DO
10328 
10329 * COUNT TRACKS IN EACH VERTEX
10330 * LOOP ON VERTEXES
10331  DO j=1,nvtx
10332  ntrv(j)=0
10333  DO i=1,n
10334  IF (k(i,2).EQ.92) istringa=i
10335  IF ((k(i,1).LE.10.OR.(k(i,1).GT.10.AND.
10336  + k(i,4).GT.0.AND.v(i,5).NE.0)).AND.p(i,
10337  + 4).GT.emin.OR.i.EQ.4) THEN
10338  IF (v(i,3).EQ.vert(j,3)) THEN
10339 * COUNT TOTAL TRACKS AND TRACKS FROM THAT VERTEX
10340  ntrv(j)=ntrv(j)+1
10341  ntrk=ntrk+1
10342 * PUT IN DALUAEF ARRAY THE EFICASS POSITION FOR THAT PARTICLE
10343  daluaef(i)=ntrk
10344  ktrk(j,ntrv(j))=ntrk
10345 * TAKE GEANT PARTICLE CODE
10346  ipart(j,ntrv(j))=lutoge(k(i,2))
10347  lpart(j,ntrv(j))=k(i,2)
10348  lstrfrom(j,ntrv(j))=jstro(i)
10349  IF (k(i,3).EQ.istringa) THEN
10350  lstrda(j,ntrv(j))=1
10351  ENDIF
10352 
10353 * TAKE PARTICLE MOMENTUM
10354  DO kk=1,3
10355  plab(j,ntrv(j),kk)=p(i,kk)
10356  END DO
10357 * FILL PT, P, E
10358  ubuft(j,ntrv(j),1)=sqrt(p(i,1)**2+p(i,2)**2)
10359  ubuft(j,ntrv(j),2)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
10360  ubuft(j,ntrv(j),3)=p(i,4)
10361  ppp=ubuft(j,ntrv(j),2)
10362 * BETAI=PI/P
10363  IF (ppp.GT.0) THEN
10364  DO kk=1,3
10365  ubuft(j,ntrv(j),3+kk)=p(i,kk)/ppp
10366  END DO
10367  ELSE
10368  DO kk=1,3
10369  ubuft(j,ntrv(j),3+kk)=0.
10370  END DO
10371  ENDIF
10372 * FILL 0 THE TRACK LENGTH
10373  ubuft(j,ntrv(j),7)=0.
10374 * CALCULATE TRACK LENGTH: GAMMA BETA C TAU
10375  IF (k(i,4).NE.0.AND.v(i,5).NE.0) THEN
10376  IF (p(i,5).GT.0) THEN
10377  ubuft(j,ntrv(j),7)=v(i,5)*ppp/p(i,5)/10.
10378  ELSE
10379  ubuft(j,ntrv(j),7)=0.
10380  ENDIF
10381  ENDIF
10382 * VERY IMPORTANT FOR NEW JETSET CUT IN DECAYS
10383  IF (k(i,4).EQ.0) ubuft(j,ntrv(j),7)=0.
10384  IF (ievt.GE.lome(1).AND.ievt.LE.lome(2)) THEN
10385  WRITE(*,*)'TRACK ',i,'FROM VTX ',j,' PARENTID=',lbea(j)
10386  ENDIF
10387  ENDIF
10388  ENDIF
10389  END DO
10390  END DO
10391 
10392 
10393 * SIMULATE OUTPUT
10394 
10395  temulx=rndmm(iseed)*140.-70.
10396  temuly=rndmm(iseed)*140.-70.
10397  ftuple(iof2+1)=temulx
10398  ftuple(iof2+2)=temuly
10399  xbari=0
10400  ybari=0
10401  xmbari=0
10402  ymbari=0
10403  xbaria=0
10404  ybaria=0
10405  plaa=0
10406 
10407  nmu=0
10408  nhad=0
10409 
10410  CALL mzbook(ixevt,jgege,jgeev,-3,'GEGE',nvtx,nvtx,7,3,0)
10411  CALL mzbook(ixevt,jgebe,jgeev,-4,'GEBE',0,0,14,3,0)
10412  jgege=lq(jgeev-3)
10413  q(jgege+1)=idevt
10414  q(jgege+2)=lnu
10415  q(jgege+3)=llep
10416  q(jgege+4)=lcha
10417  q(jgege+5)=nvtx
10418  q(jgege+6)=ntrk
10419  q(jgege+7)=enu
10420 
10421  WRITE(lout)idevt,lnu,llep,lcha,nvtx+1,ntrk,enu
10422  IF (ievt.GE.lome(1).AND.ievt.LE.lome(2)) THEN
10423  WRITE(*,*)'OUTPUT-EVT',idevt,lnu,llep,lcha,nvtx+1,ntrk,enu
10424  ENDIF
10425 
10426  jgebe=lq(jgeev-4)
10427  DO iju=1,3
10428  q(jgebe+iju)=vect(iju)
10429  q(jgebe+iju+3)=gkin(iju)
10430  ENDDO
10431  q(jgebe+7)=neutype
10432  q(jgebe+8)=xsect
10433  q(jgebe+9)=pnumber
10434 
10435  beamft(1)=mestype
10436  beamft(2)=g4mes(1)
10437  beamft(3)=g4mes(2)
10438  beamft(4)=g4mes(3)
10439  beamft(5)=g4mes(4)
10440  beamft(6)=xsect
10441  beamft(7)=pnumber
10442 
10443  DO iri=1,7
10444  q(jgebe+6+iri)=beamft(iri)
10445  ENDDO
10446 
10447  WRITE(lout)1,1,0,0,(vect(kk),kk=1,3)
10448  WRITE(lout)1,1,1,neutype,(gkin(kk),kk=1,3), (beamft(kk),kk=1,7)
10449  IF (ievt.GE.lome(1).AND.ievt.LE.lome(2)) THEN
10450  WRITE(*,*)'OUTPUT-VERT-NEUTRINO ',1,1,0,0,(vect(kk),kk=1,3)
10451  WRITE(*,*)'OUTPUT-PART-NEUTRINO ' ,1,1,1,neutype,(gkin(kk),kk=
10452  + 1,3), (beamft(kk),kk=1,7)
10453  ENDIF
10454 
10455  DO j=1,nvtx
10456  itruentbeam=daluaef(ntbeam(j))
10457  IF (ntrv(j).EQ.0) THEN
10458  WRITE(*,*)'DANGER! VERTEX WITH 0 TRACKS:NVTX=',nvtx
10459  WRITE(*,*)'VERT,IDEVT=',vert(j,3),idevt
10460  CALL lulist(3)
10461  WRITE(*,*)'END DANGER! '
10462  ENDIF
10463  DO jj=1,3
10464  tmpar(jj)=vert(j,jj)/10.
10465  END DO
10466  jgege=lq(jgeev-3)
10467  CALL mzbook(ixevt,jgevt,jgege,-j,'GEVT',ntrv(j),ntrv(j),7,3,0)
10468  q(jgevt+1)=j
10469  q(jgevt+2)=ntrv(j)
10470  q(jgevt+3)=itruentbeam
10471  q(jgevt+4)=lbea(j)
10472  DO jj=1,3
10473  q(jgevt+4+jj)=tmpar(jj)
10474  END DO
10475  WRITE(lout)j+1,ntrv(j),itruentbeam,lbea(j),
10476  + (tmpar(jj),jj=1,3)
10477  IF (ievt.GE.lome(1).AND.ievt.LE.lome(2)) THEN
10478  WRITE(*,*)'OUTPUT-VERT=',j,ntrv(j),itruentbeam,lbea(j),
10479  + (tmpar(jj),jj=1,3)
10480  ENDIF
10481 
10482 * NOW LOOP ON SINGLE VERTEX HERE
10483  DO i=1,ntrv(j)
10484  jgege=lq(jgeev-3)
10485  jgevt=lq(jgege-j)
10486  CALL mzbook(ixevt,jgetr,jgevt,-i,'GETR',0,0,14,3,0)
10487  q(jgetr+1)=ktrk(j,i)
10488  q(jgetr+2)=i
10489  q(jgetr+3)=j
10490  q(jgetr+4)=ipart(j,i)
10491  DO kk=1,3
10492  q(jgetr+4+kk)=plab(j,i,kk)
10493  ENDDO
10494  DO kk=1,7
10495  q(jgetr+7+kk)=ubuft(j,i,kk)
10496  ENDDO
10497  WRITE(lout)ktrk(j,i)+1,i,j+1,ipart(j,i),(plab(j,i,kk),kk=1,3),
10498  + (ubuft(j,i,kk),kk=1,7)
10499  IF (ievt.GE.lome(1).AND.ievt.LE.lome(2)) THEN
10500  WRITE(*,*)'OUTPUT-TRACK=',ktrk(j,i),i,j,ipart(j,i), (plab(j
10501  + ,i,kk),kk=1,3), (ubuft(j,i,kk),kk=1,7)
10502  ENDIF
10503  IF (ipart(j,i).EQ.34.OR.
10504  + ipart(j,i).EQ.33) THEN
10505  ftuple(80)=ubuft(j,i,7)
10506  ENDIF
10507 
10508  IF (ipart(j,i).EQ.35.OR.ipart(j,i).EQ.36.OR.
10509  + ipart(j,i).EQ.37.OR.ipart(j,i).EQ.38.OR.
10510  + ipart(j,i).EQ.39.OR.ipart(j,i).EQ.40.OR.
10511  + ipart(j,i).EQ.41.OR.ipart(j,i).EQ.42.OR.
10512  + ipart(j,i).EQ.43.OR.ipart(j,i).EQ.44.OR.
10513  + ipart(j,i).EQ.45.OR.ipart(j,i).EQ.46
10514  + ) THEN
10515  ftuple(iof1+10)=ubuft(j,i,7)
10516  ftuple(iof1+11)=ipart(j,i)
10517  ftuple(iof1+12)=ubuft(j,i,2)
10518  ftuple(iof1+13)=ubuft(j,i,3)
10519  ftuple(iof1+15)=plab(j,i,1)
10520  ftuple(iof1+16)=plab(j,i,2)
10521  ftuple(iof1+17)=plab(j,i,3)
10522  ENDIF
10523 
10524  IF(ubuft(j,i,7).EQ.0) THEN
10525 
10526  pla=sqrt(plab(j,i,1)**2+plab(j,i,2)**2+plab(j,i,3)**2)
10527 
10528 * CHECK PT IN FRAGMENTATION
10529 
10530 
10531 * CONSTRUCT Z VARIABLE
10532 
10533  ethis=ubuft(j,i,3)
10534 
10535  IF (lstrfrom(j,i).GT.0) THEN
10536  ptsr=plab(j,i,1)*vstr(1)+ plab(j,i,2)*vstr(2)+plab(j,i,3)
10537  + *vstr(3)
10538  ptstrfin=sqrt(pla**2-ptsr**2)
10539  thcas=rndmm(iseed)*3.141*2
10540  CALL hfill(1011,ptstrfin*cos(thcas),0.,1.)
10541  CALL hfill(1011,ptstrfin*sin(thcas),0.,1.)
10542  ENDIF
10543  IF (lstrda(j,i).GT.0) THEN
10544  ptsr=plab(j,i,1)*vstr(1)+ plab(j,i,2)*vstr(2)+plab(j,i,3)
10545  + *vstr(3)
10546  ptstrfin=sqrt(pla**2-ptsr**2)
10547  thcas=rndmm(iseed)*3.141*2
10548 
10549 * CHECK ON D(Z) AS IN ALLASIA ET AL., Z PHYS C 24, 119-131 (1984)
10550 * CHECK ON D(X_F) AS IN ALLEN ET AL., NUCL PHYS. B214 (1983) 369-391
10551  zzz=ethis/u
10552  xf=2*ptsr/sqrt(w2)
10553  ichg=luchge(lpart(j,i))
10554  IF (ipart(j,i).EQ.8) THEN
10555  IF (w2.GT.3) THEN
10556  CALL hfill(1015,xf,0.,1.)
10557  ENDIF
10558  ENDIF
10559  IF (ipart(j,i).EQ.9) THEN
10560  IF (w2.GT.3) THEN
10561  CALL hfill(1016,xf,0.,1.)
10562  ENDIF
10563  ENDIF
10564  IF (w2.GT.5.AND.q2.GT.1) THEN
10565  IF (ichg.GT.0) THEN
10566  CALL hfill(1013,zzz,0.,1.)
10567  ELSE
10568  CALL hfill(1014,zzz,0.,1.)
10569  ENDIF
10570  ENDIF
10571  CALL hfill(1012,ptstrfin*cos(thcas),0.,1.)
10572  CALL hfill(1012,ptstrfin*sin(thcas),0.,1.)
10573  ENDIF
10574  ENDIF
10575  END DO
10576  END DO
10577 
10578 
10579  RETURN
10580  END
10581 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
10582 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
10583 *-- AUTHOR :
10584 C **********************************************************************
10585 
10586  SUBROUTINE lazimu(XP,ZP)
10587 
10588 C...CHOOSE AZIMUTHAL ANGLE (PHI) ACCORDING TO QCD MATRIX ELEMENTS.
10589  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
10590  COMMON /linter/ pari(40),ewqc(2,2,8),qc(8),zl(2,4),zq(2,8),pq(17)
10591 
10592  j=lst(24)-1
10593  sgn=sign(1.,2.5-lst(24))
10594  ifl=lst(25)
10595  i=iabs(ifl)
10596  ih=1
10597  IF(lst(30).EQ.1) ih=2
10598 
10599  IF(lst(23).EQ.2) THEN
10600  a=pari(24)*dqcd(0,j,1,xp,zp,y)+pari(25)*dqcd(0,j,2,xp,zp,y)
10601  & -lst(30)*isign(1,ifl)*pari(26)*dqcd(0,j,3,xp,zp,y)
10602  b=dqcd(1,j,1,xp,zp,y)
10603  & +sgn*lst(30)*isign(1,ifl)*dqcd(1,j,3,xp,zp,y)
10604  c=dqcd(2,j,1,xp,zp,y)
10605  ELSE
10606  a=(ewqc(1,ih,i)+ewqc(2,ih,i))*(pari(24)*dqcd(0,j,1,xp,zp,y)+
10607  & pari(25)*dqcd(0,j,2,xp,zp,y))
10608  & -lst(30)*isign(1,ifl)*(ewqc(1,ih,i)-ewqc(2,ih,i))
10609  & *pari(26)*dqcd(0,j,3,xp,zp,y)
10610  b=(ewqc(1,ih,i)+ewqc(2,ih,i))*dqcd(1,j,1,xp,zp,y)
10611  & +sgn*lst(30)*isign(1,ifl)*(ewqc(1,ih,i)-ewqc(2,ih,i))
10612  & *dqcd(1,j,3,xp,zp,y)
10613  c=(ewqc(1,ih,i)+ewqc(2,ih,i))*dqcd(2,j,1,xp,zp,y)
10614  ENDIF
10615  phimax=abs(a)+abs(b)+abs(c)
10616  10 phi=6.2832*rlu(0)
10617  IF(a+b*cos(phi)+c*cos(2.*phi).LT.rlu(0)*phimax) goto 10
10618  CALL lurobo(0.,phi,0.,0.,0.)
10619 
10620  RETURN
10621  END
10622 *CMZ : 1.01/33 11/07/95 18.31.20 BY PIERO ZUCCHELLI
10623 *CMZ : 1.01/08 05/03/95 11.35.13 BY PIERO ZUCCHELLI
10624 *CMZ : 1.00/00 29/07/94 17.22.12 BY PIERO ZUCCHELLI
10625 *CMZ : 1.00/00 20/07/94 12.26.37 BY PIERO ZUCCHELLI
10626 *-- AUTHOR :
10627  SUBROUTINE jetta
10628 *KEEP,CDEBEAM.
10629 C--
10630  COMMON /contro/ binit,lunb,npneut,npanti,cpnorm,xpsour,sigdiv
10631  COMMON /fluxes/ fluxd(80000),weight(8),specd(800),specn(800)
10632  COMMON /input/ iall(80000),ncount(8)
10633  LOGICAL binit
10634 
10635 
10636 C-
10637 *KEEP,POLAR.
10638 C--
10639  COMMON /polariz/pol(4000,3)
10640  REAL polarx(4)
10641 *KEEP,LUDAT1.
10642  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
10643  SAVE /ludat1/
10644 *KEEP,LUJETS.
10645  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
10646  SAVE /lujets/
10647 *KEEP,JETTA.
10648 C--
10649  parameter(icento=100)
10650  parameter(isiz=93)
10651  parameter(iof1=32)
10652  parameter(iof2=83)
10653  parameter(lux_level=4)
10654  INTEGER*4 jtau(100),jpri(100),jstro(100)
10655  REAL*4 ftuple(isiz)
10656  common/jettagl/jtau,jpri,jstro
10657  common/ntupla/ftuple,isfirst
10658  common/beam/spec(icento)
10659  COMMON /maxspec/rmaxspec,rintspec
10660  common/sav/xminsav(icento),xmaxsav(icento),yminsav(icento),
10661  & ymaxsav(icento),q2minsav(icento),q2maxsav(icento),
10662  & w2minsav(icento),w2maxsav(icento),parimax(icento),
10663  & ppsave(icento,3,4,5),paricor(icento),index,sigmasav(icento),
10664  & xmsigma,xsect
10665 
10666 *KEEP,FOREFI.
10667 C--
10668  INTEGER*4 ievt
10669  common/foreficass/ievt
10670 
10671 
10672 *KEND.
10673 
10674  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
10675 
10676 * FIRST, CALCULATE MEAN CHARGED MULTIPLICITIES
10677 
10678  ichgpri=0
10679  ineupri=0
10680  ichgtau=0
10681  ineutau=0
10682  ichgcha=0
10683 
10684  enetauchg=0
10685  enetauneu=0
10686  eneprichg=0
10687  eneprineu=0
10688 
10689 
10690  DO i=1,n
10691 
10692  IF (k(i,2).EQ.92) THEN
10693  ftuple(31)=p(i,4)
10694  ftuple(32)=p(i,5)
10695 * WRITE(*,*)'W2 AND WSTR2:',W2,P(I,5)**2
10696  ENDIF
10697 
10698  IF(jtau(i).EQ.1) THEN
10699  IF(luchge(k(i,2)).NE.0) THEN
10700  ichgtau=ichgtau+1
10701  enetauchg=enetauchg+p(i,4)
10702  ELSE
10703  ineutau=ineutau+1
10704  enetauneu=enetauneu+p(i,4)
10705  ENDIF
10706  ENDIF
10707 
10708  IF(jpri(i).EQ.1) THEN
10709  IF(luchge(k(i,2)).NE.0) THEN
10710  ichgpri=ichgpri+1
10711  eneprichg=eneprichg+p(i,4)
10712  ELSE
10713  ineupri=ineupri+1
10714  eneprineu=eneprineu+p(i,4)
10715  ENDIF
10716  ENDIF
10717 
10718  END DO
10719 
10720 * WRITE(*,*)'ICHGPRI,ENEPRICHG=',ICHGPRI,ENEPRICHG
10721 
10722  ftuple(20)=ichgtau
10723  ftuple(21)=ineutau
10724  ftuple(22)=ichgpri
10725  ftuple(23)=ineupri
10726  ftuple(24)=enetauchg
10727  ftuple(25)=enetauneu
10728  ftuple(26)=eneprichg
10729  ftuple(27)=eneprineu
10730 
10731  RETURN
10732  END
10733 *CMZ : 04/03/97 12.54.46 by Unknown
10734 *CMZ : 1.01/22 27/05/95 16.18.36 BY PIERO ZUCCHELLI
10735 *CMZ : 1.00/00 04/07/94 15.02.26 BY PIERO ZUCCHELLI
10736 *-- AUTHOR :
10737 C **********************************************************************
10738 
10739  BLOCK DATA leptod
10740 
10741 C...GIVE SENSIBLE DEFAULT VALUES TO SWITCHES AND PARAMETERS.
10742 
10743  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
10744  COMMON /linter/ pari(40),ewqc(2,2,8),qc(8),zl(2,4),zq(2,8),pq(17)
10745  COMMON /lflmix/ cabibo(4,4)
10746  COMMON /loptim/ optx(4),opty(4),optq2(4),optw2(4),comfac
10747  COMMON /lgrid/ nxx,nww,xx(20),ww(15),pqg(20,15,3),pqqb(20,15,2),
10748  &qgmax(20,15,3),qqbmax(20,15,2),ycut(20,15),xtot(20,15),np
10749  COMMON /flgrid/ nfx,nfq,xr(2),qr(2),flqt(41,16),flgt(41,16),
10750  &flmt(41,16)
10751  COMMON /pypara/ ipy(80),pypar(80),pyvar(80)
10752  COMMON /lminui/ xkin(4),ukin(4),wkin(4),ain(4),bin(4),
10753  &maxfin,relup,relerr,reler2,fcnmax
10754  COMMON /lminuc/ namkin(4),nam(30)
10755  CHARACTER*10 namkin,nam
10756 
10757 C...LEPTOU: CUTS, BASIC SWITCHES AND PARAMETERS.
10758  DATA cut/1.e-04,1.,0.,1.,4.,1.e+08,5.,1.e+08,.1,1.e+08,.1,1.e+08,
10759  &0.,3.1416/
10760  DATA lst/0,1,5,1,3,1,1,12,5,1,0,4,5,1,1,1,0,2,3,21*0/
10761  DATA parl/1.,1.,0.44,0.75,0.226,0.,0.,0.015,2.,0.,0.01,4.,
10762  &0.001,0.44,0.01,7.29735e-03,1.16637e-05,0.044,0.03,1.,10*0./
10763 C...INTERNALLY USED VARIABLES.
10764  DATA pari/40*0./
10765  DATA qc/-.33333,.66667,-.33333,.66667,-.33333,.66667,
10766  & -.33333,.66667/
10767  DATA cabibo/.95,.05,2*0.,.05,.948,.002,2*0.,.002,.998,4*0.,1./
10768  DATA optx/1.,3*0./,opty/1.,3*0./,optq2/1.,3*0./,optw2/1.,3*0./
10769  DATA nxx,nww/20,15/
10770  DATA pqg,pqqb,qgmax,qqbmax/3000*0./,ycut/300*0./,xtot/300*0./
10771  DATA nfx,nfq/41,16/,flqt,flgt,flmt/1968*0./
10772  DATA xkin/1.,2.,3.,4./,ukin,wkin,ain,bin/16*0./,maxfin/2000/
10773  DATA relup,relerr,reler2/0.1,0.05,0.05/
10774  DATA namkin/' X',' ',' ',' '/
10775  DATA ipy/
10776  1 0, 0, 2, 2, 6, 1, 1, 6, 3, 1,
10777  2 3, 1, 1, 2, 1, 1, 4, 1, 1, 1,
10778  3 0, 1, 1, 1, 1, 1, 1, 0, 0, 0,
10779  4 1, 2, 1, 1, 30, 33, 1, 1, 7, 0,
10780  5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
10781  6 0, 0, 0, 1, 100, 0, 0, 0, 0, 0,
10782  7 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
10783  8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
10784  DATA (pypar(i),i=1,40)/
10785  1 7.299e-03, 2.290e-01, 2.000e-01, 2.500e-01, 4.000e+00,
10786  1 1.000e+00, 4.400e-01, 4.400e-01, 7.500e-02, 0.000e+00,
10787  2 2.000e+00, 2.000e+00, 1.000e+00, 0.000e+00, 3.000e+00,
10788  2 1.000e+00, 0.000e+00, 0.000e+00, 0.000e+00, 1.000e+00,
10789  3 2.500e-01, 1.000e+00, 2.000e+00, 1.000e-03, 1.000e+00,
10790  3 1.000e+00, 1.000e+00, -2.000e-02, -1.000e-02, 0.000e+00,
10791  4 0.000e+00, 1.600e+00, 0.500e+00, 0.200e+00, 3.894e-01,
10792  4 1.000e+00, 3.300e-01, 6.600e-01, 0.000e+00, 1.000e+00/
10793  DATA (pypar(i),i=41,80)/
10794  5 2.260e+00, 1.000e+04, 1.000e-04, 0.000e+00, 0.000e+00,
10795  5 0.000e+00, 0.000e+00, 0.000e+00, 0.000e+00, 0.000e+00,
10796  6 0.000e+00, 0.000e+00, 0.000e+00, 0.000e+00, 0.000e+00,
10797  6 0.000e+00, 0.000e+00, 0.000e+00, 0.000e+00, 0.000e+00,
10798  7 0.000e+00, 0.000e+00, 0.000e+00, 0.000e+00, 0.000e+00,
10799  7 0.000e+00, 0.000e+00, 0.000e+00, 0.000e+00, 0.000e+00,
10800  8 0.000e+00, 0.000e+00, 0.000e+00, 0.000e+00, 0.000e+00,
10801  8 0.000e+00, 0.000e+00, 0.000e+00, 0.000e+00, 0.000e+00/
10802  DATA pyvar/80*0./
10803  END
10804 *CMZ : 06/03/97 15.28.28 by Unknown
10805 *CMZ : 1.01/50 20/03/96 12.38.57 by Piero Zucchelli
10806 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
10807 *CMZ : 1.01/08 05/03/95 11.39.25 BY PIERO ZUCCHELLI
10808 *CMZ : 1.01/01 23/09/94 12.10.13 BY PIERO ZUCCHELLI
10809 *CMZ : 1.00/00 19/08/94 11.05.13 BY PIERO ZUCCHELLI
10810 *CMZ : 1.00/00 20/07/94 12.12.49 BY PIERO ZUCCHELLI
10811 *-- AUTHOR :
10812 C **********************************************************************
10813 
10814  SUBROUTINE leptox
10815 
10816 C...SELECT PROCESS AND CHOOSE KINEMATICAL VARIABLES (X,Y; X,Q2; X,W2)
10817 C...ACCORDING TO THE DIFFERENTIAL CROSS SECTION.
10818 
10819 *KEEP,JETTA.
10820 C--
10821  parameter(icento=100)
10822  parameter(isiz=93)
10823  parameter(iof1=32)
10824  parameter(iof2=83)
10825  parameter(lux_level=4)
10826  INTEGER*4 jtau(100),jpri(100),jstro(100)
10827  REAL*4 ftuple(isiz)
10828  common/jettagl/jtau,jpri,jstro
10829  common/ntupla/ftuple,isfirst
10830  common/beam/spec(icento)
10831  COMMON /maxspec/rmaxspec,rintspec
10832  common/sav/xminsav(icento),xmaxsav(icento),yminsav(icento),
10833  & ymaxsav(icento),q2minsav(icento),q2maxsav(icento),
10834  & w2minsav(icento),w2maxsav(icento),parimax(icento),
10835  & ppsave(icento,3,4,5),paricor(icento),index,sigmasav(icento),
10836  & xmsigma,xsect
10837 
10838 *KEND.
10839 
10840  COMMON /lintrl/ psave(3,4,5),ksave(4),xmin,xmax,ymin,ymax,
10841  +q2min,q2max,w2min,w2max,ilep,inu,ig,iz
10842  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
10843  COMMON /linter/ pari(40),ewqc(2,2,8),qc(8),zl(2,4),zq(2,8),pq(17)
10844  COMMON /loptim/ optx(4),opty(4),optq2(4),optw2(4),comfac
10845  COMMON /flinfo/ rflq,rflg,rflm,rflt
10846  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
10847  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
10848  common/wlist/ww1,ww2,ww3,ww5
10849  dimension pqh(17,2),pnt(2,2),xpq(-6:6)
10850  DOUBLE PRECISION dari27,dari28
10851  DATA dari27,dari28/2*0.d0/
10852  DATA w2low,w2upp,ylow,yupp,q2low,q2upp/6*0./
10853 
10854  w2low=0
10855  w2upp=0
10856  ylow=0
10857  yupp=0
10858  q2low=0
10859  q2upp=0
10860 
10861  DO 30 ih=1,2
10862  DO 10 i=1,2
10863  10 pnt(i,ih)=0.
10864  DO 20 i=1,8
10865  ewqc(1,ih,i)=0.
10866  20 ewqc(2,ih,i)=0.
10867  DO 30 i=1,17
10868  30 pqh(i,ih)=0.
10869  DO 40 i=1,17
10870  40 pq(i)=0.
10871 
10872  lst(21)=0
10873  ncut=0
10874  rml=p(4,5)
10875  ee=p(1,4)
10876  rmm=p(2,5)
10877  hel=lst(30)
10878 
10879  s=parl(21)+psave(3,1,5)**2+psave(3,2,5)**2
10880  pm2=psave(3,2,5)**2
10881  IF(lst(2).NE.1) THEN
10882 
10883 * NOT SO USEFUL AS I THOUGHT
10884  aaa=0.5
10885  bbb=0.5
10886  IF (parl(21).GT.0) THEN
10887  aaa= 0.5*(1.-rml**2/(parl(21)*x)-2.* (rml*rmm/parl(21))**2)
10888  + /(1.+x*rmm**2/parl(21))
10889  bbb=0.5*sqrt((1.-rml**2/(parl(21)*x))**2-(2.*rml*rmm/parl(21)
10890  + )**2) /(1.+x*rmm**2/parl(21))
10891  ELSE
10892  WRITE(*,*)'WARNING: 2PK==0'
10893  ENDIF
10894 
10895 * EE-RMM OR EE+RMM ? THIS IS THE QUESTION.....
10896 
10897  txlow=rml**2/2./rmm/(ee+rmm)
10898 
10899  q2low=max(q2min,x*ymin*s,(w2min-pm2)*x/max(1.-x,1.e-22))
10900  q2upp=min(q2max,x*ymax*s,(w2max-pm2)*x/max(1.-x,1.e-22))
10901  ylowcmp=max(ymin,q2min/max(s*x,1.e-22), (w2min-pm2)/max(s*(1.-
10902  + x),1.e-22))
10903  yuppcmp=min(ymax,q2max/max(s*x,1.e-22), (w2max-pm2)/max(s*(1.-
10904  + x),1.e-22))
10905  ylow=max(ymin,q2min/max(s*x,1.e-22), (w2min-pm2)/max(s*(1.-x),
10906  + 1.e-22))
10907  yupp=min(ymax,q2max/max(s*x,1.e-22), (w2max-pm2)/max(s*(1.-x),
10908  + 1.e-22))
10909 
10910 
10911 
10912  w2low=max(w2min,(1.-x)*ymin*s+pm2,q2min*(1.-x)/max(x,1.e-22)+
10913  + pm2)
10914  w2upp=min(w2max,(1.-x)*ymax*s+pm2,q2max*(1.-x)/max(x,1.e-22)+
10915  + pm2)
10916  goto 70
10917  ENDIF
10918 
10919  IF(pari(28).LT.0.5) THEN
10920 C...FOR FIRST CALL, RESET DOUBLE PRECISION COUNTERS.
10921  dari27=0.d0
10922  dari28=0.d0
10923  ENDIF
10924  50 dari28=dari28+1.d0
10925  pari(28)=dari28
10926  60 CONTINUE
10927 * WRITE(*,*)'OPTX=',OPTX
10928 * WRITE(*,*)'OPTY=',OPTY
10929 C...CHOOSE X ACCORDING TO THE DISTRIBUTION
10930 C...HX(X) = A + B/X + C/X**2 + D/X**3. IN DETAIL
10931 C...HQ=OPTX(1)/(XMAX-XMIN) + 1/LN(XMAX/XMIN)*OPTX(2)/X
10932 C... +XMIN*XMAX/(XMAX-XMIN)*OPTX(3)/X**2
10933 C... +2*(XMIN*XMAX)**2/(XMAX**2-XMIN**2)*OPTX(4)/X**3
10934  which=(optx(1)+optx(2)+optx(3)+optx(4))*rlu(0)
10935  IF(which.LE.optx(1)) THEN
10936  x=xmin+rlu(0)*(xmax-xmin)
10937  ELSEIF(which.LE.(optx(1)+optx(2))) THEN
10938  x=xmin*(xmax/xmin)**rlu(0)
10939  ELSEIF(which.LE.(optx(1)+optx(2)+optx(3))) THEN
10940  x=xmin*xmax/(xmax+rlu(0)*(xmin-xmax))
10941  ELSE
10942  x=sqrt((xmin*xmax)**2/(xmax**2+rlu(0)*(xmin**2-xmax**2)))
10943  ENDIF
10944  IF(lst(31).EQ.1) THEN
10945 C...CHOOSE Q**2 ACCORDING TO THE DISTRIBUTION
10946 C...HQ(Q2) = A + B/(Q2) + C/(Q2)**2 + D/(Q2)**3. IN DETAIL
10947 C...HQ=OPTQ2(1)/(Q2MAX-Q2MIN) + 1/LN(Q2MAX/Q2MIN)*OPTQ2(2)/Q2
10948 C... +Q2MIN*Q2MAX/(Q2MAX-Q2MIN)*OPTQ2(3)/Q2**2
10949 C... +2*(Q2MIN*Q2MAX)**2/(Q2MAX**2-Q2MIN**2)*OPTQ2(4)/Q2**3
10950  q2low=max(q2min,x*ymin*s,(w2min-pm2)*x/(1.-x))
10951  q2upp=min(q2max,x*ymax*s,(w2max-pm2)*x/(1.-x))
10952  IF(q2upp.LT.q2low) goto 60
10953  which=(optq2(1)+optq2(2)+optq2(3)+optq2(4))*rlu(0)
10954  IF(which.LE.optq2(1)) THEN
10955  q2=q2low+rlu(0)*(q2upp-q2low)
10956  ELSEIF(which.LE.(optq2(1)+optq2(2))) THEN
10957  q2=q2low*(q2upp/q2low)**rlu(0)
10958  ELSEIF(which.LE.(optq2(1)+optq2(2)+optq2(3))) THEN
10959  q2=q2low*q2upp/(q2upp+rlu(0)*(q2low-q2upp))
10960  ELSE
10961  q2=sqrt((q2low*q2upp)**2/(q2upp**2+rlu(0)*(q2low**2-q2upp**2)
10962  + ))
10963  ENDIF
10964  y=q2/(parl(21)*x)
10965  IF(y.LT.ymin.OR.y.GT.ymax) goto 50
10966  ELSEIF(lst(31).EQ.2) THEN
10967 C...CHOOSE Y ACCORDING TO THE DISTRIBUTION
10968 C...HY(Y) = A + B/Y + C/Y**2 + D/Y**3. IN DETAIL
10969 C...HY=OPTY(1)/(YMAX-YMIN) + 1/LN(YMAX/YMIN)*OPTY(2)/Y
10970 C... +YMIN*YMAX/(YMAX-YMIN)*OPTY(3)/Y**2
10971 C... +2*(YMIN*YMAX)**2/(YMAX**2-YMIN**2)*OPTY(4)/Y**3
10972  ylow=max(ymin,q2min/(s*x),(w2min-pm2)/(s*(1.-x)))
10973  yupp=min(ymax,q2max/(s*x),(w2max-pm2)/(s*(1.-x)))
10974  IF(yupp.LT.ylow) goto 60
10975  which=(opty(1)+opty(2)+opty(3)+opty(4))*rlu(0)
10976  IF(which.LE.opty(1)) THEN
10977  y=ylow+rlu(0)*(yupp-ylow)
10978  ELSEIF(which.LE.(opty(1)+opty(2))) THEN
10979  y=ylow*(yupp/ylow)**rlu(0)
10980  ELSEIF(which.LE.(opty(1)+opty(2)+opty(3))) THEN
10981  y=ylow*yupp/(yupp+rlu(0)*(yupp-ylow))
10982  ELSE
10983  y=sqrt((ylow*yupp)**2/(yupp**2+rlu(0)*(ylow**2-yupp**2)))
10984  ENDIF
10985  q2=x*y*parl(21)
10986  IF(q2.LT.q2min.OR.q2.GT.q2max) goto 50
10987  ELSEIF(lst(31).EQ.3) THEN
10988 C...CHOOSE W**2 ACCORDING TO THE DISTRIBUTION
10989 C...HW(W2) = A + B/(W2) + C/(W2)**2 + D/(W2)**3. IN DETAIL
10990 C...HW=OPTW2(1)/(W2MAX-W2MIN) + 1/LN(W2MAX/W2MIN)*OPTW2(2)/W2
10991 C... +W2MIN*W2MAX/(W2MAX-W2MIN)*OPTW2(3)/W2**2
10992 C... +2*(W2MIN*W2MAX)**2/(W2MAX**2-W2MIN**2)*OPTW2(4)/W2**3
10993  w2low=max(w2min,(1.-x)*ymin*s+pm2,q2min*(1.-x)/x+pm2)
10994  w2upp=min(w2max,(1.-x)*ymax*s+pm2,q2max*(1.-x)/x+pm2)
10995  IF(w2upp.LT.w2low) goto 60
10996  which=(optw2(1)+optw2(2)+optw2(3)+optw2(4))*rlu(0)
10997  IF(which.LE.optw2(1)) THEN
10998  w2=w2low+rlu(0)*(w2upp-w2low)
10999  ELSEIF(which.LE.(optw2(1)+optw2(2))) THEN
11000  w2=w2low*(w2upp/w2low)**rlu(0)
11001  ELSEIF(which.LE.(optw2(1)+optw2(2)+optw2(3))) THEN
11002  w2=w2low*w2upp/(w2upp+rlu(0)*(w2low-w2upp))
11003  ELSE
11004  w2=sqrt((w2low*w2upp)**2/(w2upp**2+rlu(0)*(w2low**2-w2upp**2)
11005  + ))
11006  ENDIF
11007  y=(w2-p(2,5)**2)/((1.-x)*parl(21))
11008  q2=x*y*parl(21)
11009  IF(y.LT.ymin.OR.y.GT.ymax) goto 50
11010  IF(q2.LT.q2min.OR.q2.GT.q2max) goto 50
11011  ENDIF
11012 c write(*,*) x,y
11013 
11014  aa=lkinem(lst(2))
11015 c write(*,*) aa,lst(2)
11016  70 IF(lkinem(lst(2)).NE.0) THEN
11017  ncut=ncut+1
11018  IF(lst(2).EQ.1) THEN
11019  IF(ncut.LE.9999) goto 50
11020  IF(lst(3).GE.1) then
11021  do kk=1,14
11022 c write(*,*) kk,cut(kk)
11023  end do
11024 c write(*,*) lst(11), lst(12),lst(13),lst(14)
11025 c print*,'yes here'
11026  WRITE(6,10000)
11027  end if
11028  ENDIF
11029  lst(21)=1
11030  RETURN
11031  ENDIF
11032 
11033 c print*,' survived in leptox'
11034  pari(24)=(1.+(1.-y)**2)/2.
11035  pari(25)=1.-y
11036  pari(26)=(1.-(1.-y)**2)/2.
11037  CALL lnstrf(x,q2,xpq)
11038 C...LEPTON HELICITY STATE, ONLY ONE CONTRIBUTES IN SOME CASES.
11039  ih=1
11040  IF(parl(6).GT.+0.99) ih=2
11041  80 lst(30)=sign(1.,ih-1.5)
11042  pqh(17,ih)=0.
11043  pnt(1,ih)=0.
11044  pnt(2,ih)=0.
11045  IF(lst(23).EQ.2) THEN
11046 C...CHARGED CURRENT: ZERO CROSS-SECTION FOR ONE HELICITY STATE.
11047  IF(ksave(1).LT.0.AND.ih.EQ.1
11048  + .OR.ksave(1).GT.0.AND.ih.EQ.2) goto 110
11049 *LST(30)=- O +1 A SECONDA DI HELICITA' LEFT/RIGHT
11050  yq=pari(24)-lst(30)*pari(26)
11051  yqb=pari(24)+lst(30)*pari(26)
11052  IF(pari(11).GT.1.e-06) THEN
11053  IF(k(3,2).LT.0) THEN
11054  pnt(1,ih)=(1.-pari(11))*pari(13)*yq
11055  pnt(2,ih)=pari(11)*pari(12)*yq
11056  ELSE
11057  pnt(1,ih)=(1.-pari(11))*pari(12)*yq
11058  pnt(2,ih)=pari(11)*pari(13)*yq
11059  ENDIF
11060  ENDIF
11061  DO 90 i=1,lst(12)
11062  IF(k(3,2)*qc(i).LT.0) THEN
11063  pqh(i,ih)=xpq(i)*yq
11064  ELSE
11065  pqh(i+lst(12),ih)=xpq(-i)*yqb
11066  ENDIF
11067  90 CONTINUE
11068  ELSE
11069 C...NEUTRAL CURRENT: ELECTROMAGNETIC OR WEAK OR BOTH WITH INTERFERENCE.
11070  gfq2=q2/(pmas(23,1)**2+q2)*sqrt(2.)*parl(17)*pmas(23,1)**2/
11071  + (3.1415927*parl(16))
11072 C...CORRECTION TO OBTAIN Q**2 DEPENDENT ALPHA-EM, IF DESIRED.
11073  aemcor=1.
11074  IF(lst(18).GE.2) aemcor=ulalem(q2)/parl(16)
11075  ii=3-ih
11076  zlep=zl(ih,ilep+2*inu)
11077  DO 100 i=1,max(lst(12),lst(13))
11078  a=(-ig*qc(i)*aemcor+iz*gfq2*zlep*zq(ih,i))**2
11079  b=(-ig*qc(i)*aemcor+iz*gfq2*zlep*zq(ii,i))**2
11080 C...SAVE HELICITY-DEPENDENT ELECTROWEAK QUARK COUPLINGS FOR LATER USE.
11081  ewqc(1,ih,i)=a
11082  ewqc(2,ih,i)=b
11083  IF(i.GT.lst(12)) goto 100
11084  fyq=(a+b)*pari(24)+(a-b)*pari(26)
11085  pqh(i,ih)=xpq(i)*fyq
11086  IF(i.LE.2.AND.pari(11).GT.1.e-06) THEN
11087  pnt(1,ih)=pnt(1,ih)+(1.-pari(11))*pari(11+i)*fyq
11088  pnt(2,ih)=pnt(2,ih)+pari(11)*pari(14-i)*fyq
11089  ENDIF
11090  pqh(i+lst(12),ih)=xpq(-i)*((a+b)*pari(24)-(a-b)*pari(26))
11091  100 CONTINUE
11092  ENDIF
11093  110 CONTINUE
11094  DO 120 i=1,lst(12)
11095  120 pqh(17,ih)=pqh(17,ih)+pqh(i,ih)+pqh(i+lst(12),ih)
11096 
11097  IF(abs(parl(6)).LT.0.99.AND.ih.EQ.1) THEN
11098  ih=2
11099  goto 80
11100  ENDIF
11101 
11102  IF (lst(32).NE.0.AND.lst(23).EQ.2) THEN
11103 
11104  f1=0.
11105  f5=0.
11106  f2cc=0.
11107  f3cc=0.
11108 * D U~ S C~
11109  f2cc=xpq(1)+xpq(-2)+xpq(3)+xpq(-4)
11110  f3cc=(xpq(1)-xpq(-2)+xpq(3)-xpq(-4))/x
11111 
11112 
11113 
11114  IF(x.NE.0) THEN
11115  f5=f2cc/x
11116  f1=f2cc*0.5/x
11117  ELSE
11118  WRITE(*,*)'WARNING:X==0'
11119  ENDIF
11120 
11121 * NOW CALCULATE FULL CROS SECTION, EXCEPT
11122 * FOR COMFAC AND PARL(19) FACTORS
11123 * KEEPING IN ACCOUNT BOTH NUCLEON AND LEPTON MASS
11124 
11125  rml=p(4,5)
11126  ee=p(1,4)
11127  rmm=p(2,5)
11128  hel=lst(30)
11129 
11130 
11131  a1=( x*y + rml**2 /parl(21) ) *y
11132  a2=(1.-y)- ( rmm**2*x*y/parl(21) + (rml*rmm/parl(21))**2 )
11133  a3=( x*y*(1.-y/2.) - rml**2/(2.*parl(21))*y )
11134  a5=-rml**2/parl(21)
11135 
11136 
11137  rml=0.
11138  rmm=0.0000001
11139 
11140  c1=( x*y + rml**2 /parl(21) ) *y
11141  c2=(1.-y)- ( rmm**2*x*y/parl(21) + (rml*rmm/parl(21))**2 )
11142  c3=( x*y*(1.-y/2.) - rml**2/(2.*parl(21))*y )
11143  c5=-rml**2/parl(21)
11144 
11145 
11146 
11147 
11148 
11149 * WRITE(*,*)'A1,A2,A3,A5=',A1,A2,A3,A5
11150 
11151  pp=a1*f1+a2*f2cc+a3*f3cc+a5*f5
11152  pppp=c1*f1+c2*f2cc+c3*f3cc+c5*f5
11153  ppp=a1*f1+a2*f2cc+a3*f3cc
11154  p17=(1.-parl(6))/2.*pqh(17,1)+(1.+parl(6))/2.*pqh(17,2)
11155 
11156 
11157  p17ok=(1.-parl(6))/2.*pppp+(1.+parl(6))/2.*pqh(17,2)
11158  IF( abs(p17ok-p17).GT.0.00005) THEN
11159  WRITE(*,*)'TAU LEPTON X-SECTION WRONG',p17ok,p17
11160  ENDIF
11161 
11162  IF(pp.LT.0.) pp=0.
11163 * BY HAND, BUT A GOOD THING IS TO CHECKIT...
11164 
11165  IF(x.LT.txlow) pp=0.
11166 
11167 
11168 * NOW W CALCULATIONS FOR TAU POLARIZATION
11169 
11170  rmm=p(2,5)
11171  ww1=f2cc*(1./u+0.5/x/rmm)
11172  ww2=f2cc/u
11173  ww3=-f2cc/u/x*sqrt(1+ (q2/u)**2 )
11174  ww5=f2cc/x/u
11175 * WRITE(*,*)'W1,W2,W3,W5=',WW1,WW2,WW3,WW5
11176 
11177 * WRITE(*,*)'3F=',PPP,' 5F=',PP,' STD=',P17OK,' P17=',P17
11178 * WRITE(*,*)'Y=',Y,' 5F=',PP,' X=',X,' P17=',P17
11179 * CRUCIAL!!!
11180 * HERE STAYS THE FINAL JUMP INTO THE DARKNESS.....
11181 
11182  pqh(17,1)=pp
11183 
11184 
11185  ENDIF
11186 
11187 
11188  flq=0.
11189  flg=0.
11190  flm=0.
11191  flt=0.
11192  IF(lst(23).EQ.1.AND.lst(11).NE.0.AND.lst(2).NE.-3) THEN
11193 C-CHECK: IF(LST(23).EQ.1.AND.LST(11).NE.0) THEN
11194  lqcd=mod(lst(11),10)
11195  ltm=mod(lst(11)/10,10)
11196  lht=lst(11)/100
11197 C...INCLUDE QCD, TARGET MASS AND/OR HIGHER TWIST CONTR. TO LONG. STR FCN
11198 C...FL FROM INTERPOLATION.
11199  IF(lqcd.EQ.1.OR.ltm.EQ.1) CALL flipol(flq,flg,flm)
11200 C...EVENT SIMULATION: IF REQUESTED, GET FL BY EVENT-BY-EVENT INTEGRATION
11201  IF(lst(2).GT.0.AND.
11202  + (lqcd.EQ.2.OR.ltm.EQ.2)) CALL flintg(flq,flg,flm)
11203  IF(ltm.GE.1.OR.lht.GE.1) THEN
11204  f2em=0.
11205  DO 130 i=1,lst(12)
11206  130 f2em=f2em+qc(i)**2*(xpq(i)+xpq(-i))
11207  IF(ltm.GE.1) flm=flm-2.*x**2*psave(3,2,5)**2/q2*f2em
11208  IF(lht.GE.1) flt=8.*parl(19)/q2*f2em
11209  ENDIF
11210  DO 140 ih=1,2
11211  pqh17=pqh(17,ih)
11212 C...NOTE FACTOR 2 AT THE END, SINCE PQH(IH,17) CONTAINS OVERALL FACTOR 2
11213  pqh(17,ih)=pqh(17,ih)-y**2*(flq+flg+flm+flt)
11214  DO 140 i=1,16
11215  140 pqh(i,ih)=pqh(i,ih)*pqh(17,ih)/pqh17
11216  ENDIF
11217 
11218  DO 150 i=1,17
11219  150 pq(i)=(1.-parl(6))/2.*pqh(i,1)+(1.+parl(6))/2.*pqh(i,2)
11220 
11221 C...RELATIVE CONTRIBUTION FROM LONGITUDINAL STR. FCN. AND HIGHER TWIST.
11222  rflq=-y**2*flq/pq(17)
11223  rflg=-y**2*flg/pq(17)
11224  rflm=-y**2*flm/pq(17)
11225  rflt=-y**2*flt/pq(17)
11226 
11227 C...COMMON FACTOR FOR MATRIX ELEMENTS.
11228  IF(lst(31).EQ.1) THEN
11229  IF(lst(23).EQ.2) THEN
11230  comfac=1./x/(1.+q2/pmas(24,1)**2)**2
11231  ELSE
11232  comfac=1./x/q2**2
11233  ENDIF
11234  ELSEIF(lst(31).EQ.2) THEN
11235  IF(lst(23).EQ.2) THEN
11236  comfac=1./(1.+q2/pmas(24,1)**2)**2*parl(21)
11237  ELSE
11238  comfac=1./q2**2*parl(21)
11239  ENDIF
11240  ELSEIF(lst(31).EQ.3) THEN
11241  IF(lst(23).EQ.2) THEN
11242  comfac=1./x/(1.+q2/pmas(24,1)**2)**2 * x/(1.-x)
11243  ELSE
11244  comfac=1./x/q2**2 * x/(1.-x)
11245  ENDIF
11246  ENDIF
11247 C-CHECK: MOVE CHANGE OF COMFAC TO BELOW??
11248 C...PREPARE FOR Q2 WEIGHTING.
11249 C WEIGHT=1/Q2**2
11250  weight=1.d0
11251  comfac=comfac/weight
11252 
11253 c print*,'before cec lst(2)'
11254  IF(lst(2).LE.-2) RETURN
11255 c print*,' after'
11256  hx=optx(1)/(xmax-xmin) + 1./alog(xmax/xmin)*optx(2)/x
11257  ++xmin*xmax/(xmax-xmin)*optx(3)/x**2
11258  ++2*(xmin*xmax)**2/(xmax**2-xmin**2)*optx(4)/x**3
11259  xfact=optx(1)+optx(2)+optx(3)+optx(4)
11260  IF(lst(31).EQ.1) THEN
11261  hq2=optq2(1)/(q2upp-q2low)
11262  + +1./alog(q2upp/q2low)*optq2(2)/q2
11263  + +q2low*q2upp/(q2upp-q2low)*optq2(3)/q2**2
11264  + +2*(q2low*q2upp)**2/(q2upp**2-q2low**2)*optq2(4)/q2**3
11265  q2fact=optq2(1)+optq2(2)+optq2(3)+optq2(4)
11266  comfac=comfac*xfact*q2fact/hx/hq2
11267  ELSEIF(lst(31).EQ.2) THEN
11268  hy=opty(1)/(yupp-ylow)+1./alog(yupp/ylow)*opty(2)/y
11269  + +ylow*yupp/(yupp-ylow)*opty(3)/y**2
11270  + +2*(ylow*yupp)**2/(yupp**2-ylow**2)*opty(4)/y**3
11271  yfact=opty(1)+opty(2)+opty(3)+opty(4)
11272  comfac=comfac*xfact*yfact/hx/hy
11273  ELSEIF(lst(31).EQ.3) THEN
11274  hw2=optw2(1)/(w2upp-w2low)
11275  + +1./alog(w2upp/w2low)*optw2(2)/w2
11276  + +w2low*w2upp/(w2upp-w2low)*optw2(3)/w2**2
11277  + +2*(w2low*w2upp)**2/(w2upp**2-w2low**2)*optw2(4)/w2**3
11278  w2fact=optw2(1)+optw2(2)+optw2(3)+optw2(4)
11279  comfac=comfac*xfact*w2fact/hx/hw2
11280  ENDIF
11281  IF(lst(2).LE.0) RETURN
11282 
11283 C-CHECK: MOVE CHANGE OF COMFAC TO HERE?
11284  sigl=(1.-parl(6))/2.*pqh(17,1)
11285  sigr=(1.+parl(6))/2.*pqh(17,2)
11286  sigma=sigl+sigr
11287  IF(lst(2).EQ.1) THEN
11288 C...WHEN CHOSING (X,Y), REJECT ACCORDING TO MAXIMUM OF "CROSS-SECTION",
11289 C...UPDATE CROSS-SECTION ESTIMATE.
11290  dari27=dari27+dble(sigma)*dble(comfac)*weight
11291  pari(27)=dari27
11292  viol=sigma*comfac/pari(lst(23))
11293  IF(viol.GT.pari(32)) THEN
11294  pari(32)=viol
11295  IF(pari(32).GT.1.) THEN
11296  pari(lst(23))=pari(lst(23))*pari(32)
11297  IF(lst(3).GE.1) WRITE(6,10100) pari(32),int(pari(30)+1),
11298  + pari(lst(23)),x,y,q2,w2
11299  pari(32)=1.
11300  ENDIF
11301  ENDIF
11302  IF(viol.LT.rlu(0)) goto 50
11303  parl(24)=pari(31)*dari27/dari28
11304  ENDIF
11305 
11306  IF(abs(parl(6)).LT.0.99) THEN
11307 C...CHOOSE HELICITY OF INCOMING LEPTON.
11308  ih=1
11309  IF(rlu(0)*sigma.GT.sigl) ih=2
11310  ENDIF
11311  lst(30)=sign(1.,ih-1.5)
11312 
11313 C...CHOOSE TARGET NUCLEON, PROTON OR NEUTRON.
11314  lst(22)=1
11315  k(2,2)=2212
11316  IF(pari(11).GT.1.e-06) THEN
11317  IF(rlu(0).LT.(pari(11)*(pqh(17,ih)-pnt(1,ih)-pnt(2,ih))+
11318  + pnt(2,ih))/pqh(17,ih)) THEN
11319  lst(22)=2
11320  k(2,2)=2112
11321  ENDIF
11322  ENDIF
11323  rcross=pari(31)*pq(17)*comfac
11324  ftuple(1)=rcross
11325  ftuple(2)=x
11326  ftuple(3)=y
11327 
11328 c print*,' end of leptox'
11329 
11330  RETURN
11331 10000 FORMAT(' WARNING: LEPTOX IS LOOPING, CANNOT FIND ALLOWED ',
11332  +'PHASE SPACE POINT DUE TO CUTS,',/,
11333  +10x,'CHECK, IN PARTICULAR, CUT(11) TO CUT(14)')
11334 10100 FORMAT(' WARNING: MAXIMUM VIOLATED BY A FACTOR ',f7.3,
11335  +' IN EVENT ',i7,/,' MAXIMUM INCREASED BY THIS FACTOR TO ',e12.3,
11336  +/,' POINT OF VIOLATION: X, Y, Q**2, W**2 = ',4g10.3)
11337  END
11338 *CMZ : 1.01/50 29/02/96 12.09.02 by Piero Zucchelli
11339 *CMZ : 1.01/45 08/01/96 11.11.52 by Piero Zucchelli
11340 *CMZ : 1.01/43 15/12/95 18.01.11 by Piero Zucchelli
11341 *CMZ : 1.01/41 12/12/95 16.06.05 by Piero Zucchelli
11342 *CMZ : 1.01/40 08/12/95 16.56.00 by Piero Zucchelli
11343 *CMZ : 1.01/36 26/07/95 17.35.22 BY PIERO ZUCCHELLI
11344 *CMZ : 1.01/30 02/06/95 19.54.53 BY PIERO ZUCCHELLI
11345 *CMZ : 1.01/29 02/06/95 19.51.39 BY PIERO ZUCCHELLI
11346 *CMZ : 1.01/28 02/06/95 18.17.14 BY PIERO ZUCCHELLI
11347 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
11348 *CMZ : 1.01/08 05/03/95 11.39.25 BY PIERO ZUCCHELLI
11349 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
11350 *-- AUTHOR :
11351 C **********************************************************************
11352 
11353  SUBROUTINE lflav(IFL,IFLR)
11354 *KEEP,KEYS.
11355  common/cfread/space(5000)
11356  common/mykeys/ievar,if5cc,ineut,iinte,iferm,iflat,icoun,
11357  & refix,imudo,ikat1,ikat2,ikat3,ikat4,ikat5,ikat6,
11358  & inevt,ijak1,ijak2,iitdk,rptau,rxk0d,ntgr,idimuon,iglu,
11359  & iqden,lome(2),ifiles,iccha,iseed,idsubs,ionem,ehac,ipsel,
11360  & ihist
11361 
11362 
11363 *KEEP,PERROR.
11364 *-- AUTHOR : PIERO ZUCCHELLI 01/09/94
11365  parameter(charmsens=10000)
11366  common/myerr/icrack
11367 
11368 
11369 *KEND.
11370 C...CHOOSE FLAVOUR OF STRUCK QUARK AND THE
11371 C...CORRESPONDING FLAVOUR OF THE TARGET REMNANT JET.
11372 
11373  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
11374  COMMON /linter/ pari(40),ewqc(2,2,8),qc(8),zl(2,4),zq(2,8),pq(17)
11375  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
11376  COMMON /lflmix/ cabibo(4,4)
11377 
11378  lst(21)=0
11379  IF(lst(24).EQ.3) THEN
11380  nfl=lst(13)
11381  ELSE
11382  nfl=lst(12)
11383  ENDIF
11384 
11385  imaxdimu=charmsens
11386 
11387  10 r=rlu(0)*pq(17)
11388  psub=0.
11389  DO 20 i=1,2*nfl
11390  ifl=i
11391  psub=psub+pq(i)
11392  IF(r.LE.psub) goto 30
11393  20 CONTINUE
11394  30 CONTINUE
11395  IF(ifl.GT.nfl) ifl=nfl-ifl
11396  lst(25)=ifl
11397  iflr=-ifl
11398 
11399  IF(lst(23).EQ.2) THEN
11400 C...WEAK CHARGED CURRENT, CHANGE THE FLAVOUR OF THE STRUCK
11401 C...QUARK USING GENERALIZED CABIBBO MIXING MATRIX.
11402  ifla=iabs(ifl)
11403  j1=(ifla+1)/2
11404  m1=mod(ifla,2)
11405  m2=mod(ifla+1,2)
11406  r=rlu(0)
11407  psub=0.
11408  DO 40 j=1,4
11409  j2=j
11410  psub=psub+cabibo(m1*j2+m2*j1,m2*j2+m1*j1)
11411  IF(r.LT.psub) goto 50
11412  40 CONTINUE
11413  50 ifl=2*j2-m2
11414  IF(lst(25).LT.0) ifl=-ifl
11415  ENDIF
11416 
11417  ifla=iabs(ifl)
11418  iflra=iabs(iflr)
11419 
11420 * PIEROZ PATCH FOR DIMUONS
11421  IF (idimuon.GE.1.AND.imaxdimu.EQ.0) THEN
11422  WRITE(*,*)'SKIPPING CHARM PRODUCTION: CRACK ALARM'
11423  icrack=1
11424  goto 3434
11425 * THIS IS PROGRAMMING!!!
11426  ENDIF
11427  IF (idimuon.GE.1.AND.ifla.NE.4) THEN
11428  rsmall=rndmm(iseed)
11429  IF (rsmall.GT.0.05) goto 10
11430  ENDIF
11431  IF(ifla.GE.4.OR.iflra.GE.4) THEN
11432 C...THRESHOLD FUNCTION FOR HEAVY QUARKS OF FLAVOUR IFLA AND IFLRA.
11433  IF(1.-(.938+pmas(lucomp(ifla),1)+pmas(lucomp(iflra),1)
11434  + +2.*pmas(1,1))**2/w2.LT.rlu(0)) THEN
11435  imaxdimu=imaxdimu-1
11436  goto(10,60 ,60 ) lst(24)
11437  ENDIF
11438  ENDIF
11439 
11440  3434 CONTINUE
11441 C...REMNANT FLAVOUR TAKEN CARE OF LATER FOR QQBAR EVENT AND ME+PS CASE
11442  IF(lst(24).EQ.3) RETURN
11443  IF(lst(8).GT.10.AND.lst(8).NE.19) RETURN
11444 
11445 C...WITH LST(14)=0/1(DEFAULT) BARYON PRODUCTION FROM THE TARGET REMNANT
11446 C...IS EXCLUDED/INCLUDED.
11447  IF(lst(14).EQ.0) RETURN
11448  IF(iflr.EQ.-2) THEN
11449  IF(lst(22).EQ.1) THEN
11450  iflr=2101
11451  IF(rlu(0).GT.parl(4)) iflr=2103
11452  ELSE
11453  iflr=1103
11454  ENDIF
11455  ELSEIF(iflr.EQ.-1) THEN
11456  IF(lst(22).EQ.1) THEN
11457  iflr=2203
11458  ELSE
11459  iflr=2101
11460  IF(rlu(0).GT.parl(4)) iflr=2103
11461  ENDIF
11462  ENDIF
11463  RETURN
11464 
11465  60 lst(21)=1
11466  RETURN
11467  END
11468 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
11469 *CMZ : 1.01/08 05/03/95 11.39.25 BY PIERO ZUCCHELLI
11470 *CMZ : 1.00/00 24/07/94 16.02.59 BY PIERO ZUCCHELLI
11471 *CMZ : 1.00/00 19/07/94 17.08.36 BY PIERO ZUCCHELLI
11472 *-- AUTHOR :
11473 C **********************************************************************
11474 
11475  SUBROUTINE lframe(IFR,IPH)
11476 
11477 C...MAKE TRANSFORMATION FROM HADRONIC CM FRAME TO LAB FRAME.
11478 
11479  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
11480  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
11481  COMMON /linter/ pari(40),ewqc(2,2,8),qc(8),zl(2,4),zq(2,8),pq(17)
11482  COMMON /lintrl/ psave(3,4,5),ksave(4),xmin,xmax,ymin,ymax,
11483  +q2min,q2max,w2min,w2max,ilep,inu,ig,iz
11484  COMMON /lboost/ dbeta(2,3),stheta(2),sphi(2),pb(5),phir
11485 *KEEP,POLAR.
11486 C--
11487  COMMON /polariz/pol(4000,3)
11488  REAL polarx(4)
11489 *KEND.
11490  DOUBLE PRECISION dtheta,dphi,dbeta,dbetadbg(3)
11491  INTEGER ifr,iph,iframe,iphi
11492 
11493 * WRITE(*,*)'ENTER IFR,PHI,LST28,LST29',IFR,IPH,LST(28),LST(29)
11494 
11495  iframe=ifr
11496  iphi=iph
11497  IF(iframe.LT.1.OR.iframe.GT.4.OR.iphi.LT.0.OR.iphi.GT.1)
11498  +goto 100
11499  IF(iframe.EQ.1) iphi=0
11500  n=n+1
11501  DO 10 j=1,5
11502  10 p(n,j)=pb(j)
11503 
11504  20 CONTINUE
11505  IF(iphi.NE.lst(29)) THEN
11506  iframe=2
11507  ELSE
11508  iframe=ifr
11509  ENDIF
11510  IF((iframe.EQ.lst(28)).AND.(iphi.EQ.lst(29))) THEN
11511  DO 30 j=1,5
11512  30 pb(j)=p(n,j)
11513  n=n-1
11514  RETURN
11515  ENDIF
11516 
11517 * WRITE(*,*)'IFR,PHI,LST28,LST29,LST6',
11518 * &IFRAME,IPHI,LST(28),LST(29),LST(6)
11519  goto(40 ,50 ,70 ,90 ), lst(28)
11520  goto 100
11521 
11522  40 IF(iframe.GE.2) THEN
11523  CALL ludbrb(0,0,stheta(2),sphi(2),0.d0,0.d0,0.d0)
11524 
11525  CALL ludbrb(0,0,0.,0.,dbeta(2,1),dbeta(2,2),dbeta(2,3))
11526  lst(28)=2
11527  ELSE
11528  goto 100
11529  ENDIF
11530  goto 20
11531 
11532  50 IF(lst(6).NE.0.AND.iphi.NE.lst(29)) THEN
11533  CALL ludbrb(0,0,0.,sign(phir,float(iphi-lst(29))),0.d0,0.d0,
11534  + 0.d0)
11535  lst(29)=iphi
11536  ENDIF
11537 
11538  IF(iframe.EQ.1) THEN
11539  CALL ludbrb(0,0,0.,0.,-dbeta(2,1),-dbeta(2,2),-dbeta(2,3))
11540  CALL ludbrb(0,0,-stheta(2),0.,0.d0,0.d0,0.d0)
11541  lst(28)=1
11542  ELSEIF(iframe.GE.3) THEN
11543  IF(lst(17).EQ.0) THEN
11544  CALL ludbrb(0,0,0.,0.,0.d0,0.d0,dbeta(1,3))
11545  IF(psave(3,1,3).LT.0.) THEN
11546  DO 60 i=1,n
11547  60 p(i,3)=-p(i,3)
11548  ENDIF
11549  ELSE
11550  IF(dbeta(1,3).EQ.0) THEN
11551  DO j=1,3
11552  dbetadbg(j)= (dble(psave(3,1,j))+dble(psave(3,2,j)))/
11553  + (dble(psave(3,1,4))+dble(psave(3,2,4)))
11554  END DO
11555  CALL ludbrb(0,0,stheta(1),sphi(1),0.d0,0.d0,0.d0)
11556  CALL ludbrb(0,0,0.,0.,dbetadbg(1),dbetadbg(2),dbetadbg(3))
11557  ELSE
11558  CALL ludbrb(0,0,stheta(1),sphi(1),0.d0,0.d0,0.d0)
11559  CALL ludbrb(0,0,0.,0.,dbeta(1,1),dbeta(1,2),dbeta(1,3))
11560  ENDIF
11561  ENDIF
11562  lst(28)=3
11563  ENDIF
11564  goto 20
11565 
11566  70 IF(iframe.LE.2) THEN
11567  IF(lst(17).EQ.0) THEN
11568  IF(psave(3,1,3).LT.0.) THEN
11569  DO 80 i=1,n
11570  80 p(i,3)=-p(i,3)
11571  ENDIF
11572  CALL ludbrb(0,0,0.,0.,0.d0,0.d0,-dbeta(1,3))
11573  ELSE
11574  CALL ludbrb(0,0,0.,0.,-dbeta(1,1),-dbeta(1,2),-dbeta(1,3))
11575  CALL ludbrb(0,0,0.,-sphi(1),0.d0,0.d0,0.d0)
11576  CALL ludbrb(0,0,-stheta(1),0.,0.d0,0.d0,0.d0)
11577  ENDIF
11578  lst(28)=2
11579  ELSEIF(iframe.EQ.4) THEN
11580  thebos=plu(n,13)
11581  phibos=plu(n,15)
11582  CALL ludbrb(0,0,0.,-phibos,0.d0,0.d0,0.d0)
11583  CALL ludbrb(0,0,-thebos,0.,0.d0,0.d0,0.d0)
11584  lst(28)=4
11585  ENDIF
11586  goto 20
11587 
11588  90 IF(iframe.LE.3) THEN
11589  CALL ludbrb(0,0,thebos,phibos,0.d0,0.d0,0.d0)
11590  lst(28)=3
11591  ENDIF
11592  goto 20
11593 
11594  100 WRITE(*,10000) iframe,iphi,lst(28),lst(29)
11595 10000 FORMAT(' BAD VARIABLES IN SUBROUTINE LFRAME: IFRAME,IPHI,',
11596  +'LST(28),LST(29) =',4i5)
11597  RETURN
11598  END
11599 *CMZ : 1.01/40 11/12/95 19.19.33 by Piero Zucchelli
11600 *CMZ : 1.01/39 19/10/95 11.02.39 by Piero Zucchelli
11601 *CMZ : 1.01/16 14/05/95 11.46.23 BY PIERO ZUCCHELLI
11602 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
11603 *CMZ : 1.01/08 05/03/95 11.39.25 BY PIERO ZUCCHELLI
11604 *CMZ : 1.01/01 04/03/95 17.16.12 BY PIERO ZUCCHELLI
11605 *CMZ : 1.00/00 19/08/94 11.04.46 BY PIERO ZUCCHELLI
11606 *CMZ : 1.00/00 17/07/94 18.30.49 BY PIERO ZUCCHELLI
11607 *-- AUTHOR :
11608 C **********************************************************************
11609 
11610  SUBROUTINE linit(LFILE,LEPIN,PLZ,PPZ,INTER)
11611 
11612 C...INITIALIZE FOR AN INCOMING LEPTON (TYPE LEPIN, MOMENTUM PZ=PLZ)
11613 C...AND TARGET NUCLEON (MOMENTUM PZ=PPZ) TO INTERACT VIA INTER.
11614 C...FIND MAXIMUM OF DIFFERENTIAL CROSS SECTION, CALCULATE QCD EVENT
11615 C...PROBABILITIES OR READ THEM FROM LOGICAL FILE LFILE (IF >0).
11616 C...NUMERICAL INTEGRATION TO OBTAIN TOTAL CROSS-SECTION.
11617 
11618  COMMON /lintrl/ psave(3,4,5),ksave(4),xmin,xmax,ymin,ymax,
11619  +q2min,q2max,w2min,w2max,ilep,inu,ig,iz
11620  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
11621  COMMON /linter/ pari(40),ewqc(2,2,8),qc(8),zl(2,4),zq(2,8),pq(17)
11622  COMMON /lgrid/ nxx,nww,xx(20),ww(15),pqg(20,15,3),pqqb(20,15,2),
11623  +qgmax(20,15,3),qqbmax(20,15,2),ycut(20,15),xtot(20,15),np
11624  COMMON /loptim/ optx(4),opty(4),optq2(4),optw2(4),comfac
11625  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
11626  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
11627  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
11628  COMMON /lboost/ dbeta(2,3),stheta(2),sphi(2),pb(5),phir
11629  COMMON /lminui/ xkin(4),ukin(4),wkin(4),ain(4),bin(4),
11630  +maxfin,relup,relerr,reler2,fcnmax
11631  COMMON /lminuc/ namkin(4),nam(30)
11632  COMMON /lpflag/ lst3
11633  COMMON /pypara/ ipy(80),pypar(80),pyvar(80)
11634  CHARACTER*10 namkin,nam
11635  dimension lstw(40),parlw(30)
11636  DOUBLE PRECISION dtheta,dphi,dbeta
11637  DATA pi/3.1415927/,ncall/0/
11638 
11639  ncall=ncall+1
11640  lst3=lst(3)
11641 
11642 * S SUPPRESSION ACCORDING TO JONES ET AL,
11643 * Z PHYS C 27, 43-52 (1985)
11644 
11645  parj(2)=0.203
11646 
11647 
11648 * WARNING !!! UNDOCUMENTED VARIATION IN Q0 MASS SCALE
11649  pypar(12)=0.2*2
11650 
11651  parj(32)=0.5
11652 * (D=1. GeV) is, with quark masses added, used to define
11653 * the minimum allowable energy of a
11654 * colour-singlet jet system
11655 
11656 
11657 * TAU MASS CORRECTION ACCORDING TO PDG
11658 
11659  IF (ncall.EQ.1) THEN
11660  CALL lugive('PMAS(15,1)=1.777')
11661  WRITE(*,*)' ACTUAL CTAU LIFETIME IN MM:',pmas(15,4)
11662  CALL lugive('PMAS(15,4)=0.0886')
11663  ENDIF
11664 
11665 
11666 
11667 * NOW SOME PERSONAL PATCHES TO LUSHOW:
11668 * Q2=M^2/4
11669 * MSTJ(44)=1
11670 * LAMBDA=0.25 ACCORDING TO THE STRUCTURE FUNCTIONS VALUE
11671  parj(81)=0.25
11672 * INVARIANT MASS CUTOFF FOR PARTON SHOWERS
11673 * PARJ(82)=0.5
11674 * INVARIANT MASS CUTOFF FOR PHOTON EMISSION
11675 * PARJ(83)=0.5
11676 
11677 
11678 
11679 
11680  IF(lst(32).NE.0) THEN
11681  IF (lepin.NE.16) THEN
11682  WRITE(*,*)'***WARNING: LST(32) OPTION TESTED ONLY WITH TAU'
11683  ENDIF
11684  ENDIF
11685 
11686 
11687  IF(lst(8).LT.2) THEN
11688 C...DEFAULT FRAGMENTATION PARAMETERS SUITABLE FOR PARTON SHOWER CASE,
11689 C...RESET WHEN USING MATRIX ELEMENTS OR NO QCD.
11690  parj(21)=0.4
11691  parj(33)=1.1
11692  parj(41)=1.
11693  parj(42)=0.7
11694  parj(43)=1.
11695  parj(44)=0.7
11696  ELSE
11697 C...RESET PYTHIA PARAMETERS FROM LEPTO PARAMETERS.
11698  IF(mod(lst(8),10).EQ.3.OR.mod(lst(8),10).EQ.5) ipy(13)=0
11699  IF(mod(lst(8),10).EQ.4.OR.mod(lst(8),10).EQ.5) ipy(14)=0
11700  ipy(8)=lst(12)
11701  ENDIF
11702 
11703  IF(lst(18).GE.1) THEN
11704 C...W, Z MASSES FROM THETA-WEINBERG, FERMI CONSTANT GF AND RAD. CORR.
11705  pmas(24,1)=sqrt(pi*parl(16)/(sqrt(2.)*parl(17)*parl(5)*
11706  + (1.-parl(18))))
11707  pmas(23,1)=pmas(24,1)/sqrt(1.-parl(5))
11708  ENDIF
11709 C...COUPLINGS BETWEEN Z0 AND LEFT/RIGHT-HANDED LEPTONS AND QUARKS.
11710  zl(1,1)=-.5+parl(5)
11711  zl(1,2)=parl(5)
11712  zl(2,1)=zl(1,2)
11713  zl(2,2)=zl(1,1)
11714  zl(1,3)=0.5
11715  zl(2,3)=0.
11716  zl(1,4)=0.
11717  zl(2,4)=0.5
11718  DO 10 ifl=1,8
11719  zq(1,ifl)=sign(0.5,qc(ifl))-qc(ifl)*parl(5)
11720  10 zq(2,ifl)=-qc(ifl)*parl(5)
11721 
11722 C...SET INITIAL STATE.
11723  lst(23)=inter
11724  ksave(1)=lepin
11725  ksave(2)=2212
11726  k(1,1)=21
11727  k(1,2)=ksave(1)
11728  k(1,3)=0
11729  k(1,4)=0
11730  k(1,5)=0
11731  k(2,1)=21
11732  k(2,2)=ksave(2)
11733  k(2,3)=0
11734  k(2,4)=0
11735  k(2,5)=0
11736  p(1,1)=0.
11737  p(1,2)=0.
11738  p(1,3)=plz
11739  p(1,5)=ulmass(ksave(1))
11740  p(1,4)=sqrt(p(1,3)**2+p(1,5)**2)
11741  p(2,1)=0.
11742  p(2,2)=0.
11743  p(2,3)=ppz
11744  p(2,5)=ulmass(ksave(2))
11745  p(2,4)=sqrt(p(2,3)**2+p(2,5)**2)
11746  n=2
11747  lst(28)=3
11748 C...SAVE MOMENTUM VECTORS OF INCOMING PARTICLES
11749  DO 20 i=1,2
11750  DO 20 j=1,5
11751  20 psave(3,i,j)=p(i,j)
11752 C...DOT-PRODUCT OF INITIAL PARTICLES, CMS ENERGY
11753  parl(21)=2.*(dble(p(1,4))*dble(p(2,4))-dble(p(1,3))*dble(p(2,3)))
11754  roots=sqrt((dble(p(1,4))+dble(p(2,4)))**2
11755  + -(dble(p(1,3))+dble(p(2,3)))**2)
11756  IF(lst(3).GE.4.OR.(lst(3).EQ.3.AND.ncall.EQ.1)) WRITE(6,10000)
11757  +lepin,(p(1,j),j=1,3),parl(1),parl(2),(p(2,j),j=1,3),inter,roots
11758  IF(plz*ppz.GT.0.1) THEN
11759  WRITE(6,10100)
11760  stop
11761  ENDIF
11762 
11763  IF(psave(3,1,3).LT.0.) THEN
11764 C...FLIP EVENT TO HAVE INITIAL LEPTON ALONG +Z AXIS
11765  p(1,3)=-p(1,3)
11766  p(2,3)=-p(2,3)
11767  ENDIF
11768 C...BOOST PARAMETERS TO CMS OF INCOMING PARTICLES
11769  dbeta(1,1)=0.d0
11770  dbeta(1,2)=0.d0
11771  dbeta(1,3)=(dble(p(1,3))+dble(p(2,3)))/(dble(p(1,4))+dble(p(2,4)))
11772  sphi(1)=0.d0
11773  stheta(1)=0.d0
11774  IF(lst(17).NE.0) THEN
11775 C...FOR VARYING BEAM ENERGIES, TRANSFORM TO CMS, LEPTON ALONG +Z AXIS.
11776  CALL ludbrb(0,0,0.,0.,0.d0,0.d0,-dbeta(1,3))
11777  sphi(1)=ulangl(p(1,1),p(1,2))
11778  CALL ludbrb(0,0,0.,-sphi(1),0.d0,0.d0,0.d0)
11779  stheta(1)=ulangl(p(1,3),p(1,1))
11780  CALL ludbrb(0,0,-stheta(1),0.,0.d0,0.d0,0.d0)
11781  lst(28)=2
11782  ENDIF
11783 
11784 C...EFFECTIVE LIMITS ON KINEMATIC VARIABLES X, Y, Q**2, W**2
11785  pm2=p(2,5)**2
11786  s=roots**2
11787  cut(1)=max(cut(1),0.)
11788  cut(2)=min(cut(2),1.)
11789  cut(3)=max(cut(3),0.)
11790  cut(4)=min(cut(4),1.)
11791  cut(5)=max(cut(5),0.)
11792  cut(6)=min(cut(6),s)
11793  cut(7)=max(cut(7),0.)
11794  cut(8)=min(cut(8),s)
11795  cut(9)=max(cut(9),0.)
11796  cut(10)=min(cut(10),s/(2.*p(2,5)))
11797  xmin =cut(1)
11798  xmax =cut(2)
11799  ymin =cut(3)
11800  ymax =cut(4)
11801  q2min=cut(5)
11802  q2max=cut(6)
11803  w2min=cut(7)
11804  w2max=cut(8)
11805  umin =cut(9)
11806  umax =cut(10)
11807  DO 30 i=1,2
11808  IF(lst(32).NE.0) THEN
11809  xmin=max(xmin,q2min/(s*ymax),q2min/(2.*p(2,5)*cut(10)),
11810  + 1.-(w2max-pm2)/max(s*ymin,1.e-22), 1.-(w2max-pm2)/max(2.*p(2,
11811  + 5)*umin,1.e-22))
11812  xmin=max(xmin,xmin, ulmass(lepin-1)**2/(2.*ulmass(2212)*(plz+
11813  + ulmass(2212))) )
11814  xmincmp=max(xmin,q2min/(s*ymax),q2min/(2.*p(2,5)*cut(10)),
11815  + 1.-(w2max-pm2)/max(s*ymin,1.e-22), 1.-(w2max-pm2)/max(2.*p(2,
11816  + 5)*umin,1.e-22))
11817 * WRITE(*,*)'XMIN, XMINCMP=',XMIN,XMINCMP
11818  ELSE
11819  xmin=max(xmin,q2min/(s*ymax),q2min/(2.*p(2,5)*cut(10)),
11820  + 1.-(w2max-pm2)/max(s*ymin,1.e-22), 1.-(w2max-pm2)/max(2.*p(2,
11821  + 5)*umin,1.e-22))
11822  ENDIF
11823  xmax=min(xmax,q2max/max(s*ymin,1.e-22), q2max/max(2.*p(2,5)*
11824  + umin,1.e-22), 1.-(w2min-pm2)/(s*ymax),1.-(w2min-pm2)/(2.*p(2,5)
11825  + *umax))
11826  ymin=max(ymin,q2min/(s*xmax),(w2min-pm2)/(s*(1.-xmin)), (w2min-
11827  + pm2+q2min)/s,2.*p(2,5)*umin/s)
11828  ymax=min(ymax,q2max/max(s*xmin,1.e-22), (w2max-pm2)/max(s*(1.-
11829  + xmax),1.e-22), (w2max-pm2+q2max)/s,2.*p(2,5)*umax/s)
11830  q2min=max(q2min,s*xmin*ymin,s*ymin-w2max+pm2, 2.*p(2,5)*umin*
11831  + xmin,(w2min-pm2)*xmin/(1.-xmin))
11832  q2max=min(q2max,s*xmax*ymax,s*ymax-w2min+pm2, 2.*p(2,5)*umax*
11833  + xmax,(w2max-pm2)*xmax/max(1.-xmax,1.e-22))
11834  w2min=max(w2min,s*(1.-xmax)*ymin+pm2,q2min*(1.-xmax)/xmax+pm2,
11835  + s*ymin-q2max+pm2,2.*p(2,5)*umin*(1.-xmax)+pm2)
11836  w2max=min(w2max,s*(1.-xmin)*ymax+pm2, q2max*(1.-xmin)/max(xmin,
11837  + 1.e-22)+pm2, s*ymax-q2min+pm2,2.*p(2,5)*umax*(1.-xmin)+pm2)
11838 C UMIN=MAX(UMIN,....)
11839 C UMAX=MIN(UMAX,....)
11840  30 CONTINUE
11841 
11842 
11843 
11844 
11845  IF(lst(3).GE.4.OR.(lst(3).EQ.3.AND.ncall.EQ.1)) WRITE(6,10200)
11846  +cut,xmin,xmax,ymin,ymax,q2min,q2max,w2min,w2max,umin,umax
11847  IF(xmax.LT.xmin.OR.ymax.LT.ymin.OR.q2max.LT.q2min.OR.
11848  +w2max.LT.w2min) THEN
11849  IF(lst(3).GE.1) WRITE(6,10300)
11850  IF(lst(3).GE.2) THEN
11851 * WRITE(6,11600)
11852 * STOP
11853  ENDIF
11854  ENDIF
11855 
11856 
11857  pari(11)=(parl(1)-parl(2))/parl(1)
11858  ksave(4)=lepin
11859  ilep=1
11860  IF(lepin.LT.0) ilep=2
11861  inu=0
11862  IF(iabs(lepin).EQ.12.OR.iabs(lepin).EQ.14.OR.
11863  +iabs(lepin).EQ.16) inu=1
11864  IF(inu.EQ.1) THEN
11865 C...SET FULL POLARISATION FOR INCOMING NEUTRINO.
11866  parl(6)=-1.
11867  IF(lepin.LT.0) parl(6)=1.
11868  ENDIF
11869  IF(lst(23).EQ.1.AND.inu.EQ.0) THEN
11870 C...ELECTROMAGNETIC INTERACTION.
11871  ksave(3)=22
11872  ig=1
11873  iz=0
11874  ELSEIF(lst(23).EQ.2) THEN
11875 C...WEAK CHARGED CURRENT, ONLY ONE HELICITY STATE CONTRIBUTES.
11876  IF(ksave(1).LT.0.AND.parl(6).LT.-0.99
11877  + .OR.ksave(1).GT.0.AND.parl(6).GT.0.99) THEN
11878  IF(lst(3).GE.1) WRITE(6,10400) lepin,parl(6)
11879  IF(lst(3).GE.2) THEN
11880  WRITE(6,11600)
11881  stop
11882  ENDIF
11883  ENDIF
11884  IF(mod(iabs(lepin),2).EQ.0) THEN
11885  ksave(3)=isign(24,lepin)
11886  ksave(4)=isign(iabs(lepin)-1,lepin)
11887  ELSE
11888  ksave(3)=isign(24,-lepin)
11889  ksave(4)=isign(iabs(lepin)+1,lepin)
11890  ENDIF
11891  ELSEIF(lst(23).EQ.3.OR.(lst(23).EQ.4.AND.inu.EQ.1)) THEN
11892 C...WEAK NEUTRAL CURRENT.
11893  ksave(3)=23
11894  ig=0
11895  iz=1
11896  ELSEIF(lst(23).EQ.4.AND.inu.EQ.0) THEN
11897 C...NEUTRAL CURRENT, ELECTROMAGNETIC AND WEAK WITH INTERFERENCE.
11898  ksave(3)=23
11899  ig=1
11900  iz=1
11901  ELSE
11902  IF(lst(3).GE.1) WRITE(6,10500) inter,lepin
11903  IF(lst(3).GE.2) THEN
11904  WRITE(6,11600)
11905  stop
11906  ENDIF
11907  ENDIF
11908 
11909 C...CHOICE OF INDEPENDENT VARIABLES.
11910  IF(lst(1).EQ.0) THEN
11911  lst(31)=1
11912  IF(inter.EQ.2.OR.inter.EQ.3) lst(31)=2
11913  ELSE
11914  lst(31)=iabs(lst(1))
11915  ENDIF
11916  IF(lst(31).LT.1.OR.lst(31).GT.3) THEN
11917  IF(lst(3).GE.1) WRITE(6,10600) lst(1),lst(31)
11918  IF(lst(3).GE.2) THEN
11919  WRITE(6,11600)
11920  stop
11921  ENDIF
11922  ENDIF
11923  IF(lst(1).LT.0) THEN
11924 C...USER-DEFINED OPTIMIZATION PARAMETERS.
11925  IF(lst(3).GE.4.OR.(lst(3).EQ.3.AND.ncall.EQ.1)) WRITE(6,10700)
11926  + optx,opty,optq2,optw2
11927  ELSE
11928 C...SET OPTIMIZATION PARAMETERS.
11929  DO 40 i=1,4
11930  optx(i)=0.
11931  opty(i)=0.
11932  optq2(i)=0.
11933  40 optw2(i)=0.
11934  IF(inter.EQ.1) THEN
11935  optx(2)=1.
11936  opty(1)=1.
11937  optq2(3)=1.
11938  optw2(3)=1.
11939  ELSEIF(inter.EQ.4) THEN
11940  optx(1)=0.1
11941  optx(2)=1.
11942  opty(1)=1.
11943  optq2(1)=0.5
11944  optq2(2)=0.5
11945  optq2(3)=1.
11946  optw2(1)=0.5
11947  optw2(2)=0.5
11948  optw2(3)=1.
11949  ELSE
11950  optx(1)=1.
11951  opty(1)=1.
11952  optq2(1)=1.
11953  optw2(1)=1.
11954  ENDIF
11955  ENDIF
11956 
11957 C...INITIALIZE MONTE CARLO ESTIMATE OF CROSS SECTION.
11958  parl(24)=0.
11959  pari(27)=0.
11960  pari(28)=0.
11961  pari(29)=0.
11962  pari(30)=0.
11963  pari(32)=0.
11964  IF(lst(23).EQ.2) THEN
11965 C...CONSTANT FACTOR GF**2/PI FOR CC, TRANSFORMATION TO PICOBARN.
11966  pari(31)=parl(17)**2/pi*0.39e+09
11967  ELSE
11968 C...CONSTANT FACTOR 2*PI*ALPHA**2 FOR NC, TRANSFORMATION TO PICOBARN.
11969  pari(31)=2.*pi*parl(16)**2*0.39e+09
11970  ENDIF
11971  IF(lst(3).GE.4.OR.(lst(3).EQ.3.AND.ncall.EQ.1)) WRITE(6,10800)
11972  +(i,lst(i),lst(i+10),parl(i),parl(i+10),i=1,10)
11973 
11974 C...SET UP GRID WITH LONGITUDINAL STRUCTURE FUNCTION, QCD OR TARGET MASS
11975  lqcd=mod(lst(11),10)
11976  ltm=mod(lst(11)/10,10)
11977  IF(inter.EQ.1.AND.lst(11).NE.0) CALL fltabl
11978 
11979 C...GET INTEGRATED CROSS-SECTION.
11980  parl(23)=0.
11981  IF(lst(10).GT.0) CALL lxsect
11982  IF(lqcd.EQ.2.OR.ltm.EQ.2) THEN
11983  WRITE(6,10900)
11984  IF(lqcd.EQ.2) WRITE(6,11000)
11985  IF(ltm .EQ.2) WRITE(6,11100)
11986  WRITE(6,11200)
11987  ENDIF
11988 
11989  IF(lst(2).EQ.1) THEN
11990 C...FIND MAX VALUE OF DIFFERENTIAL CROSS SECTION FOR REJECTION.
11991  ukin(1)=(xmax+xmin)/2.
11992  wkin(1)=0.8*(xmax-xmin)/2.
11993  ain(1)=xmin
11994  bin(1)=xmax
11995  IF(lst(31).EQ.1) THEN
11996  ukin(2)=(q2max+q2min)/2.
11997  wkin(2)=0.8*(q2max-q2min)/2.
11998  ain(2)=q2min
11999  bin(2)=q2max
12000  namkin(2)=' Q**2'
12001  ELSEIF(lst(31).EQ.2) THEN
12002  ukin(2)=(ymax+ymin)/2.
12003  wkin(2)=0.8*(ymax-ymin)/2.
12004  ain(2)=ymin
12005  bin(2)=ymax
12006  namkin(2)=' Y'
12007  ELSEIF(lst(31).EQ.3) THEN
12008  ukin(2)=(w2max+w2min)/2.
12009  wkin(2)=0.8*(w2max-w2min)/2.
12010  ain(2)=w2min
12011  bin(2)=w2max
12012  namkin(2)=' W**2'
12013  ENDIF
12014 C...MAXIMUM OBTAINED BY MINIMIZING -(DIFF. X-SECTION).
12015  CALL ltimex(ti1)
12016  CALL lminew
12017  CALL ltimex(ti2)
12018 * WRITE(*,*)'MIN. TIME:',TI2-TI1,' S'
12019  pari(lst(23))=fcnmax*1.5
12020  IF(lst(3).GE.4.OR.(lst(3).EQ.3.AND.ncall.EQ.1)) WRITE(6,11300)
12021  + pari(lst(23)),ti2-ti1
12022  ENDIF
12023 
12024  IF(lfile.GT.0) THEN
12025 C...READ QCD WEIGHTS FROM FILE.
12026  READ(lfile) lstw,parlw,nxx,nww,np,xx,ww
12027  ipmax=2
12028  IF(lstw(17).NE.0) ipmax=3
12029  READ(lfile) (((pqg(ix,iw,ip),ix=1,nxx),iw=1,nww),ip=1,np),
12030  + (((pqqb(ix,iw,ip),ix=1,nxx),iw=1,nww),ip=1,np),
12031  + (((qgmax(ix,iw,ip),ix=1,nxx),iw=1,nww),ip=1,ipmax),
12032  + (((qqbmax(ix,iw,ip),ix=1,nxx),iw=1,nww),ip=1,min(2,ipmax)),
12033  + ycut
12034  IF(np.NE.1) READ(lfile) xtot
12035  CLOSE(lfile)
12036 C...RESET PARAMETERS FOR MATRIX ELEMENT INTEGRATION.
12037  parl(8)=parlw(8)
12038  parl(9)=parlw(9)
12039  parl(11)=parlw(11)
12040  parl(12)=parlw(12)
12041  parl(13)=parlw(13)
12042 C...CHECK CURRENT PARAMETER VALUES AGAINST THOSE USED WHEN
12043 C...CALCULATING WEIGHTS.
12044  IF(lst(12).NE.lstw(12).OR.lst(13).NE.lstw(13)
12045  + .OR.lst(15).NE.lstw(15).OR.lst(16).NE.lstw(16)
12046  + .OR.lst(17).NE.lstw(17).OR.lst(23).NE.lstw(23)
12047  + .OR.abs(parl(1)-parlw(1)).GT.0.1.OR.abs(parl(2)-parlw(2)).GT.0.1
12048  + .OR.abs(parl(5)-parlw(5)).GT.0.01
12049  + .OR.abs(parl(6)-parlw(6)).GT.0.1) THEN
12050  IF(lst(3).GE.1) WRITE(6,11400) lst(12),lstw(12),lst(13),
12051  + lstw(13),lst(15), lstw(15),lst(16),lstw(16),lst(17),lstw(17),
12052  + lst(23),lstw(23), parl(1),parlw(1),parl(2),parlw(2),parl(5),
12053  + parlw(5),parl(6), parlw(6)
12054  IF(lst(3).GE.2) THEN
12055  WRITE(6,11600)
12056  stop
12057  ENDIF
12058  ENDIF
12059  ELSEIF(lst(8).EQ.1.OR.lst(8)/10.EQ.1.OR.mod(lst(8),10).EQ.9) THEN
12060 C...CALCULATE WEIGHTS IF 1ST ORDER QCD REQUESTED.
12061  CALL ltimex(ti1)
12062  CALL lweits(lfile)
12063  CALL ltimex(ti2)
12064  IF(lst(3).GE.4.OR.(lst(3).EQ.3.AND.ncall.EQ.1)) WRITE(6,11500)
12065  + ti2-ti1
12066  ENDIF
12067 
12068 C...RESET COUNTERS TO ZERO FOR MONTE CARLO ESTIMATE OF CROSS SECTION.
12069  pari(27)=0.
12070  pari(28)=0.
12071  pari(29)=0.
12072  pari(30)=0.
12073  lst(20)=0
12074  RETURN
12075 
12076 10000 FORMAT('1',//,5x,'THE LUND MONTE CARLO FOR DEEP INELASTIC LEPTON-'
12077  +,'NUCLEON SCATTERING',/,5x,65('='),//,
12078  +25x,'LEPTO VERSION 6.1, MAY 4, 1992',//,
12079  +' LEPTON: TYPE =',i3,5x,'MOMENTUM (PX,PY,PZ) =',3f8.1,
12080  +' GEV',//,' TARGET: A, Z =',2f3.0,2x,
12081  +'MOMENTUM (PX,PY,PZ) =',3f8.1,' GEV',//,
12082  +' INTERACTION :',i3,14x,' CMS ENERGY =',1pg12.4,' GEV',/)
12083 10100 FORMAT(' WARNING: LEPTON AND NUCLEON MOMENTA IN SAME DIRECTION',
12084  +' NOT ALLOWED.',/,10x,'EXECUTION STOPPED.')
12085 10200 FORMAT(/,' USER APPLIED CUTS (+ PHASE SPACE) : ',1p,
12086  + g12.4,' < X < ',g12.4,
12087  +/,37x,g12.4,' < Y < ',g12.4,
12088  +/,37x,g12.4,' < Q**2 < ',g12.4,
12089  +/,37x,g12.4,' < W**2 < ',g12.4,
12090  +/,37x,g12.4,' < NU < ',g12.4,
12091  +/,37x,g12.4,' < E'' < ',g12.4,
12092  +/,37x,g12.4,' < THETA < ',g12.4,/,
12093  +/, ' EFFECTIVE RANGES (FROM ABOVE CUTS): ',
12094  + g12.4,' < X < ',g12.4,
12095  +/,37x,g12.4,' < Y < ',g12.4,
12096  +/,37x,g12.4,' < Q**2 < ',g12.4,
12097  +/,37x,g12.4,' < W**2 < ',g12.4,
12098  +/,37x,g12.4,' < NU < ',g12.4)
12099 10300 FORMAT(' WARNING: EFFECTIVE UPPER LIMIT OF KINEMATICAL ',
12100  +'VARIABLE(S) SMALLER THAN CORRESPONDING LOWER LIMIT.')
12101 10400 FORMAT(' WARNING: WEAK CHARGED CURRENT CROSS SECTION ZERO FOR ',
12102  +'SPECIFIED LEPTON HELICITY; LEPIN, PARL(6) =',i3,f5.2)
12103 10500 FORMAT(' WARNING: UNRECOGNIZED INTERACTION IN LINIT CALL: ',
12104  +'INTER = ',i5,' FOR LEPTON LEPIN =',i5)
12105 10600 FORMAT(' WARNING: UNALLOWED VALUE OF LST(1) =',i3,
12106  +' AND/OR LST(31) =',i3)
12107 10700 FORMAT(/,' USER-DEFINED OPTIMIZATION PARAMETERS:',
12108  +/,5x,'OPTX(1...4) =',4g11.3,/,5x,'OPTY(1...4) =',4g11.3,
12109  +/,5x,'OPYQ2(1...4) =',4g11.3,/,5x,'OPTW2(1...4) =',4g11.3,/)
12110 10800 FORMAT(/,' PARAMETER VALUES:',//,9x,'I',4x,'LST(I)',1x,
12111  +'LST(I+10)',8x,'PARL(I)',5x,'PARL(I+10)',1p,
12112  +/,5x,55('-'),10(/,3i10,2g15.4),/)
12113 10900 FORMAT(' WARNING: CROSS SECTION, PARL(23), EXCLUDES FL (SEE ',
12114  +'LST(11)) FROM:')
12115 11000 FORMAT(10x,'QCD, SINCE EVALUATED EVENT BY EVENT FOR LQCD=2')
12116 11100 FORMAT(10x,'TM , SINCE EVALUATED EVENT BY EVENT FOR LTM =2')
12117 11200 FORMAT(' CROSS SECTION IN PARL(24) INCLUDES THESE CONTRIBUTIONS.')
12118 11300 FORMAT(' MAX OF DIFFERENTIAL CROSS SECTION (FOR WEIGHTING) =',
12119  +e12.4,/,' OBTAINED IN ',f7.2,' SECONDS.',/)
12120 11400 FORMAT(//,' WARNING: CURRENT PARAMETER VALUES DO NOT MATCH ',
12121  +'WITH THOSE USED WHEN CALCULATING QCD WEIGHTS.',//,15x,
12122  +'CURRENT VALUE VALUE FOR WEIGHTS',/,
12123  +/,' LST(12) ',i12,10x,i12,
12124  +/,' LST(13) ',i12,10x,i12,
12125  +/,' LST(15) ',i12,10x,i12,
12126  +/,' LST(16) ',i12,10x,i12,
12127  +/,' LST(17) ',i12,10x,i12,
12128  +/,' LST(23) ',i12,10x,i12,
12129  +/,' PARL(1) ',e12.4,10x,e12.4,
12130  +/,' PARL(2) ',e12.4,10x,e12.4,
12131  +/,' PARL(5) ',e12.4,10x,e12.4,
12132  +/,' PARL(6) ',e12.4,10x,e12.4)
12133 11500 FORMAT(/,' TIME FOR CALCULATING QCD WEIGHTS =',f5.1,' SECONDS',/)
12134 11600 FORMAT(' EXECUTION STOPPED ',/)
12135  END
12136 *CMZ : 03/03/97 19.17.26 by Unknown
12137 *CMZ : 1.01/22 27/05/95 16.02.43 BY PIERO ZUCCHELLI
12138 *CMZ : 1.01/21 27/05/95 15.58.38 BY PIERO ZUCCHELLI
12139 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
12140 *CMZ : 1.01/08 05/03/95 11.39.25 BY PIERO ZUCCHELLI
12141 *CMZ : 1.00/00 22/07/94 17.46.01 BY PIERO ZUCCHELLI
12142 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
12143 *-- AUTHOR :
12144 C **********************************************************************
12145 
12146  FUNCTION lkinem(L)
12147 
12148 C...CALCULATE KINEMATICAL VARIABLES AND REJECT (OPTIONALLY) IF OUTSIDE
12149 C...REQUIRED LIMITS.
12150 
12151  COMMON /lintrl/ psave(3,4,5),ksave(4),xmin,xmax,ymin,ymax,
12152  +q2min,q2max,w2min,w2max,ilep,inu,ig,iz
12153  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
12154  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
12155  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
12156  COMMON /linter/ pari(40),ewqc(2,2,8),qc(8),zl(2,4),zq(2,8),pq(17)
12157  COMMON /lboost/ dbeta(2,3),stheta(2),sphi(2),pb(5),phir
12158  DOUBLE PRECISION dtheta,dphi,dbeta,de,dpz,dpt,detot
12159 C print*,' in lkinem'
12160  lkinem=1
12161  IF(l.EQ.-3) THEN
12162 C...X,W KNOWN FROM LWEITS, NO CUTS APPLIED.
12163  u=(w2-p(2,5)**2)/(2.*p(2,5)*(1.-x))
12164  q2=2.*p(2,5)*u*x
12165  y=q2/(parl(21)*x)
12166  goto 20
12167  ENDIF
12168 C...X,Y GIVEN.
12169  parl(22)=y*parl(21)
12170  q2=x*parl(22)
12171  u=parl(22)/(2.*p(2,5))
12172  w2=parl(22)*(1.-x)+p(2,5)**2
12173  p(4,5)=ulmass(k(4,2))
12174  IF(p(4,5)/sqrt(parl(21)).LT.0.001) THEN
12175 C...SIMPLER FORMULAE FOR EFFECTIVELY MASSLESS SCATTERED LEPTON.
12176  de=dble(p(1,4))*(1.-dble(y))+dble(x)*dble(y)*dble(abs(p(2,3)))
12177  dpz=de-dble(x)*dble(y)*(dble(p(2,4))+dble(abs(p(2,3))))
12178  ELSE
12179 C...FORMULAE FOR MASSIVE SCATTERED LEPTON.
12180  de=dble(p(1,4))+(dble(abs(p(2,3)))*(dble(q2)+dble(p(4,5))**2)/
12181  + (2.d0*dble(p(1,4)))-dble(parl(22))/2.d0)/
12182  + (dble(p(2,4))+dble(abs(p(2,3))))
12183  dpz=dble(p(1,4))-(dble(p(2,4))*(dble(q2)+dble(p(4,5))**2)/
12184  + (2.d0*dble(p(1,4)))+dble(parl(22))/2.d0)/
12185  + (dble(p(2,4))+dble(abs(p(2,3))))
12186  ENDIF
12187  dpt=de**2-dpz**2-dble(p(4,5))**2
12188  IF(dpt.LT.0.d0) RETURN
12189  dpt=sqrt(dpt)
12190  p(4,1)=dpt
12191  p(4,2)=0.
12192  p(4,3)=dpz
12193  p(4,4)=de
12194  p(3,1)=-dpt
12195  p(3,2)=0.
12196  p(3,3)=dble(p(1,3))-dpz
12197  p(3,4)=dble(p(1,4))-de
12198  p(3,5)=-sqrt(q2)
12199  k(3,3)=1
12200  k(4,3)=1
12201  n=4
12202  IF(l.EQ.3) goto 20
12203 C print*,' cut cut cut'
12204  IF(x.LT.cut(1).OR.x.GT.cut(2)) RETURN
12205  IF(y.LT.cut(3).OR.y.GT.cut(4)) RETURN
12206  IF(q2.LT.cut(5).OR.q2.GT.cut(6)) RETURN
12207  IF(w2.LT.cut(7).OR.w2.GT.cut(8)) RETURN
12208  IF(u.LT.cut(9).OR.u.GT.cut(10)) RETURN
12209  IF(lst(17).EQ.0) THEN
12210 C print*,'survived'
12211  IF(p(4,4).LT.cut(11).OR.p(4,4).GT.cut(12)) THEN
12212  WRITE(*,*)'CUTTING TOO LOW LEPTON ENERGY',p(4,4),cut(11)
12213  RETURN
12214  ENDIF
12215  thetal=plu(4,13)
12216 C THETAL=ACOS((P(1,1)*P(4,1)+P(1,2)*P(4,2)+P(1,3)*P(4,3))
12217 C & /SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2)/
12218 C & SQRT(P(4,1)**2+P(4,2)**2+P(4,3)**2))
12219  ELSE
12220 C...NO CUTS ON ENERGY, ANGLE FOR INITIALISATION OF VARYING ENERGY MODE
12221  IF(lst(20).NE.0) goto 20
12222 C...TRANSFORM SCATTERED LEPTON BACK TO LAB SYSTEM TO MAKE CUT
12223 C...IN ENERGY AND ANGLE (DEFINED AS SPACE ANGLE TO INCOMING LEPTON).
12224  DO 10 j=1,5
12225  k(6,j)=k(4,j)
12226  10 p(6,j)=p(4,j)
12227 * WRITE(*,*)'LKINEM BOOST'
12228  CALL ludbrb(6,6,stheta(1),sphi(1),0.d0,0.d0,0.d0)
12229  CALL ludbrb(6,6,0.,0.,dbeta(1,1),dbeta(1,2),dbeta(1,3))
12230  IF(p(6,4).LT.cut(11).OR.p(6,4).GT.cut(12)) RETURN
12231  thetal=acos((psave(3,1,1)*p(6,1)+psave(3,1,2)*p(6,2)+
12232  + psave(3,1,3)*p(6,3))
12233  + /sqrt(psave(3,1,1)**2+psave(3,1,2)**2+psave(3,1,3)**2)/
12234  + sqrt(p(6,1)**2+p(6,2)**2+p(6,3)**2))
12235  ENDIF
12236  IF(thetal.LT.cut(13).OR.thetal.GT.cut(14)) then
12237 C print*,' problem with thetal'
12238  RETURN
12239  end if
12240  20 lkinem=0
12241  RETURN
12242  END
12243 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
12244 *CMZ : 1.00/00 04/07/94 15.02.28 BY PIERO ZUCCHELLI
12245 *-- AUTHOR :
12246 C#######################################################################
12247 C
12248 C THE FOLLOWING ROUTINES ARE SLIGHTLY MODIFIED MINIMIZATION ROUTINES
12249 C FROM THE MINUIT PROGRAM PACKAGE.
12250 C
12251 C **********************************************************************
12252 
12253  SUBROUTINE lmcmnd
12254 
12255 C...THIS IS THE MINUIT ROUTINE COMAND.
12256 CC GETS IFORMATION FROM /LMINUI/ AND TAKES APPROPRIATE ACTION,
12257 CC EITHER DIRECTLY BY SKIPPING TO THE CORRESPONDING CODE IN
12258 CC LMCMND, OR BY SETTING UP A CALL TO A SUBROUTINE
12259 CC
12260  COMMON /lminui/ xkin(4),ukin(4),wkin(4),ain(4),bin(4),
12261  &maxfin,relup,relerr,reler2,fcnmax
12262  COMMON /lpflag/ lst3
12263 
12264  COMMON
12265  1/lmmine/ erp(30) ,ern(30)
12266  2/lmpari/ x(15) ,xt(15) ,dirin(15) ,maxint ,npar
12267  3/lmpare/ u(30) ,werr(30) ,maxext ,nu
12268  4/lmlimi/ alim(30) ,blim(30) ,lcode(30) ,lcorsp(30) ,limset
12269  5/lmvari/ v(15,15)
12270  7/lmfix / ipfix(15),xs(15) ,xts(15) ,dirins(15) ,npfix
12271  7/lmfix2/ grds(15) ,g2s(15) ,gsteps(15),aberfs(15)
12272  c/lmcasc/ y(16) ,jh ,jl
12273  f/lmderi/ gin(30) ,grd(15) ,g2(15) ,gstep(15) ,aberf(15)
12274  g/lmsimv/ p(15,16) ,pstar(15),pstst(15) ,pbar(15) ,prho(15)
12275  j/lmvart/ vt(15,15)
12276  COMMON
12277  6/lmunit/ isysrd ,isyswr ,isyspu
12278  8/lmtitl/ title(13),date(2) ,isw(7) ,nblock
12279  9/lmconv/ epsi ,apsi ,vtest ,nstepq ,nfcn ,nfcnmx
12280  a/lmcard/ cword ,cword2 ,cword3 ,word7(7)
12281  b/lmmini/ amin ,up ,newmin ,itaur ,sigma,epsmac
12282  fval3 = 2.0*amin+1.0
12283 C . . . . . . . . . . ERROR DEF
12284  word7(1)=relup*abs(amin)
12285  up = word7(1)
12286  IF (up .LE. 0.) up = 1.0
12287  IF (isw(2) .GE. 1) CALL lmprin(1,amin)
12288  word7(1)=maxfin
12289  word7(2)=relerr*up
12290  nfcnmx = word7(1) + 0.5
12291  IF (nfcnmx .LE. 0) nfcnmx = 1000
12292  epsi = word7(2)
12293  IF (epsi .LE. 0.) epsi = 0.1 * up
12294  newmin = 0
12295  itaur = 0
12296  isw(1) = 0
12297  CALL lmsimp
12298  IF(abs(dirin(1)).LE.abs(epsmac*x(1)).AND.
12299  + abs(dirin(2)).LE.abs(epsmac*x(2))) THEN
12300  IF(lst3.GE.1) WRITE(6,10000)
12301  goto 10
12302  ENDIF
12303  word7(1)=maxfin
12304  relerr=reler2*relerr
12305  word7(2)=relerr*up
12306  nfcnmx = word7(1) + 0.5
12307  IF (nfcnmx .LE. 0) nfcnmx = 1000
12308  epsi = word7(2)
12309  IF (epsi .LE. 0.) epsi = 0.1 * up
12310  CALL lmsimp
12311  10 fcnmax=abs(amin)
12312  IF(isw(1).GE.1) THEN
12313  IF(lst3.GE.1) WRITE(6,10100)
12314  fcnmax=fcnmax*1.25
12315  ENDIF
12316  fmax=abs(amin)
12317 C . . . . . . . . . . END, EXIT
12318  word7(1)=0.
12319  20 it = word7(1) + 0.5
12320  IF (fval3 .EQ. amin .OR. it .GT. 0) RETURN
12321  iflag = 3
12322  CALL lsigmx(npar,gin,f,u,iflag)
12323  nfcn = nfcn + 1
12324  IF(lst3.GE.1.AND.abs(f).GT.fmax) WRITE(6,10200) f
12325  RETURN
12326 
12327 10000 FORMAT(' WARNING: STEPSIZES ARE LESS THAN MACHINE ACCURACY ',
12328  &'TIMES VARIABLE VALUES. NO FURTHER MINIMIZATION ATTEMPTED.')
12329 10100 FORMAT(' WARNING: SIMPLEX MINIMIZATION HAS NOT CONVERGED ',
12330  &'PROPERLY.',/,10x,'RETURNED MAXIMUM INCREASED BY A FACTOR 1.25.')
12331 10200 FORMAT(' WARNING FROM LMCMND: FUNCTION AT MINIMUM, ',e12.4,
12332  &' IS SMALLER THAN STORED MINIMUM.')
12333 
12334  END
12335 *CMZ : 1.01/50 22/05/96 12.22.19 by Piero Zucchelli
12336 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
12337 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
12338 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
12339 *-- AUTHOR :
12340 C **********************************************************************
12341 
12342  SUBROUTINE lmeps
12343 
12344  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
12345  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
12346  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
12347  COMMON /lboost/ dbeta(2,3),stheta(2),sphi(2),pb(5),phir
12348  COMMON /pypara/ ipy(80),pypar(80),pyvar(80)
12349  COMMON /pyproc/ isub,kfl(3,2),xpy(2),sh,th,uh,q2py,xsec(0:40)
12350  COMMON /pyint1/ xqpy(2,-6:6)
12351  DOUBLE PRECISION dtheta,dphi,dbeta
12352  DOUBLE PRECISION dpq2,dpb(3),dpa(3),dcthet,drobo(5)
12353  dimension ks(9,5),ps(9,5),robo(5),xpq(-6:6)
12354  DATA mg/2/
12355  SAVE ks,ps
12356 
12357 C CALL GULIST(100,2)
12358 C...SAVE EVENT RECORD IN HADRONIC CMS
12359  DO 10 i=1,7
12360  DO 10 j=1,5
12361  ks(i,j)=k(i,j)
12362  10 ps(i,j)=p(i,j)
12363 C...REARRANGE EVENT RECORD TO PYSSPB STANDARD
12364  ip2=6
12365  IF(lst(24).EQ.3) ip2=7
12366  DO 20 j=1,5
12367  k(3,j)=0.
12368  p(3,j)=0.
12369  k(4,j)=0
12370  p(4,j)=0.
12371  k(5,j)=ks(3,j)
12372  p(5,j)=ps(3,j)
12373  k(7,j)=ks(4,j)
12374  p(7,j)=ps(4,j)
12375  k(8,j)=ks(5,j)
12376  p(8,j)=ps(5,j)
12377  k(9,j)=ks(4,j)
12378  p(9,j)=ps(4,j)
12379  k(10,j)=ks(ip2,j)
12380  20 p(10,j)=ps(ip2,j)
12381  k(5,3)=3
12382  k(6,3)=4
12383  k(7,3)=5
12384  k(8,3)=6
12385  k(9,3)=5
12386  k(10,3)=6
12387  DO 30 i=5,10
12388  30 k(i,1)=21
12389  k(9,1)=0
12390 C...INCOMING PARTON = OUTGOING 2 PARTON - BOSON FOURVECTORS
12391  DO 40 j=1,4
12392  40 p(6,j)=p(8,j)+p(10,j)-p(5,j)
12393  p(6,5)=0.
12394  k(6,2)=lst(25)
12395  IF(lst(24).EQ.3) k(6,2)=21
12396  n=10
12397 C CALL GULIST(101,2)
12398 
12399  xr=x
12400  dpq2=dble(q2)
12401 C...PARTONS WITH COLOUR INFORMATION IN HADRONIC CMS FRAME.
12402  DO 50 i=11,27
12403  DO 50 j=1,5
12404  k(i,j)=0
12405  p(i,j)=0.
12406  50 v(i,j)=0.
12407  ns=20
12408  DO 60 j=1,5
12409  k(ns+1,j)=k(5,j)
12410  p(ns+1,j)=p(5,j)
12411  k(ns+3,j)=k(6,j)
12412  p(ns+3,j)=p(6,j)
12413  k(ns+5,j)=k(8,j)
12414  p(ns+5,j)=p(8,j)
12415  k(ns+6,j)=k(10,j)
12416  60 p(ns+6,j)=p(10,j)
12417 C...OLD STANDARD CONTINUATION LINES
12418  k(ns+2,1)=-1
12419  k(ns+2,3)=ns+1
12420  k(ns+4,1)=-1
12421  k(ns+4,3)=ns+3
12422  p(ns+4,3)=27
12423  p(ns+4,4)=27
12424 C...ORIGIN AND COLOUR INFO FOR INCOMING PARTON
12425  k(ns+3,1)=13
12426  k(ns+3,3)=2
12427  k(ns+3,4)=27
12428  k(ns+3,5)=27
12429 C...COLOUR INFO FOR TWO OUTGOING PARTONS
12430  k(ns+5,1)=3
12431  k(ns+6,1)=3
12432  IF(k(ns+6,2).EQ.21) THEN
12433 C...QG-EVENT
12434  IF(k(ns+5,2).GT.0) THEN
12435  k(ns+5,4)=(ns+6)*mstu(5)
12436  k(ns+5,5)=(ns+7)*mstu(5)
12437  k(ns+6,4)=(ns+7)*mstu(5)
12438  k(ns+6,5)=(ns+5)*mstu(5)
12439  ELSE
12440  k(ns+5,4)=(ns+7)*mstu(5)
12441  k(ns+5,5)=(ns+6)*mstu(5)
12442  k(ns+6,4)=(ns+5)*mstu(5)
12443  k(ns+6,5)=(ns+7)*mstu(5)
12444  ENDIF
12445  ELSE
12446 C...QQBAR-EVENT
12447  k(ns+5,4)=(ns+7)*mstu(5)
12448  k(ns+5,5)=(ns+7)*mstu(5)
12449  k(ns+6,4)=(ns+7)*mstu(5)
12450  k(ns+6,5)=(ns+7)*mstu(5)
12451  ENDIF
12452 C...EFFECTIVE OUTGOING PARTON = SUM OF BOTH OUTGOING PARTONS
12453  k(ns+7,1)=14
12454  k(ns+7,3)=3
12455  IF(lst(24).EQ.2) THEN
12456  k(ns+7,2)=k(ns+5,2)
12457  IF(k(ns+7,2).EQ.21) WRITE(6,*) ' WARNING: K(NS+7,2)=',k(ns+7,2)
12458  IF(k(ns+7,2).GT.0) THEN
12459  k(ns+7,4)=(ns+3)*mstu(5)+26
12460  k(ns+7,5)=(ns+3)*mstu(5)+25
12461  ELSE
12462  k(ns+7,4)=(ns+3)*mstu(5)+25
12463  k(ns+7,5)=(ns+3)*mstu(5)+26
12464  ENDIF
12465  ELSE
12466  k(ns+7,2)=21
12467  IF(k(ns+5,2).GT.0) THEN
12468  k(ns+7,4)=(ns+3)*mstu(5)+25
12469  k(ns+7,5)=(ns+3)*mstu(5)+26
12470  ELSE
12471  k(ns+7,4)=(ns+3)*mstu(5)+26
12472  k(ns+7,5)=(ns+3)*mstu(5)+25
12473  ENDIF
12474  ENDIF
12475  DO 70 j=1,4
12476  70 p(ns+7,j)=p(8,j)+p(10,j)
12477  p(ns+7,5)=sqrt(p(ns+7,4)**2-p(ns+7,1)**2-p(ns+7,2)**2-
12478  +p(ns+7,3)**2)
12479  n=ns+7
12480 C CALL GULIST(103,2)
12481 
12482 C...SCALE FOR BREMSSTRAHLUNG ETC.
12483  q2py=q2
12484  ipy(40)=10
12485  ipy(47)=n
12486 C...SAVE QUANTITIES FOR LATER USE.
12487  xpy(1)=1.
12488  xpy(2)=xr
12489  CALL pystfu(k(2,2),xr,q2,xpq)
12490  DO 80 ifl=-6,6
12491  80 xqpy(2,ifl)=xpq(ifl)
12492  IF(lst(23).EQ.1) THEN
12493  isub=39
12494  ipy(11)=1
12495  ELSEIF(lst(23).EQ.3) THEN
12496  isub=39
12497  ipy(11)=2
12498  ELSEIF(lst(23).EQ.4) THEN
12499  isub=39
12500  ipy(11)=3
12501  ELSEIF(lst(23).EQ.2) THEN
12502  isub=40
12503  ENDIF
12504  IF(isub.EQ.39.AND.ipy(11).EQ.1) THEN
12505  kfl(2,1)=22
12506  ELSEIF(isub.EQ.39.AND.ipy(11).EQ.2) THEN
12507  kfl(2,1)=23
12508  ELSEIF(isub.EQ.39.AND.ipy(11).EQ.3) THEN
12509  kfl(2,1)=23
12510  ELSEIF(isub.EQ.40) THEN
12511  kfl(2,1)=-24
12512  ENDIF
12513  kfl(2,2)=k(6,2)
12514  kfl(1,1)=kfl(2,1)
12515  kfl(1,2)=kfl(2,2)
12516  IF(isub.EQ.39) kfl(3,1)=k(1,2)
12517  IF(isub.EQ.40) kfl(3,1)=k(1,2)+isign(1,k(1,2))
12518  kfl(3,2)=k(27,2)
12519  pyvar(2)=parl(21)
12520  pyvar(1)=sqrt(pyvar(2))
12521  pyvar(3)=p(1,5)
12522  pyvar(4)=p(2,5)
12523  pyvar(5)=pyvar(1)/2.
12524  ipy(41)=k(1,2)
12525  ipy(42)=k(2,2)
12526  ipy(48)=0
12527 
12528 C...GENERATE TIMELIKE PARTON SHOWER (IF REQUIRED)
12529  IF(ipy(13).EQ.1) THEN
12530  CALL lscale(1,qmax)
12531  CALL lushow(25,26,qmax)
12532  ENDIF
12533  it=25
12534  IF(n.GE.27) it=27
12535  ns=n
12536 C CALL GULIST(104,2)
12537 
12538 C...GENERATE SPACELIKE PARTON SHOWER (IF REQUIRED)
12539  ipu1=0
12540  ipu2=23
12541  IF(xpy(2)*(1.+(p(it,5)**2+pypar(22))/p(21,5)**2).GT.0.999) THEN
12542  lst(21)=47
12543  RETURN
12544  ENDIF
12545  IF(ipy(14).GE.1) THEN
12546  CALL pysspb(ipu1,ipu2)
12547  ELSE
12548  DO 90 i=ns+1,ns+4
12549  DO 90 j=1,5
12550  k(i,j)=0
12551  p(i,j)=0.
12552  90 v(i,j)=0.
12553  k(ns+1,1)=11
12554  k(ns+1,2)=kfl(2,1)
12555  k(ns+1,3)=21
12556  DO 100 j=1,5
12557  100 p(ns+1,j)=p(21,j)
12558  k(ns+2,1)=-1
12559  k(ns+2,3)=ns+1
12560  k(ns+3,1)=13
12561  k(ns+3,2)=kfl(2,2)
12562  k(ns+3,3)=23
12563  k(ns+3,4)=23
12564  k(ns+3,5)=23
12565  p(ns+3,3)=(p(it,5)**2+q2)*(p(21,4)-p(21,3))/(2.*q2)
12566  p(ns+3,4)=-p(ns+3,3)
12567  k(ns+4,1)=-1
12568  k(ns+4,3)=ns+3
12569  p(ns+4,3)=23
12570  p(ns+4,4)=23
12571  p(24,1)=ns+3
12572  p(24,2)=ns+3
12573  k(23,4)=k(23,4)+(ns+3)*mstu(5)
12574  k(23,5)=k(23,5)+(ns+3)*mstu(5)
12575  ipu1=0
12576  ipu2=ns+3
12577  n=n+4
12578  ENDIF
12579 C CALL GULIST(105,2)
12580 
12581 C...ROTATE AND BOOST OUTGOING PARTON SHOWER
12582  IF(n.GT.31) THEN
12583  k(n+1,1)=0
12584  DO 110 j=1,4
12585  110 p(n+1,j)=p(ns+1,j)+p(ns+3,j)
12586  IF(p(n+1,4).LE.1.01*p(it,5)) THEN
12587  lst(21)=50
12588  RETURN
12589  ENDIF
12590  robo(1)=ulangl(p(it,3),sqrt(p(it,1)**2+p(it,2)**2))
12591  robo(2)=ulangl(p(it,1),p(it,2))
12592  CALL ludbrb(25,ns,0.,-robo(2),0.d0,0.d0,0.d0)
12593  CALL ludbrb(25,ns,-robo(1),0.,0.d0,0.d0,0.d0)
12594  drobo(5)=-(p(it,3)*p(it,4)-p(n+1,4)*sqrt(p(n+1,4)**2-
12595  + p(it,4)**2+p(it,3)**2))/(p(it,3)**2+p(n+1,4)**2)
12596  CALL ludbrb(25,ns,0.,0.,0.d0,0.d0,drobo(5))
12597  robo(1)=ulangl(p(n+1,3),sqrt(p(n+1,1)**2+p(n+1,2)**2))
12598  robo(2)=ulangl(p(n+1,1),p(n+1,2))
12599  CALL ludbrb(25,ns,robo(1),robo(2),0.d0,0.d0,0.d0)
12600  ENDIF
12601 C CALL GULIST(106,2)
12602 
12603  q2py=q2
12604 C...HADRON REMNANT AND PRIMORDIAL KT
12605  ipy(47)=n
12606  CALL pyremm(ipu1,ipu2)
12607  IF(ipy(48).EQ.1) THEN
12608  lst(21)=48
12609  RETURN
12610  ENDIF
12611 C CALL GULIST(107,2)
12612 
12613 C...REARRANGE PARTONS ALONG STRINGS
12614  mstu(24)=0
12615  CALL luprep(0)
12616  IF(mstu(24).NE.0) THEN
12617 C CALL GULIST(188,2)
12618  IF(lst(3).GE.1) WRITE(6,*) ' LUPREP ERROR MSTU(24)= ',mstu(24)
12619  lst(21)=49
12620  RETURN
12621  ENDIF
12622 C CALL GULIST(109,2)
12623 
12624 C...CLEAN UP EVENT RECORD -> ORDER:
12625 C...1=INC. LEPTON; 2=INC. NUCLEON; 3=EXCH BOSON; 4=SCAT. LEPTON;
12626 C...5=INC. PARTON BEFORE INITIAL SHOWER; 6=INC. PARTON AT HARD SCATTERING
12627 C...AFTER SHOWER; 7,8=FIRST,SECOND PARTON FROM HARD SCATTERING
12628 C...BEFORE FINAL SHOWER
12629  lst(26)=7
12630  DO 120 j=1,5
12631  k(n+1,j)=k(4,j)
12632  120 p(n+1,j)=p(4,j)
12633  DO 130 j=1,5
12634  k(3,j)=k(5,j)
12635  p(3,j)=p(5,j)
12636  k(4,j)=k(9,j)
12637  p(4,j)=p(9,j)
12638  k(5,j)=k(n+1,j)
12639  p(5,j)=p(n+1,j)
12640  k(6,j)=k(ns+3,j)
12641  p(6,j)=p(ns+3,j)
12642 C K(7,J)=K(IT,J)
12643 C P(7,J)=P(IT,J)
12644  k(7,j)=k(25,j)
12645  p(7,j)=p(25,j)
12646  k(8,j)=k(26,j)
12647  p(8,j)=p(26,j)
12648  130 CONTINUE
12649  k(3,3)=1
12650  k(4,3)=1
12651  k(6,1)=21
12652  k(6,3)=5
12653  k(6,4)=0
12654  k(6,5)=0
12655  k(7,1)=21
12656  k(7,3)=6
12657  k(7,4)=0
12658  k(7,5)=0
12659  k(8,1)=21
12660  k(8,3)=6
12661  k(8,4)=0
12662  k(8,5)=0
12663 C...ACTIVATE LINE WITH SCATTERED LEPTON.
12664  k(4,1)=1
12665 C...DEACTIVATE OBSOLETE LINES 9, 10, 21, NS+1 (EXTRA LINES WITH BOSON)
12666  k(9,1)=0
12667  k(10,1)=0
12668  k(21,1)=0
12669  IF(k(ns+1,2).EQ.k(3,2)) k(ns+1,1)=0
12670 C...ZERO IRRELEVANT LINES WITH K(I,1)<0
12671  DO 150 i=1,n
12672  IF(k(i,1).LT.0) THEN
12673  DO 140 j=1,5
12674  k(i,j)=0
12675  140 p(i,j)=0.
12676  ENDIF
12677  150 CONTINUE
12678 C CALL GULIST(110,2)
12679 C...DELETE INTERNAL PARTON LINES, I.E. WITH K(I,1)=13,14
12680  IF(mod(lst(4)/10,10).EQ.0) THEN
12681  CALL ltimex(t1)
12682  CALL luedit(14)
12683  CALL ltimex(t2)
12684 C CALL GULIST(111,2)
12685  ENDIF
12686 C...DELETE EMPTY LINES
12687  CALL ltimex(t1)
12688  CALL luedit(12)
12689  CALL ltimex(t2)
12690 C CALL GULIST(112,2)
12691 
12692  RETURN
12693  END
12694 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
12695 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
12696 *CMZ : 1.01/01 20/09/94 14.38.50 BY PIERO ZUCCHELLI
12697 *CMZ : 1.00/00 04/07/94 15.02.28 BY PIERO ZUCCHELLI
12698 *-- AUTHOR :
12699 C **********************************************************************
12700 
12701  SUBROUTINE lmidat
12702 
12703 C...THIS IS THE MINUIT ROUTINE MIDATA.
12704 CC GETS PARAMETERS FROM /LMINUI/ AND /LMINUC/
12705 CC AND SETS UP THE STARTING PARAMETER LISTS.
12706 CC CONTROL THEN PASSES TO LMCMND FOR READING THE COMMAND "CARDS".
12707 CC
12708 
12709  COMMON
12710  +/lmmine/ erp(30) ,ern(30)
12711  +/lmpari/ x(15) ,xt(15) ,dirin(15) ,maxint ,npar
12712  +/lmpare/ u(30) ,werr(30) ,maxext ,nu
12713  +/lmlimi/ alim(30) ,blim(30) ,lcode(30) ,lcorsp(30) ,limset
12714  +/lmvari/ v(15,15)
12715  +/lmfix / ipfix(15),xs(15) ,xts(15) ,dirins(15) ,npfix
12716  +/lmfix2/ grds(15) ,g2s(15) ,gsteps(15),aberfs(15)
12717  +/lmcasc/ y(16) ,jh ,jl
12718  +/lmderi/ gin(30) ,grd(15) ,g2(15) ,gstep(15) ,aberf(15)
12719  +/lmsimv/ p(15,16) ,pstar(15),pstst(15) ,pbar(15) ,prho(15)
12720  +/lmvart/ vt(15,15)
12721  COMMON
12722  +/lmunit/ isysrd ,isyswr ,isyspu
12723  +/lmtitl/ title(13),date(2) ,isw(7) ,nblock
12724  +/lmconv/ epsi ,apsi ,vtest ,nstepq ,nfcn ,nfcnmx
12725  +/lmcard/ cword ,cword2 ,cword3 ,word7(7)
12726  +/lmmini/ amin ,up ,newmin ,itaur ,sigma,epsmac
12727  COMMON /lminui/ xkin(4),ukin(4),wkin(4),ain(4),bin(4),
12728  +maxfin,relup,relerr,reler2,fcnmax
12729  COMMON /lminuc/ namkin(4),nam(30)
12730  COMMON /lpflag/ lst3
12731  CHARACTER*10 namkin,nam,namk,blank
12732  CHARACTER xtitle*60
12733  REAL lmpint
12734  DATA blank/' '/
12735  DATA xtitle/' FIND MINIMUM OF -(DIFFERENTIAL CROSS SECTION)'/
12736  DATA mninit/0/,ifatal,nint/0,0/
12737 C . INITIALIZE NEW DATA BLOCK . .
12738 
12739  mninit=0
12740  ifatal=0
12741  nint=0
12742 
12743  IF (mninit .EQ. 0) nblock=0
12744  mninit = 1
12745  nblock = nblock + 1
12746  versn = 11.79
12747  IF(lst3.GE.5) THEN
12748  WRITE (isyswr,10200) maxint,maxext,versn,nblock
12749  WRITE (isyswr,10300)
12750  ENDIF
12751  DO 10 i= 1, 7
12752  10 isw(i) = 0
12753  sigma = 0.
12754  CALL ltimex(time)
12755  IF(lst3.GE.5) THEN
12756  WRITE (isyswr,11200) xtitle,time,epsmac
12757  WRITE (isyswr,10300)
12758  ENDIF
12759  npfix = 0
12760  nint = 0
12761  nu = 0
12762  npar = 0
12763  ifatal = 0
12764  IF(lst3.GE.5) WRITE (isyswr,10300)
12765  DO 20 i= 1, maxext
12766  u(i) = 0.0
12767  nam(i) = blank
12768  erp(i) = 0.0
12769  ern(i) = 0.0
12770  lcode(i) = 0
12771  20 lcorsp(i) = 0
12772  up = 1.0
12773  isw(5) = 1
12774  iunit = isysrd
12775 C . . . READ PARAMETER CARDS . .
12776  entry lmida2
12777  DO 150 i= 1, 200
12778  IF(i.GE.5) goto 160
12779  xk=xkin(i)
12780  namk=namkin(i)
12781  uk=ukin(i)
12782  wk=wkin(i)
12783  a=ain(i)
12784  b=bin(i)
12785  k = xk + 0.1
12786  nu = max0(nu,k)
12787  IF (k .LE. 0) go to 160
12788  IF (k .LE. maxext) go to 30
12789  ifatal = ifatal + 1
12790  IF(lst3.GE.1) THEN
12791  WRITE (isyswr,10700) k,maxext
12792  WRITE (isyswr,10000) k,namk,uk,wk,a,b
12793  ENDIF
12794  go to 150
12795  30 CONTINUE
12796  IF(nam(k).EQ.blank) go to 40
12797 C PREVIOUSLY DEFINED PARAMETER IS BEING REDEFINED
12798  IF(lst3.GE.1) WRITE(isyswr,10500)
12799  IF(werr(k).GT..0) nint=nint-1
12800  40 CONTINUE
12801  nam(k) = namk
12802  u(k) = uk
12803  werr(k) = wk
12804  IF (wk .GT. 0.0) go to 50
12805 C . . . FIXED PARAMETER . . . .
12806  IF(lst3.GE.5) WRITE (isyswr, 10000) k,namk,uk
12807  lcode(k) = 0
12808  go to 140
12809 C . . . VARIABLE PARAMETER . . .
12810  50 IF(lst3.GE.5) WRITE (isyswr, 10000) k,namk,uk,wk,a,b
12811  nint = nint + 1
12812  isw(2) = 0
12813  IF (a) 80 ,60 ,80
12814  60 IF (b) 80 ,70 ,80
12815  70 lcode(k) = 1
12816  go to 140
12817  80 IF (b-a) 100,90 ,110
12818  90 ifatal = ifatal + 1
12819  IF(lst3.GE.1) WRITE (isyswr,10800)
12820  go to 110
12821  100 sav = b
12822  b = a
12823  a = sav
12824  IF(lst3.GE.1) WRITE (isyswr,10100)
12825  110 alim(k) = a
12826  blim(k) = b
12827  lcode(k) = 4
12828  IF ((b-u(k))*(u(k)-a)) 120,130,140
12829  120 ifatal = ifatal + 1
12830  IF(lst3.GE.1) WRITE (isyswr,10900)
12831  go to 140
12832  130 IF(lst3.GE.1) WRITE (isyswr,10400)
12833  140 CONTINUE
12834  150 CONTINUE
12835  ifatal = ifatal + 1
12836  IF(lst3.GE.1) WRITE (isyswr,11000)
12837 C . . . END PARAMETER CARDS
12838 C . . . STOP IF FATAL ERROR
12839  160 IF(lst3.GE.5) WRITE (isyswr,10300)
12840  IF (nint .LE. maxint) go to 170
12841  IF(lst3.GE.1) WRITE (isyswr,10600) nint,maxint
12842  ifatal = ifatal + 1
12843  170 IF (ifatal .LE. 0) go to 180
12844  IF(lst3.GE.1) WRITE (isyswr,11100) ifatal
12845  IF(lst3.GE.2) stop
12846 C CALCULATE STEP SIZES DIRIN
12847  180 npar = 0
12848  DO 190 k= 1, nu
12849  IF (lcode(k) .LE. 0) go to 190
12850  npar = npar + 1
12851  lcorsp(k) = npar
12852  sav = u(k)
12853  x(npar) = lmpint(sav,k)
12854  xt(npar) = x(npar)
12855  sav2 = sav + werr(k)
12856  vplu = lmpint(sav2,k) - x(npar)
12857  sav2 = sav - werr(k)
12858  vminu = lmpint(sav2,k) - x(npar)
12859  dirin(npar) = 0.5 * (abs(vplu) +abs(vminu))
12860  g2(npar) = 2.0 / dirin(npar)**2
12861  gstep(npar) = dirin(npar)
12862  IF (lcode(k) .GT. 1) gstep(npar) = -gstep(npar)
12863  190 CONTINUE
12864  sigma = 1.0e10
12865  iunit = isysrd
12866  RETURN
12867 C... THE FORMAT BELOW IS MACHINE-DEPENDENT. (A10) , (A6,4X) , ETC.
12868 10000 FORMAT (i10,2x,a10,2x,2g12.6,2x,2g12.6)
12869 10100 FORMAT(' WARNING - ABOVE LIMITS HAVE BEEN REVERSED.')
12870 10200 FORMAT (1h1/42x,21(1h*)/42x,21h* d506 minuit */42x,
12871  +12h* dimensions, i3, 1h/, i3, 2h */ 42x,
12872  +'* MODIFICATION OF *',/,42x,
12873  +11h* version ,f6.2,4h */42x,16h* DATA block no. ,i3,2h *)
12874 10300 FORMAT (4x,96(1h*))
12875 10400 FORMAT(' WARNING - ABOVE PARAMETER IS AT LIMIT ')
12876 10500 FORMAT(' WARNING ******* - PARAMETER REQUESTED ON FOLLOWING',
12877  +' CARD HAS ALREADY APPEARED. PREVIOUS VALUES IGNORED.')
12878 10600 FORMAT('0 TOO MANY VARIABLE PARAMETERS. YOU REQUEST',i5/,
12879  +' THIS VERSION OF MINUIT IS ONLY DIMENSIONED FOR',i4//)
12880 10700 FORMAT('0FATAL ERROR. PARAMETER NUMBER',i11,' GREATER THAN ',
12881  +'ALLOWED MAXIMUM',i4)
12882 10800 FORMAT(' FATAL ERROR. UPPER AND LOWER LIMITS ARE EQUAL.')
12883 10900 FORMAT(' FATAL ERROR. PARAMETER OUTSIDE LIMITS',/)
12884 11000 FORMAT('0FATAL ERROR. MORE THAN 200 PARAMETER CARDS',/)
12885 11100 FORMAT(/i5,' FATAL ERRORS ON PARAMETER CARDS. ABORT.',//)
12886 11200 FORMAT(5x,a60,5x,'TIME',f8.3,' SECONDS',/,70x,'MACH. PREC.=',
12887  +e10.2)
12888  END
12889 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
12890 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
12891 *CMZ : 1.00/00 04/07/94 15.02.28 BY PIERO ZUCCHELLI
12892 *-- AUTHOR :
12893 C **********************************************************************
12894 
12895  SUBROUTINE lminew
12896 
12897 C...THIS IS THE MINUIT ROUTINE MINNEW.
12898 CC THIS IS THE MAIN PROGRAM, DISGUISED AS A SUBROUTINE FOR
12899 CC REASONS OF COMPATIBILITY BETWEEN SYSTEMS. IT INITIALIZES
12900 CC SOME CONSTANTS IN COMMON (INCLUDING THE LOGICAL I/O UNIT NOS.)
12901 CC THEN VERIFIES THAT FCN GIVES THE SAME VALUE WHEN CALLED
12902 CC TWICE WITH THE SAME ARGUMENTS, AND PASSES CONTROL TO LMCMND.
12903 CC
12904 
12905  COMMON /lpflag/ lst3
12906  COMMON
12907  +/lmmine/ erp(30) ,ern(30)
12908  +/lmpari/ x(15) ,xt(15) ,dirin(15) ,maxint ,npar
12909  +/lmpare/ u(30) ,werr(30) ,maxext ,nu
12910  +/lmlimi/ alim(30) ,blim(30) ,lcode(30) ,lcorsp(30) ,limset
12911  +/lmvari/ v(15,15)
12912  +/lmfix / ipfix(15),xs(15) ,xts(15) ,dirins(15) ,npfix
12913  +/lmfix2/ grds(15) ,g2s(15) ,gsteps(15),aberfs(15)
12914  +/lmcasc/ y(16) ,jh ,jl
12915  +/lmderi/ gin(30) ,grd(15) ,g2(15) ,gstep(15) ,aberf(15)
12916  +/lmsimv/ p(15,16) ,pstar(15),pstst(15) ,pbar(15) ,prho(15)
12917  +/lmvart/ vt(15,15)
12918  COMMON
12919  +/lmunit/ isysrd ,isyswr ,isyspu
12920  +/lmtitl/ title(13),date(2) ,isw(7) ,nblock
12921  +/lmconv/ epsi ,apsi ,vtest ,nstepq ,nfcn ,nfcnmx
12922  +/lmcard/ cword ,cword2 ,cword3 ,word7(7)
12923  +/lmmini/ amin ,up ,newmin ,itaur ,sigma,epsmac
12924 
12925 C UNIT NUMBERS FOR CARD READER, PRINTER, PUNCH
12926 C
12927  isysrd = 5
12928  isyswr = 6
12929  isyspu = 7
12930  maxint=15
12931  maxext=30
12932 C DETERMINE MACHINE ACCURACY EPSMAC
12933  epsmac = 0.5
12934  DO 10 i= 1, 100
12935  epsmac = epsmac * 0.5
12936  IF ((1.0+epsmac) .EQ. 1.0) go to 20
12937  10 CONTINUE
12938  epsmac = 1.0e-6
12939  20 epsmac = 2.0 * epsmac
12940 C . . . . . . . . .
12941  30 CONTINUE
12942  nfcn = 1
12943  CALL lmidat
12944  CALL lminto(x)
12945  IF(lst3.GE.5) WRITE (isyswr,10000)
12946 10000 FORMAT (/,'0FIRST ENTRY TO FCN ')
12947  CALL lsigmx(npar,gin,amin,u,1)
12948  CALL lsigmx(npar,gin,amin,u,4)
12949  CALL lmprin(1,amin)
12950  CALL lsigmx(npar,gin,f ,u,4)
12951  IF (f .NE. amin) go to 40
12952  nfcn = 3
12953  CALL lmcmnd
12954  RETURN
12955  40 CONTINUE
12956  IF(lst3.GE.1) WRITE (isyswr,10100) amin, f
12957  IF(lst3.GE.2) stop
12958 10100 FORMAT('0FOR THE ABOVE VALUES OF THE PARAMETERS, FCN IS TIME-',
12959  +'DEPENDENT',/,'0F = ',e22.14,' FOR FIRST CALL',/,' F =',e22.14,
12960  +' FOR SECOND')
12961  END
12962 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
12963 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
12964 *CMZ : 1.00/00 04/07/94 15.02.28 BY PIERO ZUCCHELLI
12965 *-- AUTHOR :
12966 C **********************************************************************
12967 
12968  SUBROUTINE lminto(PINT)
12969 
12970 C...THIS IS THE MINUIT ROUTINE INTOEX.
12971 CC TRANSFORMS FROM INTERNAL COORDINATES (PINT) TO EXTERNAL
12972 CC PARAMETERS (U). THE MINIMIZING ROUTINES WHICH WORK IN
12973 CC INTERNAL COORDINATES CALL THIS ROUTINE BEFORE CALLING FCN.
12974 
12975  COMMON
12976  +/lmmine/ erp(30) ,ern(30)
12977  +/lmpari/ x(15) ,xt(15) ,dirin(15) ,maxint ,npar
12978  +/lmpare/ u(30) ,werr(30) ,maxext ,nu
12979  +/lmlimi/ alim(30) ,blim(30) ,lcode(30) ,lcorsp(30) ,limset
12980  +/lmvari/ v(15,15)
12981  +/lmfix / ipfix(15),xs(15) ,xts(15) ,dirins(15) ,npfix
12982  +/lmfix2/ grds(15) ,g2s(15) ,gsteps(15),aberfs(15)
12983  +/lmcasc/ y(16) ,jh ,jl
12984  +/lmderi/ gin(30) ,grd(15) ,g2(15) ,gstep(15) ,aberf(15)
12985  +/lmsimv/ p(15,16) ,pstar(15),pstst(15) ,pbar(15) ,prho(15)
12986  +/lmvart/ vt(15,15)
12987  COMMON
12988  +/lmunit/ isysrd ,isyswr ,isyspu
12989  +/lmtitl/ title(13),date(2) ,isw(7) ,nblock
12990  +/lmconv/ epsi ,apsi ,vtest ,nstepq ,nfcn ,nfcnmx
12991  +/lmcard/ cword ,cword2 ,cword3 ,word7(7)
12992  +/lmmini/ amin ,up ,newmin ,itaur ,sigma,epsmac
12993 
12994  dimension pint(2)
12995  DO 30 i= 1, nu
12996  j = lcorsp(i)
12997  IF ( j ) 30 ,30 ,10
12998  10 CONTINUE
12999  IF (lcode(i) .EQ. 1) go to 20
13000  al = alim(i)
13001  u(i) = al + 0.5 *(sin(pint(j)) +1.0) * (blim(i) -al)
13002  go to 30
13003  20 u(i) = pint(j)
13004  30 CONTINUE
13005  RETURN
13006  END
13007 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
13008 *CMZ : 1.00/00 04/07/94 15.02.28 BY PIERO ZUCCHELLI
13009 *-- AUTHOR :
13010 C **********************************************************************
13011 
13012  REAL FUNCTION lmpint(PEXTI,I)
13013 
13014 C...THIS IS THE MINUIT ROUTINE PINTF.
13015 CC CALCULATES THE INTERNAL PARAMETER VALUE LMPINT CORRESPONDING
13016 CC TO THE EXTERNAL VALUE PEXTI FOR PARAMETER I.
13017 CC
13018  COMMON
13019  1/lmmine/ erp(30) ,ern(30)
13020  2/lmpari/ x(15) ,xt(15) ,dirin(15) ,maxint ,npar
13021  3/lmpare/ u(30) ,werr(30) ,maxext ,nu
13022  4/lmlimi/ alim(30) ,blim(30) ,lcode(30) ,lcorsp(30) ,limset
13023  5/lmvari/ v(15,15)
13024  7/lmfix / ipfix(15),xs(15) ,xts(15) ,dirins(15) ,npfix
13025  7/lmfix2/ grds(15) ,g2s(15) ,gsteps(15),aberfs(15)
13026  c/lmcasc/ y(16) ,jh ,jl
13027  f/lmderi/ gin(30) ,grd(15) ,g2(15) ,gstep(15) ,aberf(15)
13028  g/lmsimv/ p(15,16) ,pstar(15),pstst(15) ,pbar(15) ,prho(15)
13029  j/lmvart/ vt(15,15)
13030  COMMON
13031  6/lmunit/ isysrd ,isyswr ,isyspu
13032  8/lmtitl/ title(13),date(2) ,isw(7) ,nblock
13033  9/lmconv/ epsi ,apsi ,vtest ,nstepq ,nfcn ,nfcnmx
13034  a/lmcard/ cword ,cword2 ,cword3 ,word7(7)
13035  b/lmmini/ amin ,up ,newmin ,itaur ,sigma,epsmac
13036  COMMON /lpflag/ lst3
13037  DATA big, small / 1.570796326795 , -1.570796326795 /
13038  igo = lcode(i)
13039  go to(10 ,20 ,30 ,40 ),igo
13040 C-- IGO = 1 MEANS NO LIMITS
13041  10 lmpint = pexti
13042  go to 120
13043  20 CONTINUE
13044  30 CONTINUE
13045 C-- IGO = 4 MEANS THERE ARE TWO LIMITS
13046  40 alimi = alim(i)
13047  blimi = blim(i)
13048  IF (pexti-alimi) 50 ,100,70
13049  50 a = small
13050  60 lmpint = a
13051  pexti = alimi + 0.5* (blimi-alimi) *(sin(a) +1.0)
13052  limset=1
13053  IF(lst3.GE.1) WRITE (isyswr,10000) i
13054  go to 120
13055  70 IF (blimi-pexti) 80 ,110,90
13056  80 a = big
13057  go to 60
13058  90 yy=2.0*(pexti-alimi)/(blimi-alimi) - 1.0
13059  lmpint = atan(yy/sqrt(1.0- yy**2) )
13060  go to 120
13061  100 lmpint = small
13062  go to 120
13063  110 lmpint = big
13064  120 RETURN
13065 10000 FORMAT(' WARNING - VARIABLE',i3,' HAS BEEN BROUGHT BACK IN',
13066  +'SIDE LIMITS BY LMPINT.')
13067  END
13068 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
13069 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
13070 *CMZ : 1.00/00 04/07/94 15.02.28 BY PIERO ZUCCHELLI
13071 *-- AUTHOR :
13072 C **********************************************************************
13073 
13074  SUBROUTINE lmprin (IKODE,FVAL)
13075 
13076 C...THIS IS THE MINUIT ROUTINE MPRINT.
13077 CC PRINTS THE VALUES OF THE PARAMETERS AT THE TIME OF THE CALL.
13078 CC ALSO PRINTS OTHER RELEVANT INFORMATION SUCH AS FUNCTION VALUE,
13079 CC ESTIMATED DISTANCE TO MINIMUM, PARAMETER ERRORS, STEP SIZES.
13080 CC ACCORDING TO THE VALUE OF IKODE,THE PRINTOUT IS LONG FORMAT,
13081 CC SHORT FORMAT, OR MINOS FORMAT (0,1,2)
13082 CC
13083 
13084  COMMON
13085  +/lmmine/ erp(30) ,ern(30)
13086  +/lmpari/ x(15) ,xt(15) ,dirin(15) ,maxint ,npar
13087  +/lmpare/ u(30) ,werr(30) ,maxext ,nu
13088  +/lmlimi/ alim(30) ,blim(30) ,lcode(30) ,lcorsp(30) ,limset
13089  +/lmvari/ v(15,15)
13090  +/lmfix / ipfix(15),xs(15) ,xts(15) ,dirins(15) ,npfix
13091  +/lmfix2/ grds(15) ,g2s(15) ,gsteps(15),aberfs(15)
13092  +/lmcasc/ y(16) ,jh ,jl
13093  +/lmderi/ gin(30) ,grd(15) ,g2(15) ,gstep(15) ,aberf(15)
13094  +/lmsimv/ p(15,16) ,pstar(15),pstst(15) ,pbar(15) ,prho(15)
13095  +/lmvart/ vt(15,15)
13096  COMMON
13097  +/lmunit/ isysrd ,isyswr ,isyspu
13098  +/lmtitl/ title(13),date(2) ,isw(7) ,nblock
13099  +/lmconv/ epsi ,apsi ,vtest ,nstepq ,nfcn ,nfcnmx
13100  +/lmcard/ cword ,cword2 ,cword3 ,word7(7)
13101  +/lmmini/ amin ,up ,newmin ,itaur ,sigma,epsmac
13102  COMMON /lminuc/ namkin(4),nam(30)
13103  COMMON /lpflag/ lst3
13104  CHARACTER*10 namkin,nam
13105 C . GET TIME AND PRINT HEADINGS .
13106  CALL ltimex(ti)
13107  IF(lst3.GE.5) WRITE (isyswr,10000)
13108  e = sigma
13109  kount = 0
13110 C . . . LOOP OVER PARAMETERS . .
13111  DO 110 i= 1, nu
13112  IF(nam(i).EQ.' ') goto 110
13113  10 l = lcorsp(i)
13114  IF (l .EQ. 0) go to 80
13115 C VARIABLE PARAMETER. CALCULATE EXTERNAL ERROR IF V EXISTS
13116  IF (isw(2) .LT. 1) go to 30
13117  dx = sqrt(abs(v(l,l)*up))
13118  IF (lcode(i) .LE. 1) go to 20
13119  al = alim(i)
13120  ba = blim(i) - al
13121  du1 = al + 0.5 *(sin(x(l)+dx) +1.0) * ba - u(i)
13122  du2 = al + 0.5 *(sin(x(l)-dx) +1.0) * ba - u(i)
13123  IF (dx .GT. 1.0) du1 = ba
13124  dx = 0.5 * (abs(du1) + abs(du2))
13125  20 werr(i) = dx
13126  30 x1 = x(l)
13127  x2 = dirin(l)
13128  IF (ikode .LT. 2) go to 40
13129  x1 = erp(i)
13130  x2 = ern(i)
13131  40 IF (kount) 50,50,60
13132  50 kount = 1
13133  IF(lst3.GE.5) WRITE (isyswr,10100) fval,nfcn,ti,e, l,i,nam(i),
13134  + u(i),werr(i),x1,x2
13135  go to 70
13136  60 IF(lst3.GE.5) WRITE (isyswr,10200) l,i,nam(i),u(i),werr(i),x1,
13137  + x2
13138  70 IF (lcode(i) .LE. 1) go to 110
13139  IF(lst3.GE.1.AND. abs(cos(x(l))) .LT. 0.001) WRITE (isyswr,
13140  + 10400)
13141  go to 110
13142 C FIXED PARAMETER. PRINT ONLY IF IKODE .GT.0
13143  80 IF (ikode .EQ. 0) go to 110
13144  IF (kount) 90,90,100
13145  90 kount = 1
13146  IF(lst3.GE.5) WRITE (isyswr,10100) fval,nfcn,ti,e, l,i,nam(i),
13147  + u(i)
13148  go to 110
13149  100 IF(lst3.GE.5) WRITE (isyswr,10300) i,nam(i),u(i)
13150  110 CONTINUE
13151  IF(lst3.GE.5.AND. ikode.GE.1 .AND.isw(2).GE.1) WRITE (isyswr,
13152  +10500) up
13153  RETURN
13154 10000 FORMAT(/ 4x,'FCN VALUE',5x,'CALLS',4x,'TIME',4x,' EDM ',4x ,
13155  +'INT.EXT. PARAMETER VALUE ERROR INTERN.VALUE ',
13156  +'INT.STEP SIZE')
13157 10100 FORMAT(e15.7,i7,f9.2,e11.2,i6,i4,1x,a10,4e14.5)
13158 10200 FORMAT(1h ,41x,i6,i4,1x,a10,4e14.5)
13159 10300 FORMAT(1h ,47x ,i4,1x,a10,4e14.5)
13160 10400 FORMAT(1h ,52x ,'WARNING - - ABOVE PARAMETER IS AT LIMIT.')
13161 10500 FORMAT(/45x,'ERRORS CORRESPOND TO FUNCTION CHANGE OF ',e12.4)
13162  END
13163 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
13164 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
13165 *CMZ : 1.01/01 12/09/94 16.18.19 BY PIERO ZUCCHELLI
13166 *CMZ : 1.00/00 04/07/94 15.02.28 BY PIERO ZUCCHELLI
13167 *-- AUTHOR :
13168 C **********************************************************************
13169 
13170  SUBROUTINE lmrazz(YNEW,PNEW)
13171 
13172 C...THIS IS THE MINUIT ROUTINE RAZZIA.
13173 CC CALLED ONLY BY SIMPLEX (AND IMPROV) TO ADD A NEW POINT
13174 CC AND REMOVE AN OLD ONE FROM THE CURRENT SIMPLEX, AND GET THE
13175 CC ESTIMATED DISTANCE TO MINIMUM.
13176 CC
13177  COMMON
13178  +/lmmine/ erp(30) ,ern(30)
13179  +/lmpari/ x(15) ,xt(15) ,dirin(15) ,maxint ,npar
13180  +/lmpare/ u(30) ,werr(30) ,maxext ,nu
13181  +/lmlimi/ alim(30) ,blim(30) ,lcode(30) ,lcorsp(30) ,limset
13182  +/lmvari/ v(15,15)
13183  +/lmfix / ipfix(15),xs(15) ,xts(15) ,dirins(15) ,npfix
13184  +/lmfix2/ grds(15) ,g2s(15) ,gsteps(15),aberfs(15)
13185  +/lmcasc/ y(16) ,jh ,jl
13186  +/lmderi/ gin(30) ,grd(15) ,g2(15) ,gstep(15) ,aberf(15)
13187  +/lmsimv/ p(15,16) ,pstar(15),pstst(15) ,pbar(15) ,prho(15)
13188  +/lmvart/ vt(15,15)
13189  COMMON
13190  +/lmunit/ isysrd ,isyswr ,isyspu
13191  +/lmtitl/ title(13),date(2) ,isw(7) ,nblock
13192  +/lmconv/ epsi ,apsi ,vtest ,nstepq ,nfcn ,nfcnmx
13193  +/lmcard/ cword ,cword2 ,cword3 ,word7(7)
13194  +/lmmini/ amin ,up ,newmin ,itaur ,sigma,epsmac
13195  COMMON /lpflag/ lst3
13196  dimension pnew(15)
13197  DO 10 i=1,npar
13198  10 p(i,jh)=pnew(i)
13199  y(jh)=ynew
13200  IF(ynew.GE.amin) go to 30
13201  DO 20 i=1,npar
13202  20 x(i)=pnew(i)
13203  CALL lminto(x)
13204  amin=ynew
13205  jl=jh
13206  30 CONTINUE
13207  jh=1
13208  nparp1=npar+1
13209  40 DO 50 j=2,nparp1
13210  IF (y(j) .GT. y(jh)) jh = j
13211  50 CONTINUE
13212  sigma = y(jh) - y(jl)
13213  IF (sigma .LE. 0.) go to 90
13214  us = 1.0/sigma
13215  DO 70 i= 1, npar
13216  pbig = p(i,1)
13217  plit = pbig
13218  DO 60 j= 2, nparp1
13219  IF (p(i,j) .GT. pbig) pbig = p(i,j)
13220  IF (p(i,j) .LT. plit) plit = p(i,j)
13221  60 CONTINUE
13222  dirin(i) = pbig - plit
13223  IF (itaur .LT. 1 ) v(i,i) = 0.5*(v(i,i) +us*dirin(i)**2)
13224  70 CONTINUE
13225  80 RETURN
13226  90 IF(lst3.GE.1.AND.mod(itoo,10).EQ.0) THEN
13227  WRITE (isyswr, 10000) npar
13228  itoo=itoo+1
13229  ENDIF
13230  go to 80
13231 10000 FORMAT('0***** FUNCTION VALUE DOES NOT SEEM TO DEPEND ON ANY ',
13232  +'OF THE',i3,' VARIABLE PARAMETERS',/15x ,'VERIFY THAT STEP SIZES',
13233  +' ARE BIG ENOUGH AND CHECK FCN LOGIC.',/1x,81(1h*)/1x,81(1h*)//)
13234  END
13235 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
13236 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
13237 *CMZ : 1.01/01 20/09/94 17.12.04 BY PIERO ZUCCHELLI
13238 *CMZ : 1.00/00 04/07/94 15.02.28 BY PIERO ZUCCHELLI
13239 *-- AUTHOR :
13240 C **********************************************************************
13241 
13242  SUBROUTINE lmsimp
13243 
13244 C...THIS IS THE MINUIT ROUTINE SIMPLEX.
13245 CC PERFORMS A MINIMIZATION USING THE SIMPLEX METHOD OF NELDER
13246 CC AND MEAD (REF. -- COMP. J. 7,308 (1965)).
13247  COMMON /lminui/ xkin(4),ukin(4),wkin(4),ain(4),bin(4),
13248  +maxfin,relup,relerr,reler2,fcnmax
13249  COMMON /lpflag/ lst3
13250  COMMON
13251  +/lmmine/ erp(30) ,ern(30)
13252  +/lmpari/ x(15) ,xt(15) ,dirin(15) ,maxint ,npar
13253  +/lmpare/ u(30) ,werr(30) ,maxext ,nu
13254  +/lmlimi/ alim(30) ,blim(30) ,lcode(30) ,lcorsp(30) ,limset
13255  +/lmvari/ v(15,15)
13256  +/lmfix / ipfix(15),xs(15) ,xts(15) ,dirins(15) ,npfix
13257  +/lmfix2/ grds(15) ,g2s(15) ,gsteps(15),aberfs(15)
13258  +/lmcasc/ y(16) ,jh ,jl
13259  +/lmderi/ gin(30) ,grd(15) ,g2(15) ,gstep(15) ,aberf(15)
13260  +/lmsimv/ p(15,16) ,pstar(15),pstst(15) ,pbar(15) ,prho(15)
13261  +/lmvart/ vt(15,15)
13262  COMMON
13263  +/lmunit/ isysrd ,isyswr ,isyspu
13264  +/lmtitl/ title(13),date(2) ,isw(7) ,nblock
13265  +/lmconv/ epsi ,apsi ,vtest ,nstepq ,nfcn ,nfcnmx
13266  +/lmcard/ cword ,cword2 ,cword3 ,word7(7)
13267  +/lmmini/ amin ,up ,newmin ,itaur ,sigma,epsmac
13268 
13269  DATA alpha,beta,gamma,rhomin,rhomax / 1.0, 0.5, 2.0, 4.0, 8.0/
13270  alpha=1.0
13271  beta=0.5
13272  gamma=2.0
13273  rhomin=4.0
13274  rhomax=8.0
13275 
13276  IF (npar .LE. 0) RETURN
13277  npfn=nfcn
13278  nparp1=npar+1
13279  rho1 = 1.0 + alpha
13280  rho2 = rho1 + alpha*gamma
13281  wg = 1.0/float(npar)
13282  iflag=4
13283  IF(lst3.GE.5) WRITE(isyswr,10000) epsi
13284  DO 10 i= 1, npar
13285  IF (isw(2) .GE. 1) dirin(i) = sqrt(v(i,i)*up)
13286  IF (abs(dirin(i)) .LT. 1.0e-10*abs(x(i))) dirin(i)=1.0e-8*x(i)
13287  IF(itaur.LT. 1) v(i,i) = dirin(i)**2/up
13288  10 CONTINUE
13289  IF (itaur .LT. 1) isw(2) = 1
13290 C** CHOOSE THE INITIAL SIMPLEX USING SINGLE-PARAMETER SEARCHES
13291  20 CONTINUE
13292  ynpp1 = amin
13293  jl = nparp1
13294  y(nparp1) = amin
13295  absmin = amin
13296  DO 70 i= 1, npar
13297  aming = amin
13298  pbar(i) = x(i)
13299  bestx = x(i)
13300  kg = 0
13301  ns = 0
13302  nf = 0
13303  30 x(i) = bestx + dirin(i)
13304  CALL lminto(x)
13305  CALL lsigmx(npar,gin, f, u, 4)
13306  nfcn = nfcn + 1
13307  IF (f .LE. aming) go to 40
13308 C FAILURE
13309  IF (kg .EQ. 1) go to 50
13310  kg = -1
13311  nf = nf + 1
13312  dirin(i) = dirin(i) * (-0.4)
13313  IF (nf .LT. 3) go to 30
13314  ns = 6
13315 C SUCCESS
13316  40 bestx = x(i)
13317  dirin(i) = dirin(i) * 3.0
13318  aming = f
13319  kg = 1
13320  ns = ns + 1
13321  IF (ns .LT. 6) go to 30
13322 C LOCAL MINIMUM FOUND IN ITH DIRECTION
13323  50 y(i) = aming
13324  IF (aming .LT. absmin) jl = i
13325  IF (aming .LT. absmin) absmin = aming
13326  x(i) = bestx
13327  DO 60 k= 1, npar
13328  60 p(k,i) = x(k)
13329  70 CONTINUE
13330  jh = nparp1
13331  amin=y(jl)
13332  CALL lmrazz(ynpp1,pbar)
13333  DO 80 i= 1, npar
13334  80 x(i) = p(i,jl)
13335  CALL lminto(x)
13336  DO 90 i=1,npar
13337  90 IF(abs(dirin(i)).LE.abs(epsmac*x(i))) dirin(i)=4.*epsmac*x(i)
13338  IF (isw(5) .GE. 1) CALL lmprin(0,amin)
13339  sigma = sigma * 10.
13340  sig2 = sigma
13341  ncycl=0
13342 C . . . . . START MAIN LOOP
13343  100 CONTINUE
13344 C...CHANGE IN SIMPLX; ERROR REDEFINED FOR SECOND CALL TO LMSIMP.
13345  up=relup*abs(amin)
13346  epsi=relerr*up
13347  IF (sig2 .LT. epsi .AND. sigma.LT.epsi) go to 220
13348  sig2 = sigma
13349  IF ((nfcn-npfn) .GT. nfcnmx) go to 230
13350 C CALCULATE NEW POINT * BY REFLECTION
13351  DO 120 i= 1, npar
13352  pb = 0.
13353  DO 110 j= 1, nparp1
13354  110 pb = pb + wg * p(i,j)
13355  pbar(i) = pb - wg * p(i,jh)
13356  120 pstar(i)=(1.+alpha)*pbar(i)-alpha*p(i,jh)
13357  CALL lminto(pstar)
13358  CALL lsigmx(npar,gin,ystar,u,4)
13359  nfcn=nfcn+1
13360  IF(ystar.GE.amin) go to 190
13361 C POINT * BETTER THAN JL, CALCULATE NEW POINT **
13362  DO 130 i=1,npar
13363  130 pstst(i)=gamma*pstar(i)+(1.-gamma)*pbar(i)
13364  CALL lminto(pstst)
13365  CALL lsigmx(npar,gin,ystst,u,4)
13366  nfcn=nfcn+1
13367 C TRY A PARABOLA THROUGH PH, PSTAR, PSTST. MIN = PRHO
13368  y1 = (ystar-y(jh)) * rho2
13369  y2 = (ystst-y(jh)) * rho1
13370  rho = 0.5 * (rho2*y1 -rho1*y2) / (y1 -y2)
13371  IF (rho .LT. rhomin) go to 160
13372  IF (rho .GT. rhomax) rho = rhomax
13373  DO 140 i= 1, npar
13374  140 prho(i) = rho*pbar(i) + (1.0-rho)*p(i,jh)
13375  CALL lminto(prho)
13376  CALL lsigmx(npar,gin,yrho, u,4)
13377  nfcn = nfcn + 1
13378  IF (yrho .LT. y(jl) .AND. yrho .LT. ystst) go to 150
13379  IF (ystst .LT. y(jl)) go to 170
13380  IF (yrho .GT. y(jl)) go to 160
13381 C ACCEPT MINIMUM POINT OF PARABOLA, PRHO
13382  150 CALL lmrazz(yrho,prho)
13383  go to 180
13384  160 IF (ystst .LT. y(jl)) go to 170
13385  CALL lmrazz(ystar,pstar)
13386  go to 180
13387  170 CALL lmrazz(ystst,pstst)
13388  180 ncycl=ncycl+1
13389  IF (isw(5) .LT. 2) go to 100
13390  IF (isw(5) .GE. 3 .OR. mod(ncycl, 10) .EQ. 0) CALL lmprin(0,amin)
13391  go to 100
13392 C POINT * IS NOT AS GOOD AS JL
13393  190 IF (ystar .GE. y(jh)) go to 200
13394  jhold = jh
13395  CALL lmrazz(ystar,pstar)
13396  IF (jhold .NE. jh) go to 100
13397 C CALCULATE NEW POINT **
13398  200 DO 210 i=1,npar
13399  210 pstst(i)=beta*p(i,jh)+(1.-beta)*pbar(i)
13400  CALL lminto(pstst)
13401  CALL lsigmx(npar,gin,ystst,u,4)
13402  nfcn=nfcn+1
13403  IF(ystst.GT.y(jh)) go to 20
13404 C POINT ** IS BETTER THAN JH
13405  IF (ystst .LT. amin) go to 170
13406  CALL lmrazz(ystst,pstst)
13407  go to 100
13408 C . . . . . . END MAIN LOOP
13409  220 IF(lst3.GE.5) WRITE(isyswr,10100)
13410  go to 240
13411  230 IF(lst3.GE.5) WRITE(isyswr,10200)
13412  isw(1) = 1
13413  240 DO 260 i=1,npar
13414  pb = 0.
13415  DO 250 j=1,nparp1
13416  250 pb = pb + wg * p(i,j)
13417  260 pbar(i) = pb - wg * p(i,jh)
13418  CALL lminto(pbar)
13419  CALL lsigmx(npar,gin,ypbar,u,iflag)
13420  nfcn=nfcn+1
13421  IF (ypbar .LT. amin) CALL lmrazz(ypbar,pbar)
13422  CALL lminto(x)
13423  IF (nfcnmx+npfn-nfcn .LT. 3*npar) go to 270
13424  IF (sigma .GT. 2.0*epsi) go to 20
13425  270 CALL lmprin(1-itaur, amin)
13426  RETURN
13427 10000 FORMAT(' START SIMPLEX MINIMIZATION ',8x ,'CON',
13428  +.LT.'VERGENCE CRITERION -- ESTIMATED DISTANCE TO MINIMUM (EDM) ',
13429  +e10.2 )
13430 10100 FORMAT(1h ,'SIMPLEX MINIMIZATION HAS CONVERGED')
13431 10200 FORMAT(1h ,'SIMPLEX TERMINATES WITHOUT CONVERGENCE')
13432  END
13433 *CMZ : 1.00/00 04/07/94 15.02.28 BY PIERO ZUCCHELLI
13434 *-- AUTHOR :
13435 C######################################################################
13436 C
13437 C VARIOUS ROUTINES TO GIVE STRUCTURE FUNCTION PARAMETRIZATIONS.
13438 C ALL BUT LNSTRF CAN BE USED SEPARATELY WITHOUT INITIALIZATION.
13439 C
13440 C ********************************************************************
13441 
13442  SUBROUTINE lnstrf(X,Q2,XPQ)
13443 
13444 C...STRUCTURE FUNCTION PER NUCLEON FOR A PROTON/NEUTRON MIXTURE
13445 C...ACCORDING TO DEFINED NUCLEUS.
13446 
13447  COMMON /linter/ pari(40),ewqc(2,2,8),qc(8),zl(2,4),zq(2,8),pq(17)
13448  dimension xpq(-6:6)
13449 
13450  CALL pystfu(2212,x,q2,xpq)
13451 
13452  IF(pari(11).LE.1.e-06) RETURN
13453  xdv=xpq(1)-xpq(-1)
13454  xuv=xpq(2)-xpq(-2)
13455 C...FOR NUCLEAR TARGET, MIX U- AND D-VALENCE DISTRIBUTIONS.
13456  xpq(1)=(1.-pari(11))*xdv+pari(11)*xuv + xpq(-1)
13457  xpq(2)=(1.-pari(11))*xuv+pari(11)*xdv + xpq(-2)
13458 C...SAVE D AND U VALENCE IN PROTON
13459  pari(12)=xdv
13460  pari(13)=xuv
13461 
13462  RETURN
13463  END
13464 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
13465 *-- AUTHOR :
13466 C **********************************************************************
13467 
13468  SUBROUTINE lprikt(S,PT,PHI)
13469 
13470 C...SIZE (PT) AND AZIMUTHAL ANGLE (PHI) OF PRIMORDIAL KT ACCORDING
13471 C...TO A GAUSSIAN DISTRIBUTION.
13472 
13473  pt=s*sqrt(-alog(rlu(0)))
13474  phi=6.2832*rlu(0)
13475  RETURN
13476  END
13477 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
13478 *CMZ : 1.01/08 05/03/95 11.39.25 BY PIERO ZUCCHELLI
13479 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
13480 *-- AUTHOR :
13481 C **********************************************************************
13482 
13483  SUBROUTINE lprwts(NSTEP)
13484 
13485 C...PRINTS PROBABILITIES FOR Q-, QG- AND QQBAR-EVENTS USING THE PRESENT
13486 C...QCD WEIGHTS STORED IN COMMON BLOCK LGRID.
13487 
13488  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
13489  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
13490  COMMON /linter/ pari(40),ewqc(2,2,8),qc(8),zl(2,4),zq(2,8),pq(17)
13491  COMMON /lgrid/ nxx,nww,xx(20),ww(15),pqg(20,15,3),pqqb(20,15,2),
13492  +qgmax(20,15,3),qqbmax(20,15,2),ycut(20,15),xtot(20,15),np
13493  COMMON /lintrl/ psave(3,4,5),ksave(4),xmin,xmax,ymin,ymax,
13494  +q2min,q2max,w2min,w2max,ilep,inu,ig,iz
13495 
13496  wmax=sqrt(parl(21)+psave(3,1,5)**2+psave(3,2,5)**2)
13497  WRITE(6,10000) parl(11),lst(13),mstu(112),paru(112), parl(8),
13498  +parl(9),parl(12),parl(13)
13499  IF(np.EQ.1) THEN
13500  WRITE(6,10100)
13501  ELSE
13502  WRITE(6,10200)
13503  ENDIF
13504  WRITE(6,10300) lst(19),nww,nxx,ww,xx
13505  IF(wmax.GT.ww(nww)) WRITE(6,10400) wmax,ww(nww)
13506  WRITE(6,10500)
13507 
13508  lw=0
13509  DO 30 iw=1,nww,max(1,nstep)
13510  w=ww(iw)
13511  IF(lw.GT.0) goto 40
13512  IF(w.GT.wmax) lw=lw+1
13513  w2=w**2
13514  lx=0
13515  DO 20 ix=1,nxx,max(1,nstep)
13516  x=xx(ix)
13517  IF(lx.GT.0) goto 30
13518  u=(w2-psave(3,2,5)**2)/(2.*psave(3,2,5)*(1.-x))
13519  q2=2.*psave(3,2,5)*u*x
13520  y=q2/(parl(21)*x)
13521  pari(24)=(1.+(1.-y)**2)/2.
13522  pari(25)=1.-y
13523  pari(26)=(1.-(1.-y)**2)/2.
13524  parl(25)=ulalps(q2)
13525  IF(y.GT.1.) lx=lx+1
13526  rqg=0.
13527  rqqb=0.
13528  DO 10 ip=1,np
13529  IF(np.EQ.1) THEN
13530  rqg=pqg(ix,iw,ip)
13531  rqqb=pqqb(ix,iw,ip)
13532  ELSE
13533  rqg=rqg+pqg(ix,iw,ip)*pari(23+ip)/xtot(ix,iw)
13534  IF(ip.LT.3) rqqb=rqqb+pqqb(ix,iw,ip)*pari(23+ip)/xtot(ix,
13535  + iw)
13536  ENDIF
13537  10 CONTINUE
13538 C...INCLUDE ALPHA-STRONG IN WEIGHT.
13539  rqg=rqg*parl(25)
13540  rqqb=rqqb*parl(25)
13541  IF(lst(39).EQ.-91) THEN
13542 C...INCLUDE 3-JET CROSS SECTION IN DENOMINATOR
13543  qtot=1.+rqg+rqqb
13544  rqg =rqg/qtot
13545  rqqb=rqqb/qtot
13546  ENDIF
13547  rq=1.-rqg-rqqb
13548  WRITE(6,10600) w,x,y,q2,parl(25),ycut(ix,iw),rq,rqg,rqqb
13549  20 CONTINUE
13550  30 CONTINUE
13551  40 CONTINUE
13552  RETURN
13553 
13554 10000 FORMAT('1',/,5x,'SUMMARY OF QCD MATRIX ELEMENT INTEGRATION',
13555  + /,5x,'-----------------------------------------',//,
13556  +/,' FOR GLUON RADIATION (QG-EVENT) AND BOSON-GLUON FUSION ',
13557  +'(QQ-EVENT) PROBABILITY.',
13558  +//,' REQUIRED PRECISION IN INTEGRATION, PARL(11) =',f8.4,
13559  +//,' HEAVIEST FLAVOUR PRODUCED IN BOSON-GLUON FUSION, LST(13) =',
13560  +i5,//,' ALPHA-STRONG PARAMETERS: # FLAVOURS, MSTU(112) =',i3,
13561  +' QCD LAMBDA, PARU(112) =',f6.3,' GEV',
13562  +//,' CUTS ON MATRIX ELEMENTS:',
13563  +/,' PARL(8), PARL(9), PARL(12), PARL(13) =',4f8.4,/)
13564 10100 FORMAT(' LEPTON ENERGY NOT ALLOWED TO VARY IN SIMULATION.',/)
13565 10200 FORMAT(' LEPTON ENERGY ALLOWED TO VARY IN SIMULATION, ',/,
13566  +' Y IN TABLE BELOW CALCULATED ASSUMING MAX ENERGY.',/)
13567 10300 FORMAT(' GRID CHOICE, LST(19) =',i3,5x,'# GRID POINTS IN W, X =',
13568  +2i5,/,' W-VALUES IN ARRAY WW:',/,10f8.1,/,5f8.1,
13569  +/,' X-VALUES IN ARRAY XX:',/,10f8.4,/,10f8.4,/)
13570 10400 FORMAT(' MAX W OUTSIDE GRID, EXECUTION STOPPED ] WMAX, GRID-MAX ='
13571  +,2f12.1)
13572 10500 FORMAT(//,6x,'W',7x,'X',7x,'Y',8x,'Q**2',3x,'ALPHA',
13573  +5x,'CUT',2x,'Q-EVENT',1x,'QG-EVENT',1x,'QQ-EVENT',
13574  +/,1x,77(1h-),/)
13575 10600 FORMAT(f7.1,2f8.4,1pg12.3,0pf8.2,f8.4,3f9.4)
13576  END
13577 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
13578 *CMZ : 1.01/08 05/03/95 11.39.25 BY PIERO ZUCCHELLI
13579 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
13580 *-- AUTHOR :
13581 C **********************************************************************
13582 
13583  SUBROUTINE lqcdpr(QG,QQB)
13584 
13585 C...PROBABILITIES FOR HARD QCD EVENTS, FOR GIVEN X AND W, ARE OBTAINED
13586 C...BY MAKING A LINEAR INTERPOLATION OF THE VALUES ON THE X-W GRID.
13587 
13588  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
13589  COMMON /linter/ pari(40),ewqc(2,2,8),qc(8),zl(2,4),zq(2,8),pq(17)
13590  COMMON /lgrid/ nxx,nww,xx(20),ww(15),pqg(20,15,3),pqqb(20,15,2),
13591  +qgmax(20,15,3),qqbmax(20,15,2),ycut(20,15),xtot(20,15),np
13592  DATA nout,nabove/2*0/,nwarn/10/
13593 
13594  qg=0.
13595  qqb=0.
13596  w=sqrt(w2)
13597 C...IF W IS VERY SMALL OR X CLOSE TO 1, SET QCD WEIGHTS TO ZERO.
13598  IF(ww(1).LT.6..AND.w.LT.ww(1)) RETURN
13599  IF(x.GT.xx(nxx)) RETURN
13600 
13601  xp=x
13602  IF(x.LT.xx(1).OR.x.GT.xx(nxx).OR.
13603  +w.LT.ww(1).OR.w.GT.ww(nww)) THEN
13604 C...X AND/OR W OUTSIDE LIMITS OF GRID, WRITE WARNING FOR
13605 C...FIRST NWARN CASES.
13606  nout=nout+1
13607  IF(lst(3).GE.1.AND.nout.LE.nwarn) WRITE(6,10000) x,w,
13608  + int(pari(29)),nwarn
13609  IF(x.LT.xx(1)) xp=xx(1)
13610  IF(x.GT.xx(nxx)) xp=xx(nxx)
13611  IF(w.LT.ww(1)) w=ww(1)
13612  IF(w.GT.ww(nww)) w=ww(nww)
13613  ENDIF
13614 
13615  ih=1
13616  IF(lst(30).EQ.1) ih=2
13617  ix=0
13618  10 ix=ix+1
13619  IF(xp.GT.xx(ix+1)) goto 10
13620  iw=0
13621  20 iw=iw+1
13622  IF(w.GT.ww(iw+1)) goto 20
13623  wd=(w-ww(iw))/(ww(iw+1)-ww(iw))
13624  xd=(xp-xx(ix))/(xx(ix+1)-xx(ix))
13625 
13626  DO 30 ip=1,np
13627  x1p=(pqg(ix+1,iw,ip)-pqg(ix,iw,ip))*xd+pqg(ix,iw,ip)
13628  x2p=(pqg(ix+1,iw+1,ip)-pqg(ix,iw+1,ip))*xd+pqg(ix,iw+1,ip)
13629  qgip=(x2p-x1p)*wd+x1p
13630  IF(np.EQ.1) THEN
13631  qg=qgip
13632  pari(15)=max(qgmax(ix,iw,ih),qgmax(ix+1,iw+1,ih), qgmax(ix+1,
13633  + iw,ih),qgmax(ix,iw+1,ih))
13634  ELSE
13635  qg=qg+pari(23+ip)*qgip
13636  pari(14+ip)=max(qgmax(ix,iw,ip),qgmax(ix+1,iw+1,ip), qgmax(ix
13637  + +1,iw,ip),qgmax(ix,iw+1,ip))
13638  ENDIF
13639  IF(ip.EQ.3) goto 30
13640  x1p=(pqqb(ix+1,iw,ip)-pqqb(ix,iw,ip))*xd+pqqb(ix,iw,ip)
13641  x2p=(pqqb(ix+1,iw+1,ip)-pqqb(ix,iw+1,ip))*xd+pqqb(ix,iw+1,ip)
13642  qqbip=(x2p-x1p)*wd+x1p
13643  IF(np.EQ.1) THEN
13644  qqb=qqbip
13645  pari(18)=max(qqbmax(ix,iw,ih),qqbmax(ix+1,iw+1,ih), qqbmax(ix
13646  + +1,iw,ih),qqbmax(ix,iw+1,ih))
13647  ELSE
13648  qqb=qqb+pari(23+ip)*qqbip
13649  pari(17+ip)=max(qqbmax(ix,iw,ip),qqbmax(ix+1,iw+1,ip),
13650  + qqbmax(ix+1,iw,ip),qqbmax(ix,iw+1,ip))
13651  ENDIF
13652  30 CONTINUE
13653 
13654  IF(np.NE.1) THEN
13655 C...GET TOTAL X-SECTION FROM INTERPOLATION TO BE USED FOR NORMALIZATION.
13656  x1p=(xtot(ix+1,iw)-xtot(ix,iw))*xd+xtot(ix,iw)
13657  x2p=(xtot(ix+1,iw+1)-xtot(ix,iw+1))*xd+xtot(ix,iw+1)
13658  pq17=(x2p-x1p)*wd+x1p
13659  qg=qg/pq17
13660  qqb=qqb/pq17
13661  ENDIF
13662 
13663 C...GET VALUE OF Y-CUT, IE MINIMUM SCALED INVARIANT MASS SQUARED.
13664  parl(27)=max(ycut(ix,iw),ycut(ix+1,iw+1),
13665  +ycut(ix+1,iw),ycut(ix,iw+1))
13666 
13667 C...INCLUDE ALPHA-STRONG IN WEIGHT.
13668  qg=qg*parl(25)
13669  qqb=qqb*parl(25)
13670  IF(lst(39).EQ.-91) THEN
13671 C...INCLUDE 3-JET CROSS SECTION IN DENOMINATOR
13672  qtot=1.+qg+qqb
13673  qg =qg/qtot
13674  qqb=qqb/qtot
13675  ENDIF
13676  IF(qg+qqb.GT.1) THEN
13677 C...SUM OF QCD EVENT PROBABILITIES LARGER THAN UNITY, RESCALE TO UNITY
13678 C...AND PRINT WARNING FOR FIRST NWARN CASES.
13679  nabove=nabove+1
13680  IF(lst(3).GE.1.AND.nabove.LE.nwarn) WRITE(6,10100) qg,qqb,x,w,
13681  + int(pari(29)),nwarn
13682  qgqqb=qg+qqb
13683  qg=qg/qgqqb
13684  qqb=qqb/qgqqb
13685  ENDIF
13686 
13687 10000 FORMAT(' WARNING: X=',f7.4,' OR W=',f6.1,' OUTSIDE QCD GRID',
13688  +' IN EVENT NO.',i8,/,10x,
13689  +'WEIGHT ON LIMIT OF GRID USED. ONLY FIRST',i5,' WARNINGS PRINTED')
13690 10100 FORMAT(' WARNING: SUM OF QCD PROBABILITIES LARGER THAN UNITY ',
13691  +' QG, QQB =',2f8.4,/10x,'OCCURS AT X, W =',f8.4,f6.1,
13692  +' IN EVENT NO.',i8,/,10x,
13693  +'WEIGHTS RESCALED TO UNIT SUM. ONLY FIRST',i5,' WARNINGS PRINTED')
13694  RETURN
13695  END
13696 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
13697 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
13698 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
13699 *-- AUTHOR :
13700 C **********************************************************************
13701 
13702  SUBROUTINE lqgev
13703 
13704 C...GENERATE QUARK-GLUON JET EVENT, CHOOSE XP AND ZP ACCORDING TO QCD
13705 C...MATRIX ELEMENTS AND APPLY CUTS FOR SOFT AND COLLINEAR GLUONS.
13706 
13707  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
13708  COMMON /linter/ pari(40),ewqc(2,2,8),qc(8),zl(2,4),zq(2,8),pq(17)
13709  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
13710  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
13711  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
13712 
13713  lst(24)=2
13714  w=sqrt(w2)
13715  j1=mstu(1)
13716  j2=mstu(1)+1
13717  j3=mstu(1)+2
13718  j4=mstu(1)+3
13719 
13720  CALL lxp(xp,ifail)
13721  IF(ifail.NE.0) goto 30
13722 
13723 C...CHOOSE FLAVOUR OF SCATTERED QUARK AND TARGET REMNANT.
13724  10 CALL lflav(ifl,iflr)
13725  IF(lst(21).NE.0) RETURN
13726  CALL lzp(xp,zp,ifail)
13727  IF(ifail.NE.0) goto 30
13728  amifl=ulmass(ifl)
13729  amiflr=ulmass(iflr)
13730 
13731  IF(lst(14).EQ.0.OR.iflr.GT.10
13732  +.OR.(lst(8).GE.2.AND.mod(lst(8),10).NE.9)) THEN
13733  IF(w.LT.amifl+amiflr+parj(32)) goto 30
13734  IF(lqmcut(xp,zp,amifl,0.,amiflr).NE.0) goto 30
13735  CALL lu3ent(j1,ifl,21,iflr,w,pari(21),pari(23))
13736  k(mstu(1)+2,3)=2
13737  CALL lurobo(acos(-p(j3,3)/sqrt(p(j3,3)**2+p(j3,1)**2)),
13738  + 0.,0.,0.,0.)
13739  ELSE
13740 C...TARGET REMNANT IS NOT A SIMPLE DIQUARK, SPECIAL TREATMENT NEEDED.
13741  IF(w.LT.amifl+amiflr+1.+parj(32)) goto 30
13742  IF(lqmcut(xp,zp,amifl,0.,1.).NE.0) goto 30
13743  iflro=iflr
13744  nremh=0
13745  20 nremh=nremh+1
13746  IF(nremh.GT.100) goto 30
13747  CALL lremh(iflro,iflr,k2,xt)
13748  amk2=ulmass(k2)
13749  amiflr=ulmass(iflr)
13750  p(j1,5)=amifl
13751  p(j2,5)=0.
13752  CALL lprikt(parl(14),pt,phi)
13753  pt2=pt**2
13754  tm2k2=amk2**2+pt2
13755  tmiflr=amiflr**2+pt2
13756  p(j3,5)=sqrt(tm2k2/xt+tmiflr/(1.-xt))
13757  IF(lqmcut(xp,zp,amifl,0.,p(j3,5)).NE.0) goto 20
13758  mstu(10)=1
13759  CALL lu3ent(j1,ifl,21,iflr,w,pari(21),pari(23))
13760  k(mstu(1)+2,3)=2
13761  mstu(10)=2
13762  CALL lurobo(acos(-p(j3,3)/sqrt(p(j3,3)**2+p(j3,1)**2)),
13763  + 0.,0.,0.,0.)
13764  epz=p(j3,4)-p(j3,3)
13765  p(j3,1)=pt*cos(phi)
13766  p(j3,2)=pt*sin(phi)
13767  p(j3,3)=-0.5*((1.-xt)*epz-tmiflr/(1.-xt)/epz)
13768  p(j3,4)= 0.5*((1.-xt)*epz+tmiflr/(1.-xt)/epz)
13769  p(j3,5)=amiflr
13770  p(j4,1)=-p(j3,1)
13771  p(j4,2)=-p(j3,2)
13772  p(j4,3)=-0.5*(xt*epz-tm2k2/xt/epz)
13773  p(j4,4)= 0.5*(xt*epz+tm2k2/xt/epz)
13774  p(j4,5)=amk2
13775  k(j4,1)=1
13776  k(j4,2)=k2
13777  k(j4,3)=2
13778  k(j4,4)=0
13779  k(j4,5)=0
13780  n=j4
13781  IF((p(j3,4)+p(j2,4)/2.)**2-(p(j3,1)+p(j2,1)/2.)**2-p(j3,2)**2
13782  + -(p(j3,3)+p(j2,3)/2.)**2.LT.(amiflr+2.5*parj(32))**2) goto 20
13783  ENDIF
13784 
13785  CALL lazimu(xp,zp)
13786  lst(21)=0
13787  RETURN
13788 
13789  30 lst(21)=1
13790  RETURN
13791  END
13792 *CMZ : 1.00/00 24/07/94 15.46.44 BY PIERO ZUCCHELLI
13793 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
13794 *-- AUTHOR :
13795 C **********************************************************************
13796 
13797  SUBROUTINE lqev
13798 
13799 C...GENERATE AN ORDINARY 2-JET EVENT, Q-EVENT.
13800 
13801  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
13802  COMMON /linter/ pari(40),ewqc(2,2,8),qc(8),zl(2,4),zq(2,8),pq(17)
13803  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
13804  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
13805  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
13806 
13807  lst(24)=1
13808  w=sqrt(w2)
13809 
13810 C...CHOOSE FLAVOUR OF SCATTERED QUARK AND TARGET REMNANT.
13811  10 CALL lflav(ifl,iflr)
13812  IF(lst(21).NE.0) goto 10
13813 
13814  goto 20
13815 C...ENTRY USED FOR ARIADNE
13816  entry lqevar(iflar,iflrar)
13817  ifl=iflar
13818  iflr=iflrar
13819  lst(24)=1
13820  w=sqrt(w2)
13821 
13822  20 CONTINUE
13823  IF(lst(14).EQ.0.OR.iflr.GT.10
13824  +.OR.(lst(8).GE.2.AND.mod(lst(8),10).NE.9)) THEN
13825 C...CHECK IF ENERGY IN JET SYSTEM IS ENOUGH FOR FRAGMENTATION.
13826 C...PARJ(32) DEFAULTS TO 1 GEV
13827  IF(w.LT.ulmass(ifl)+ulmass(iflr)+parj(32)) goto 10
13828  CALL lu2ent(mstu(1),ifl,iflr,w)
13829  k(mstu(1)+1,3)=2
13830 * WRITE(*,*)'POPPING LU2ENT'
13831  ELSE
13832 * WRITE(*,*)'REMNANTS TREATEMENT'
13833 C...TARGET REMNANT IS NOT A SIMPLE DIQUARK, SPECIAL TREATMENT NEEDED.
13834  amifl=ulmass(ifl)
13835  IF(w.LT.amifl+ulmass(iflr)+0.9+parj(32)) goto 10
13836  iflro=iflr
13837  nremh=0
13838  30 nremh=nremh+1
13839  IF(nremh.GT.100) goto 40
13840  CALL lremh(iflro,iflr,k2,xt)
13841  amk2=ulmass(k2)
13842  amiflr=ulmass(iflr)
13843 C...GIVE BALANCING PT TO IFLQ AND IFLQQ.
13844  CALL lprikt(parl(14),pt,phi)
13845  pt2=pt**2
13846  tm2k2=amk2**2+pt2
13847  ek2=.5*(xt*w+tm2k2/xt/w)
13848  pzk2=-.5*(xt*w-tm2k2/xt/w)
13849  epz=w-tm2k2/xt/w
13850  wt=(1.-xt)*w*epz-pt2
13851 C...CHECK IF ENERGY IN JET SYSTEM IS ENOUGH FOR FRAGMENTATION.
13852  IF(wt.LT.(amifl+amiflr+parj(32))**2) goto 30
13853  wt=sqrt(wt+pt2)
13854  tmiflr=amiflr**2+pt2
13855  eifl=.5*(wt+(amifl**2-tmiflr)/wt)
13856  eiflr=.5*(wt+(-amifl**2+tmiflr)/wt)
13857  ther=ulangl(-sqrt(eiflr**2-tmiflr),pt)
13858 C...FORM JET SYSTEM.
13859  CALL lu1ent(-mstu(1),ifl,eifl,0.,0.)
13860  CALL lu1ent(mstu(1)+1,iflr,eiflr,ther,phi)
13861  CALL ludbrb(mstu(1),0,0.,0.,0.d0,0.d0,
13862  + (dble(epz)-(1.d0-dble(xt))*dble(w))/
13863  + (dble(epz)+(1.d0-dble(xt))*dble(w)))
13864  thek2=ulangl(pzk2,pt)
13865 C...ADD FORMED "TARGET" PARTICLE.
13866  mstu(10)=1
13867  p(mstu(1)+2,5)=amk2
13868  CALL lu1ent(mstu(1)+2,k2,ek2,thek2,phi+3.1415927)
13869  mstu(10)=2
13870  k(mstu(1)+1,3)=2
13871  k(mstu(1)+2,3)=2
13872  ENDIF
13873 
13874  lst(21)=0
13875  RETURN
13876 
13877  40 lst(21)=1
13878  RETURN
13879  END
13880 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
13881 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
13882 *-- AUTHOR :
13883 C **********************************************************************
13884 
13885  FUNCTION lqmcut(XP,ZP,AM1,AM2,AM3)
13886 
13887 C...APPLY CUTS, IF NECESSARY, ON THE EVENT CONFIGURATION
13888 C...OBTAINED FROM QCD MATRIX ELEMENTS.
13889 
13890  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
13891  COMMON /linter/ pari(40),ewqc(2,2,8),qc(8),zl(2,4),zq(2,8),pq(17)
13892  DATA s12,s23,s13/3*0./
13893 
13894  IF(lst(24).EQ.2) THEN
13895  s12=q2*(1.-xp)/xp
13896  s23=q2*(xp-x)*(1.-zp)/x/xp+am2**2+am3**2
13897  s13=q2*(xp-x)*zp/x/xp+am1**2+am3**2
13898  ELSEIF(lst(24).EQ.3) THEN
13899  s13=q2*(1.-xp)/xp
13900  s23=q2*(xp-x)*(1.-zp)/x/xp+am2**2+am3**2
13901  s12=q2*(xp-x)*zp/x/xp+am1**2+am2**2
13902  IF(s13.LT.(am1+am3)**2) goto 10
13903  ENDIF
13904 
13905  w=sqrt(w2)
13906  x1=1.-(s23-am1**2)/w2
13907  x3=1.-(s12-am3**2)/w2
13908  x2=2.-x1-x3
13909  pari(21)=x1
13910  pari(22)=x2
13911  pari(23)=x3
13912  IF(x1.GT.1..OR.x2.GT.1..OR.x3.GT.1.) goto 10
13913  IF(x1*w/2..LT.am1.OR.x2*w/2..LT.am2.OR.x3*w/2..LT.am3) goto 10
13914  pa1=sqrt((0.5*x1*w)**2-am1**2)
13915  pa2=sqrt((0.5*x2*w)**2-am2**2)
13916  pa3=sqrt((0.5*x3*w)**2-am3**2)
13917  IF(abs((pa3**2-pa1**2-pa2**2)/(2.*pa1*pa2)).GE.1.) goto 10
13918  IF(abs((pa2**2-pa1**2-pa3**2)/(2.*pa1*pa3)).GE.1.) goto 10
13919  lqmcut=0
13920  RETURN
13921 
13922  10 lqmcut=1
13923  RETURN
13924  END
13925 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
13926 *CMZ : 1.01/08 05/03/95 11.39.25 BY PIERO ZUCCHELLI
13927 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
13928 *-- AUTHOR :
13929 C **********************************************************************
13930 
13931  SUBROUTINE lqqbev
13932 
13933 C...GENERATE BOSON-GLUON FUSION EVENT, CHOOSE XP AND ZP ACCORDING TO
13934 C...QCD MATRIX ELEMENTS AND APPLY CUTS FOR SOFTNESS AND COLLINEARNESS.
13935 
13936  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
13937  COMMON /linter/ pari(40),ewqc(2,2,8),qc(8),zl(2,4),zq(2,8),pq(17)
13938  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
13939  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
13940  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
13941 
13942  lst(24)=3
13943  w=sqrt(w2)
13944  j1=mstu(1)
13945  j2=mstu(1)+1
13946  j3=mstu(1)+2
13947  j4=mstu(1)+3
13948 
13949  CALL lxp(xp,ifail)
13950  IF(ifail.NE.0) goto 50
13951 
13952 C...CHOOSE FLAVOUR OF PRODUCED QUARK-ANTIQUARK PAIR.
13953  10 CALL lflav(ifl1,ifl3)
13954  IF(lst(21).NE.0) RETURN
13955  CALL lzp(xp,zp,ifail)
13956  IF(ifail.NE.0) goto 50
13957  ifl1a=iabs(ifl1)
13958  ifl3a=iabs(ifl3)
13959  amifl1=ulmass(ifl1)
13960  amifl3=ulmass(ifl3)
13961 
13962  IF(lst(14).EQ.0.OR.(lst(8).GE.2.AND.mod(lst(8),10).NE.9)) THEN
13963 C...IF BARYON PRODUCTION FROM TARGET REMNANT IS NEGLECTED THE
13964 C...TARGET REMNANT IS APPROXIMATED BY A GLUON.
13965  IF(w.LT.amifl1+amifl3+parj(32)) goto 50
13966  IF(lqmcut(xp,zp,amifl1,0.,amifl3).NE.0) goto 50
13967  CALL lu3ent(j1,ifl1,21,ifl3,w,pari(21),pari(23))
13968  k(mstu(1)+1,3)=2
13969  CALL lurobo(-acos(-p(j2,3)/sqrt(p(j2,3)**2+p(j2,1)**2)),
13970  + 0.,0.,0.,0.)
13971  goto 40
13972  ENDIF
13973 
13974  IF(w.LT.amifl1+amifl3+0.9+2.*parj(32)) goto 50
13975  IF(lqmcut(xp,zp,amifl1,1.,amifl3).NE.0) goto 50
13976  p(j1,5)=amifl1
13977  p(j3,5)=amifl3
13978 C...CHOOSE TARGET VALENCE QUARK/DIQUARK TO FORM JET SYSTEM WITH
13979 C...PRODUCED ANTIQUARK/QUARK.
13980  iflr2=int(1.+lst(22)/3.+rlu(0))
13981  IF(iflr2.EQ.lst(22)) THEN
13982  iflr1=2101
13983  IF(rlu(0).GT.parl(4)) iflr1=2103
13984  ELSE
13985  iflr1=1000*iflr2+100*iflr2+3
13986  ENDIF
13987  iflr2=3-iflr2
13988  amr1=ulmass(iflr1)
13989  amr2=ulmass(iflr2)
13990  nremh=0
13991  20 nremh=nremh+1
13992  IF(nremh.GT.100) goto 50
13993  CALL lremh(0,iflr1,iflr2,xt)
13994  CALL lprikt(parl(14),pt,phi)
13995  pt2=pt**2
13996  tm2r1=amr1**2+pt2
13997  tm2r2=amr2**2+pt2
13998  p(j2,5)=sqrt(tm2r1/(1.-xt)+tm2r2/xt)
13999  IF(lqmcut(xp,zp,amifl1,p(j2,5),amifl3).NE.0) goto 20
14000  mstu(10)=1
14001  CALL lu3ent(j1,ifl1,21,ifl3,w,pari(21),pari(23))
14002  mstu(10)=2
14003  CALL lurobo(-acos(-p(j2,3)/sqrt(p(j2,3)**2+p(j2,1)**2)),
14004  +0.,0.,0.,0.)
14005  epz=p(j2,4)-p(j2,3)
14006  IF(ifl1.GT.0) THEN
14007  ir1=j2
14008  ir2=j4
14009  ELSE
14010  ir1=j4
14011  ir2=j2
14012  ENDIF
14013  p(ir1,1)=pt*cos(phi)
14014  p(ir1,2)=pt*sin(phi)
14015  p(ir1,3)=-0.5*((1.-xt)*epz-tm2r1/(1.-xt)/epz)
14016  p(ir1,4)= 0.5*((1.-xt)*epz+tm2r1/(1.-xt)/epz)
14017  p(ir1,5)=amr1
14018  p(ir2,1)=-p(ir1,1)
14019  p(ir2,2)=-p(ir1,2)
14020  p(ir2,3)=-0.5*(xt*epz-tm2r2/xt/epz)
14021  p(ir2,4)= 0.5*(xt*epz+tm2r2/xt/epz)
14022  p(ir2,5)=amr2
14023  k(ir1,1)=1
14024  k(ir1,2)=iflr1
14025  k(ir2,1)=1
14026  k(ir2,2)=iflr2
14027  k(j3,1)=2
14028  DO 30 i=j1,j4
14029  DO 30 j=3,5
14030  30 k(i,j)=0
14031  n=j4
14032  k(ir1,3)=2
14033  k(ir2,3)=2
14034  IF((p(j1,4)+p(j2,4))**2-(p(j1,1)+p(j2,1))**2-(p(j1,3)+p(j2,3))**2
14035  + -p(j2,2)**2.LT.(p(j1,5)+p(j2,5)+parj(32))**2) goto 20
14036  IF((p(j3,4)+p(j4,4))**2-(p(j3,1)+p(j4,1))**2-(p(j3,3)+p(j4,3))**2
14037  + -p(j4,2)**2.LT.(p(j3,5)+p(j4,5)+parj(32))**2) goto 20
14038 
14039  40 CONTINUE
14040 
14041  CALL lazimu(xp,zp)
14042  lst(21)=0
14043  RETURN
14044 
14045  50 lst(21)=1
14046  RETURN
14047  END
14048 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
14049 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
14050 *-- AUTHOR :
14051 C **********************************************************************
14052 
14053  SUBROUTINE lremh(IFLRO,IFLR,K2,Z)
14054 
14055 C...GIVES FLAVOUR AND ENERGY-MOMENTUM FRACTION Z FOR THE PARTICLE
14056 C...TO BE PRODUCED OUT OF THE TARGET REMNANT WHEN THAT IS NOT A
14057 C...SIMPLE DIQUARK.
14058 
14059  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
14060  COMMON /linter/ pari(40),ewqc(2,2,8),qc(8),zl(2,4),zq(2,8),pq(17)
14061 
14062 C...FLAVOURS FIXED WHEN CALLING FROM PYREMM OR LQQBEV
14063  IF(iflro.EQ.0) goto 20
14064 
14065 C...SPLIT TARGET REMNANT QQQQ -> QQQ + Q OR QQQQBAR -> QQBAR + QQ
14066 C...Q (QBAR) IS THE PARTNER TO THE STRUCK SEA QUARK
14067 C...QQQ ARE THE NUCLEON VALENCE QUARKS FROM WHICH A QUARK Q OR A
14068 C...DIQUARK QQ IS CHOSEN AT RANDOM TO FORM A JET SYSTEM WITH THE
14069 C...SCATTERED SEA ANTIQUARK OR QUARK, RESPECTIVELY, THE OTHER PARTON
14070 C...FORMS A BARYON QQQ OR MESON QQBAR, RESPECTIVELY.
14071  10 iflq=int(1.+lst(22)/3.+rlu(0))
14072  IF(iflq.EQ.lst(22)) THEN
14073  iflqq=2101
14074  IF(rlu(0).GT.parl(4)) iflqq =2103
14075  ELSE
14076  iflqq=1000*iflq+100*iflq+3
14077  ENDIF
14078  iflq=3-iflq
14079 
14080 C...CHOOSE FLAVOUR OF HADRON AND PARTON FOR JET SYSTEM
14081  IF(iflro.GT.0) THEN
14082  CALL lukfdi(iflqq,iflro,idum,k2)
14083  IF(k2.EQ.0) goto 10
14084  iflr=iflq
14085  ELSE
14086  CALL lukfdi(iflq,iflro,idum,k2)
14087  IF(k2.EQ.0) goto 10
14088  iflr=iflqq
14089  ENDIF
14090 
14091 C...ENTRY FOR USE FROM PYSSPB, FLAVOURS GIVEN, CHOOSE E-P FRACTION
14092  20 ksp=iflr
14093 C...SPLIT ENERGY-MOMENTUM OF TARGET REMNANT ACCORDING TO FUNCTIONS P(Z)
14094 C...Z=E-PZ FRACTION FOR QQ (Q) FORMING JET-SYSTEM WITH STRUCK Q (QBAR)
14095 C...1-Z=E-PZ FRACTION FOR QQBAR (QQQ) HADRON
14096 C...MQ=MASS OF (LIGHT) PARTON REMNANT Q (QQ) IN JET SYSTEM
14097 C...MQ=MASS OF PRODUCED (HEAVY FLAVOUR) HADRON
14098  amsp=ulmass(ksp)
14099  amk2=ulmass(k2)
14100 C...OLD LEPTO TREATMENT
14101 C...P(Z)=(A+1)(1-Z)**A WITH <Z>=1/(A+2)=1/3 SINCE A=1 FIXED
14102  z=1.-sqrt(rlu(0))
14103 C...FLIP IF BARYON PRODUCED
14104  kc2=iabs(lucomp(k2))
14105  IF(kc2.GE.301.AND.kc2.LE.400) z=1.-z
14106  IF(lst(14).EQ.2) THEN
14107 C...UPDATE OF LEPTO TREATMENT
14108 C...P(Z)=(A+1)(1-Z)**A WITH <Z>=1/(A+2)=MQ/(MQ+MQ) --> A=A(MQ,MQ)
14109  a=(amsp+amk2)/amsp - 2.
14110  z=rlu(0)**(1./(a+1.))
14111  ELSEIF(lst(14).EQ.3) THEN
14112 C...USING PETERSON FRAGMENTATION FUNCTION
14113 C...P(Z)=N/(Z(1-1/Z-C/(1-Z))**2) WHERE C=(MQ/MQ)**2 (FC=-C)
14114  fc=-(amsp/amk2)**2
14115  30 z=rlu(0)
14116  IF(-4.*fc*z*(1.-z)**2.LT.rlu(0)*((1.-z)**2-fc*z)**2) goto 30
14117  ENDIF
14118  lst(27)=1
14119  k2a=iabs(k2)
14120  IF((k2a.GE.1.AND.k2a.LE.8).OR.k2a.EQ.21.OR.lucomp(k2a).EQ.90)
14121  +lst(27)=2
14122 
14123  RETURN
14124  END
14125 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
14126 *-- AUTHOR :
14127 C **********************************************************************
14128 
14129  SUBROUTINE lscale(INFIN,QMAX)
14130 
14131 C...GIVE MAXIMUM VIRTUALITY OF PARTONS IN PARTON SHOWERS.
14132 
14133  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
14134  COMMON /pypara/ ipy(80),pypar(80),pyvar(80)
14135  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
14136  four(i,j)=p(i,4)*p(j,4)-p(i,1)*p(j,1)-p(i,2)*p(j,2)-p(i,3)*p(j,3)
14137 
14138  qmax=0.1
14139  IF(lst(8).GE.2.AND.lst(8).LE.5) THEN
14140 C...PARTON SHOWERS WITHOUT MATRIX ELEMENTS MATCHING
14141  IF(lst(9).EQ.1) THEN
14142  qmax=q2
14143  ELSEIF(lst(9).EQ.2) THEN
14144  qmax=w2
14145  ELSEIF(lst(9).EQ.3) THEN
14146  qmax=sqrt(w2*q2)
14147  ELSEIF(lst(9).EQ.4) THEN
14148  qmax=q2*(1.-x)
14149  ELSEIF(lst(9).EQ.5) THEN
14150  qmax=q2*(1.-x)*max(1.,log(1./max(1.e-06,x)))
14151  ELSEIF(lst(9).EQ.9) THEN
14152  qmax=w2**(2./3.)
14153  ELSE
14154  WRITE(6,*) ' WARNING, LSCALE: LST(9)=',lst(9),' NOT ALLOWED'
14155  ENDIF
14156  ELSEIF(lst(8).GT.10.AND.lst(24).EQ.1.AND.lst(8).NE.19) THEN
14157 C...PARTON SHOWERS ADDED TO Q-EVENT FROM 1ST ORDER MATRIX ELEMENTS
14158 C...SCALE GIVEN BY Y_CUT*W**2
14159  qmax=parl(27)*w2
14160  ELSEIF(lst(8).GT.10.AND.lst(8).NE.19) THEN
14161 C...PARTON SHOWERS ADDED TO QG-/QQBAR-EVENT FROM 1ST ORDER MATRIX ELEMENTS
14162 C...SCALE GIVEN BY INVARIANT MASS OF FINAL PARTON PAIR
14163  qmax=p(27,5)**2
14164  IF(infin.LT.0) qmax=max(abs(-q2-2.*four(25,21)),
14165  & abs(-q2-2.*four(26,21)))
14166  ENDIF
14167  IF(infin.LT.0) THEN
14168  qmax=sqrt(pypar(26)*qmax)
14169  ELSE
14170  qmax=sqrt(pypar(25)*qmax)
14171  ENDIF
14172 
14173  RETURN
14174  END
14175 *CMZ : 1.02/02 12/01/97 17.48.59 by P. Zucchelli
14176 *CMZ : 1.02/01 12/01/97 16.40.21 by J. Brunner
14177 *CMZ : 1.01/50 22/05/96 12.24.00 by Piero Zucchelli
14178 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
14179 *CMZ : 1.01/08 05/03/95 18.41.15 BY PIERO ZUCCHELLI
14180 *CMZ : 1.01/06 05/03/95 10.59.58 BY PIERO ZUCCHELLI
14181 *CMZ : 1.00/00 28/07/94 17.53.54 BY PIERO ZUCCHELLI
14182 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
14183 *-- AUTHOR :
14184 C#######################################################################
14185 C
14186 C THE FOLLOWING ROUTINES FOR PARTON CASCADES WERE MADE TOGETHER
14187 C WITH M. BENGTSSON AND T. SJOSTRAND (Z. PHYS. C37 (1988) 465,
14188 C NUCL. PHYS. B301 (1988) 554). CONTAIN MODIFICATIONS OF
14189 C ROUTINES IN PYTHIA 4.8 (SJOSTRAND, BENGTSSON, CPC 46 (1987) 43).
14190 C
14191 C **********************************************************************
14192 
14193  SUBROUTINE lshowr(ICALL)
14194 
14195  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
14196  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
14197  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
14198  COMMON /lboost/ dbeta(2,3),stheta(2),sphi(2),pb(5),phir
14199 * ADDED BY ME
14200 * COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14201  COMMON /pypara/ ipy(80),pypar(80),pyvar(80)
14202  COMMON /pyproc/ isub,kfl(3,2),xpy(2),sh,th,uh,q2py,xsec(0:40)
14203  COMMON /pyint1/ xqpy(2,-6:6)
14204 * COMMON/PYINT1/MINT(400),VINT(400)
14205 *KEEP,FOREFI.
14206 C--
14207  INTEGER*4 ievt
14208  common/foreficass/ievt
14209 
14210 
14211 *KEND.
14212 
14213  DOUBLE PRECISION dtheta,dphi,dbeta
14214  DOUBLE PRECISION dpq2,dpb(3),dpa(3),dcthet,drobo(5)
14215  dimension ks(9,5),ps(9,5),robo(5),xpq(-6:6)
14216  SAVE ks,ps
14217  DATA mg/2/
14218  IF(icall.EQ.0) THEN
14219 C...INITIALIZE CASCADE FOR EACH EVENT, SAVE EVENT RECORD IN OVERALL CMS.
14220  DO 10 i=1,9
14221  DO 10 j=1,5
14222  ks(i,j)=0
14223  10 ps(i,j)=0.
14224  DO 20 j=1,5
14225  ks(1,j)=k(1,j)
14226  ps(1,j)=p(1,j)
14227  ks(2,j)=k(2,j)
14228  ps(2,j)=p(2,j)
14229  ks(5,j)=k(3,j)
14230  ps(5,j)=p(3,j)
14231  ks(7,j)=k(4,j)
14232  20 ps(7,j)=p(4,j)
14233  ks(5,3)=3
14234  ks(7,1)=21
14235  ks(7,3)=5
14236 * WRITE(*,*)'LUJET SAVING CALLED'
14237 * CALL LULIST(1)
14238  RETURN
14239  ENDIF
14240 
14241 C CALL GULIST(1,2)
14242 C...APPLY PARTON CASCADE ON QPM EVENT.
14243 C...SAVE INCOMING AND OUTGOING QUARK AS WELL AS SCATTERED LEPTON.
14244  ks(6,1)=21
14245  ks(6,2)=lst(25)
14246  ks(6,3)=4
14247  ks(8,1)=21
14248  ks(8,2)=k(5,2)
14249  ks(8,3)=6
14250  ks(9,1)=0
14251  ks(9,2)=k(4,2)
14252  ks(9,3)=5
14253  DO 30 j=1,5
14254  ps(6,j)=0.
14255  ps(8,j)=p(5,j)
14256  30 ps(9,j)=p(4,j)
14257  xr=x
14258  dpq2=dble(q2)
14259  pma1=0.
14260  ps(6,5)=pma1
14261  pma2=ps(8,5)
14262  dpb(1)=0.5d0*(dpq2*(1d0/xr-1d0)+dble(ps(1,5))**2-
14263  +ulmass(iabs(ks(7,2)))**2)/(ps(1,4)+ps(2,4))
14264  dpb(2)=dsqrt(dpb(1)**2+dpq2)
14265  dcthet=(dble(ps(2,4))*dpb(1)-dpq2/(2d0*xr))/(dble(ps(2,3))*
14266  +dpb(2))
14267  dpa(1)=(dpb(2)*dcthet)**2-dpb(1)**2
14268  dpa(2)=dpq2-dble(pma1)**2+dble(pma2)**2
14269  ps(6,4)=-(dpa(2)*dpb(1)-dpb(2)*dcthet*dsqrt(dpa(2)**2+4d0*
14270  +dble(pma1)**2*dpa(1)))/(2d0*dpa(1))
14271  ps(6,3)=-sqrt((ps(6,4)+pma1)*(ps(6,4)-pma1))
14272 C...PARTONS WITH COLOUR INFORMATION IN HADRONIC CMS FRAME.
14273  DO 40 i=10,26
14274  DO 40 j=1,5
14275  k(i,j)=0
14276  p(i,j)=0.
14277  40 v(i,j)=0.
14278  ns=20
14279  k(ns+1,1)=21
14280  k(ns+1,2)=k(3,2)
14281  k(ns+1,3)=3
14282  k(ns+2,1)=-1
14283  k(ns+2,3)=ns+1
14284  k(ns+3,2)=ks(6,2)
14285  DO 50 j=1,5
14286  50 p(ns+1,j)=p(3,j)
14287  k(ns+3,1)=13
14288  k(ns+3,3)=2
14289  IF(mg.EQ.1) THEN
14290  pw2=w2
14291  dpa(3)=dsqrt(dpa(2)**2+4d0*dpq2*dble(pma1)**2)
14292  dpb(1)=(1d0/dble(xr)-2d0)*dpq2/(2d0*sqrt(pw2))
14293  dpb(2)=dsqrt(dpb(1)**2+dpq2)
14294  p(ns+3,4)=(dpb(2)*dpa(3)-dpb(1)*dpa(2))/(2d0*dpq2)
14295  p(ns+3,3)=-p(ns+3,4)
14296  ENDIF
14297  p(ns+3,5)=0.
14298  k(ns+4,1)=-1
14299  k(ns+4,3)=ns+3
14300  k(ns+3,4)=ns+5
14301  k(ns+3,5)=ns+5
14302  p(ns+4,3)=ns+5
14303  p(ns+4,4)=ns+5
14304  k(ns+5,1)=3
14305  k(ns+5,3)=8
14306  k(ns+5,2)=ks(8,2)
14307  k(ns+6,1)=-1
14308  k(ns+6,3)=ns+5
14309  DO 60 j=1,4
14310  IF(mg.EQ.1) THEN
14311  p(ns+5,j)=p(ns+1,j)+p(ns+3,j)
14312  ELSE
14313  p(ns+5,j)=p(5,j)
14314  p(ns+3,j)=p(ns+5,j)-p(ns+1,j)
14315  ENDIF
14316  60 CONTINUE
14317  p(ns+5,5)=pma2
14318  p(ns+6,1)=ns+3
14319  p(ns+6,2)=ns+3
14320  k(ns+5,4)=(ns+3)*mstu(5)
14321  k(ns+5,5)=(ns+3)*mstu(5)
14322  n=ns+6
14323 C CALL GULIST(2,2)
14324 C...COPY SAVED RECORD IN OVERALL CMS TO LINE 1 THROUGH 9.
14325 C...LINES 1,2,5,6,7 IN EP CMS, 8,9 IN HADRONIC CMS
14326  DO 70 i=1,9
14327  DO 70 j=1,5
14328  k(i,j)=ks(i,j)
14329  70 p(i,j)=ps(i,j)
14330 * WRITE(*,*)'1,2,5,6,7 EP CMS, 8,9, HAD CMS'
14331 * CALL LULIST(1)
14332 
14333 C CALL GULIST(3,2)
14334 C...SCALE FOR BREMSSTRAHLUNG ETC.
14335  q2py=q2
14336  ipy(40)=8
14337  ipy(47)=n
14338 C...SAVE QUANTITIES FOR LATER USE.
14339  xpy(1)=1.
14340  xpy(2)=xr
14341  CALL pystfu(k(2,2),xr,q2,xpq)
14342  DO 80 ifl=-6,6
14343  80 xqpy(2,ifl)=xpq(ifl)
14344  IF(lst(23).EQ.1) THEN
14345  isub=39
14346  ipy(11)=1
14347  ELSEIF(lst(23).EQ.3) THEN
14348  isub=39
14349  ipy(11)=2
14350  ELSEIF(lst(23).EQ.4) THEN
14351  isub=39
14352  ipy(11)=3
14353  ELSEIF(lst(23).EQ.2) THEN
14354  isub=40
14355  ENDIF
14356  IF(isub.EQ.39.AND.ipy(11).EQ.1) THEN
14357  kfl(2,1)=22
14358  ELSEIF(isub.EQ.39.AND.ipy(11).EQ.2) THEN
14359  kfl(2,1)=23
14360  ELSEIF(isub.EQ.39.AND.ipy(11).EQ.3) THEN
14361  kfl(2,1)=23
14362  ELSEIF(isub.EQ.40) THEN
14363  kfl(2,1)=-24
14364  ENDIF
14365  ifl1=k(6,2)
14366  ifl2=k(8,2)
14367  kfl(2,2)=ifl1
14368  kfl(1,1)=kfl(2,1)
14369  kfl(1,2)=kfl(2,2)
14370  IF(isub.EQ.39) kfl(3,1)=k(1,2)
14371  IF(isub.EQ.40) kfl(3,1)=k(1,2)+isign(1,k(1,2))
14372  kfl(3,2)=ifl2
14373  pyvar(2)=(p(1,4)+p(2,4))**2
14374  pyvar(1)=sqrt(pyvar(2))
14375  pyvar(3)=p(1,5)
14376  pyvar(4)=p(2,5)
14377  pyvar(5)=p(1,3)
14378  ipy(41)=k(1,2)
14379  ipy(42)=k(2,2)
14380  ipy(48)=0
14381 
14382 C...GENERATE TIMELIKE PARTON SHOWER (IF REQUIRED)
14383  IF(ipy(13).EQ.1) THEN
14384  CALL lscale(1,qmax)
14385  qmax=min(qmax,p(25,4))
14386 * WRITE(*,*)' GENERATE TIME-LIKE SHOWER WITH QMAX=',QMAX
14387 * MSTP(22)=3
14388 * WRITE(*,*)'PRE LUSHOW'
14389 * CALL LULIST(1)
14390  CALL lushow(25,0,qmax)
14391 
14392 * WRITE(*,*)' AFTER LUSHOW'
14393 * CALL LULIST(1)
14394  ENDIF
14395  it=25
14396  IF(n.GE.27) it=27
14397  ns=n
14398 
14399 * WRITE(*,*)'TEST BOZZO:NS,N=',NS,N
14400 C CALL GULIST(4,2)
14401 
14402 C...GENERATE SPACELIKE PARTON SHOWER (IF REQUIRED)
14403  ipu1=0
14404  ipu2=23
14405  IF(xpy(2)*(1.+(p(it,5)**2+pypar(22))/p(21,5)**2).GT.0.999) THEN
14406  WRITE(*,*)'21-47 ERROR'
14407  lst(21)=47
14408  RETURN
14409  ENDIF
14410  IF (ns.EQ.26) WRITE(*,*)'MAYBE BOZZO...',ievt+1
14411  IF(ipy(14).GE.1) THEN
14412  WRITE(*,*)'SPACE-LIKE SHOWER?',ievt+1
14413  CALL pysspb(ipu1,ipu2)
14414  ELSE
14415  DO 90 i=ns+1,ns+4
14416  DO 90 j=1,5
14417  k(i,j)=0
14418  p(i,j)=0.
14419  90 v(i,j)=0.
14420  k(ns+1,1)=11
14421  k(ns+1,2)=kfl(2,1)
14422  k(ns+1,3)=21
14423  DO 100 j=1,5
14424  100 p(ns+1,j)=p(21,j)
14425  k(ns+2,1)=-1
14426  k(ns+2,3)=ns+1
14427  k(ns+3,1)=13
14428  k(ns+3,2)=kfl(2,2)
14429  k(ns+3,3)=23
14430  k(ns+3,4)=23
14431  k(ns+3,5)=23
14432  p(ns+3,3)=(p(it,5)**2+q2)*(p(21,4)-p(21,3))/(2.*q2)
14433  p(ns+3,4)=-p(ns+3,3)
14434  k(ns+4,1)=-1
14435  k(ns+4,3)=ns+3
14436  p(ns+4,3)=23
14437  p(ns+4,4)=23
14438  p(24,1)=ns+3
14439  p(24,2)=ns+3
14440  k(23,4)=k(23,4)+(ns+3)*mstu(5)
14441  k(23,5)=k(23,5)+(ns+3)*mstu(5)
14442  ipu1=0
14443  ipu2=ns+3
14444  n=n+4
14445  ENDIF
14446 
14447 * CALL LULIST(1)
14448 
14449 C CALL GULIST(5,2)
14450 
14451 C...ROTATE AND BOOST OUTGOING PARTON SHOWER
14452  IF(n.GT.30) THEN
14453 * WRITE(*,*)'ROTATE AND BOOST?'
14454  k(n+1,1)=0
14455  DO 110 j=1,4
14456  110 p(n+1,j)=p(ns+1,j)+p(ns+3,j)
14457  IF(p(n+1,4).LE.1.01*p(it,5)) THEN
14458  lst(21)=50
14459  RETURN
14460  ENDIF
14461  robo(1)=ulangl(p(it,3),sqrt(p(it,1)**2+p(it,2)**2))
14462  robo(2)=ulangl(p(it,1),p(it,2))
14463  CALL ludbrb(25,ns,0.,-robo(2),0.d0,0.d0,0.d0)
14464  CALL ludbrb(25,ns,-robo(1),0.,0.d0,0.d0,0.d0)
14465  drobo(5)=-(p(it,3)*p(it,4)-p(n+1,4)*sqrt(p(n+1,4)**2-
14466  + p(it,4)**2+p(it,3)**2))/(p(it,3)**2+p(n+1,4)**2)
14467  CALL ludbrb(25,ns,0.,0.,0.d0,0.d0,drobo(5))
14468  robo(1)=ulangl(p(n+1,3),sqrt(p(n+1,1)**2+p(n+1,2)**2))
14469  robo(2)=ulangl(p(n+1,1),p(n+1,2))
14470  CALL ludbrb(25,ns,robo(1),robo(2),0.d0,0.d0,0.d0)
14471  ENDIF
14472 C CALL GULIST(6,2)
14473 
14474  q2py=q2
14475 C...HADRON REMNANT AND PRIMORDIAL KT
14476  ipy(47)=n
14477 * WRITE(*,*)' THEN CALL PYREMM IPU1,IPU2',IPU1,IPU2
14478  CALL pyremm(ipu1,ipu2)
14479  IF(ipy(48).EQ.1) THEN
14480 * WRITE(*,*)'IPY(48) ERROR'
14481  lst(21)=48
14482  RETURN
14483  ENDIF
14484 C CALL GULIST(7,2)
14485 
14486 C...TRANSFORM LINE 1,2 AND 5-7 TO HADRONIC CMS FRAME.
14487 * WRITE(*,*)'1-2,5-7 BOOST'
14488  CALL ludbrb(1,2,0.,0.,-dbeta(2,1),-dbeta(2,2),-dbeta(2,3))
14489  CALL ludbrb(1,2,-stheta(2),0.,0.d0,0.d0,0.d0)
14490  CALL ludbrb(5,7,0.,0.,-dbeta(2,1),-dbeta(2,2),-dbeta(2,3))
14491  CALL ludbrb(5,7,-stheta(2),0.,0.d0,0.d0,0.d0)
14492 C CALL GULIST(8,2)
14493 * WRITE(*,*)'1-2,5-7 TO HADRON CMS'
14494 * CALL LULIST(1)
14495 
14496 C...REARRANGE PARTONS ALONG STRINGS
14497  mstu(24)=0
14498  CALL luprep(0)
14499 * WRITE(*,*)'CALL LUPREP'
14500 * CALL LULIST(1)
14501 
14502  IF(mstu(24).NE.0) THEN
14503 C CALL GULIST(88,2)
14504  IF(lst(3).GE.1) WRITE(6,*) ' LUPREP ERROR MSTU(24)= ',mstu(24)
14505  lst(21)=49
14506  RETURN
14507  ENDIF
14508 C CALL GULIST(9,2)
14509 
14510 C...CLEAN UP EVENT RECORD -> ORDER:
14511 C...1=INC. LEPTON; 2=INC. NUCLEON; 3=EXCH BOSON; 4=SCAT. LEPTON;
14512 C...5=INC. PARTON BEFORE INITIAL SHOWER; 6=INC. QUARK AT BOSON VERTEX
14513 C...AFTER SHOWER; 7=SCAT. QUARK AT BOSON VERTEX BEFORE FINAL SHOWER
14514  lst(26)=7
14515  DO 120 j=1,5
14516  k(n+1,j)=k(4,j)
14517  120 p(n+1,j)=p(4,j)
14518  DO 130 j=1,5
14519  k(3,j)=k(5,j)
14520  p(3,j)=p(5,j)
14521  k(4,j)=k(9,j)
14522  p(4,j)=p(9,j)
14523  k(5,j)=k(n+1,j)
14524  p(5,j)=p(n+1,j)
14525 C K(7,J)=K(8,J)
14526 C P(7,J)=P(8,J)
14527  k(6,j)=k(ns+3,j)
14528  p(6,j)=p(ns+3,j)
14529  k(7,j)=k(it,j)
14530  p(7,j)=p(it,j)
14531  130 CONTINUE
14532  k(3,3)=1
14533  k(4,3)=1
14534  k(6,1)=21
14535  k(6,3)=5
14536  k(6,4)=0
14537  k(6,5)=0
14538  k(7,1)=21
14539  k(7,3)=6
14540  k(7,4)=0
14541  k(7,5)=0
14542 C...ACTIVATE LINE WITH SCATTERED LEPTON.
14543  k(4,1)=1
14544 C...DEACTIVATE OBSOLETE LINES 8, 9 AND 21, NS+1 (EXTRA LINES WITH BOSON)
14545  k(8,1)=0
14546  k(9,1)=0
14547  k(21,1)=0
14548  IF(k(ns+1,2).EQ.k(3,2)) k(ns+1,1)=0
14549 C...ZERO IRRELEVANT LINES WITH K(I,1)<0
14550  DO 150 i=1,n
14551  IF(k(i,1).LT.0) THEN
14552  DO 140 j=1,5
14553  k(i,j)=0
14554  140 p(i,j)=0.
14555  ENDIF
14556  150 CONTINUE
14557 
14558 * WRITE(*,*)'AFTER CLEANUP'
14559 * CALL LULIST(1)
14560 
14561 C CALL GULIST(10,2)
14562 C...DELETE INTERNAL PARTON LINES, I.E. WITH K(I,1)=13,14
14563  IF(mod(lst(4)/10,10).EQ.0) THEN
14564  CALL ltimex(t1)
14565  CALL luedit(14)
14566 * WRITE(*,*)'AFTER LUEDIT=14'
14567 * CALL LULIST(1)
14568  CALL ltimex(t2)
14569 C CALL GULIST(11,2)
14570  ENDIF
14571 C...DELETE EMPTY LINES
14572  CALL ltimex(t1)
14573  CALL luedit(12)
14574 * WRITE(*,*)'AFTER LUEDIT=12'
14575 * CALL LULIST(1)
14576  CALL ltimex(t2)
14577 C CALL GULIST(12,2)
14578 
14579  RETURN
14580  END
14581 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
14582 *CMZ : 1.01/01 20/09/94 14.43.49 BY PIERO ZUCCHELLI
14583 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
14584 *-- AUTHOR :
14585 C **********************************************************************
14586 
14587  SUBROUTINE lsigmx(NPAR,DERIV,DIFSIG,XF,IFLAG)
14588 
14589 C...CALCULATES THE NEGATIVE OF THE DIFFERENTIAL CROSS-SECTION.
14590 C...IN THE GENERATION PROCEDURE THE MAXIMUM OF THE DIFFERENTIAL CROSS-
14591 C...SECTION IS NEEDED FOR WEIGHTING PURPOSES. THIS MAXIMUM IS FOUND BY
14592 C...MINIMIZING THE NEGATIVE DIFFERENTIAL CROSS-SECTION USING THE MINUIT
14593 C...ROUTINES WHICH ARE THEN CALLING THIS ROUTINE.
14594 C...MORE PRECISLY, ONLY THE PART OF THE CROSS-SECTION FORMULA WHICH IS
14595 C...NEEDED FOR THE WEIGHTING PROCEDURE IS INCLUDED HERE.
14596  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
14597  COMMON /linter/ pari(40),ewqc(2,2,8),qc(8),zl(2,4),zq(2,8),pq(17)
14598  COMMON /lintrl/ psave(3,4,5),ksave(4),xmin,xmax,ymin,ymax,
14599  &q2min,q2max,w2min,w2max,ilep,inu,ig,iz
14600  COMMON /loptim/ optx(4),opty(4),optq2(4),optw2(4),comfac
14601  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
14602  dimension deriv(30),xf(30)
14603  common/linpatch/ncalls,ncall
14604 
14605  dummy=npar+deriv(1)
14606  IF(iflag.EQ.1) ncalls=0
14607  IF(iflag.EQ.2) WRITE(6,10000)
14608 
14609  difsig=1.e+10
14610  ncalls=ncalls+1
14611  x=xf(1)
14612  IF(x.LT.xmin.OR.x.GT.xmax) RETURN
14613  s=parl(21)
14614  pm2=psave(3,2,5)**2
14615  IF(lst(31).EQ.1) THEN
14616  q2=xf(2)
14617  y=q2/(parl(21)*x)
14618  w2=(1.-x)*y*parl(21)+psave(3,2,5)**2
14619  ELSEIF(lst(31).EQ.2) THEN
14620  y=xf(2)
14621  q2=y*x*parl(21)
14622  w2=(1.-x)*y*parl(21)+psave(3,2,5)**2
14623  ELSEIF(lst(31).EQ.3) THEN
14624  w2=xf(2)
14625  y=(w2-psave(3,2,5)**2)/((1.-x)*parl(21))
14626  q2=x*y*parl(21)
14627  ENDIF
14628  q2low=max(q2min,x*ymin*s,(w2min-pm2)*x/(1.-x))
14629  q2upp=min(q2max,x*ymax*s,(w2max-pm2)*x/(1.-x))
14630  ylow=max(ymin,q2min/(s*x),(w2min-pm2)/(s*(1.-x)))
14631  yupp=min(ymax,q2max/(s*x),(w2max-pm2)/(s*(1.-x)))
14632  w2low=max(w2min,(1.-x)*ymin*s+pm2,q2min*(1.-x)/x+pm2)
14633  w2upp=min(w2max,(1.-x)*ymax*s+pm2,q2max*(1.-x)/x+pm2)
14634  IF(q2.LT.q2low.OR.q2.GT.q2upp) RETURN
14635  IF(y.LT.ylow.OR.y.GT.yupp) RETURN
14636  IF(w2.LT.w2low.OR.w2.GT.w2upp) RETURN
14637  lst2=lst(2)
14638  lst(2)=-1
14639  CALL lepto
14640  lst(2)=lst2
14641  IF(lst(21).NE.0) RETURN
14642  difsig=-pq(17)*comfac
14643 
14644  IF(lst(3).GE.4.AND.iflag.EQ.3) WRITE(6,10100) ncalls,difsig,x,y,
14645  +q2,w2
14646  RETURN
14647 
14648 10000 FORMAT(' WARNING: IFLAG = 2 IN CALL TO LSIGMX, WHICH DOES NOT '
14649  &,'CALCULATE DERIVATIVES.')
14650 10100 FORMAT(/,5x,'TERMINATING ENTRY IN LSIGMX AFTER ',i5,' CALLS.',/,
14651  &5x,'BEST ESTIMATE OF MINIMUM FOUND TO BE ',e12.4,/,
14652  &5x,'LOCATED AT X, Y, Q**2, W**2 = ',4g10.3,/)
14653 
14654  END
14655 *CMZ : 1.00/00 04/07/94 15.02.26 BY PIERO ZUCCHELLI
14656 *-- AUTHOR :
14657 C 14/06/92 206150131 MEMBER NAME LEPTO61 (LUND) M FVS
14658 C######################################################################C
14659 C C
14660 C THE LUND MONTE CARLO FOR DEEP INELASTIC LEPTON-NUCLEON SCATTERING C
14661 C C
14662 C L E P T O C
14663 C C
14664 C VERSION 6.1, MAY 4, 1992 C
14665 C C
14666 C AUTHOR: GUNNAR INGELMAN PART-TIME ALSO AT C
14667 C DESY THEORY GROUP DEPT OF RADIATION SCIENCES C
14668 C (ROOM 202 BLDG 2A) UPPSALA UNIVERSITY C
14669 C NOTKESTRASSE 85 BOX 535 C
14670 C D-2000 HAMBURG 52, FRG S-751 21 UPPSALA, SWEDEN C
14671 C PHONE: +49(40)8998-2795 +46(18)18-3884 C
14672 C TELEFAX: -2777 -3833 C
14673 C E-MAIL: USE INGELMAN@DESYVAX FORWARD SET TO C
14674 C T00ING@DHHDESY3 INGELMAN@TSL.UU.SE C
14675 C C
14676 C CONTRIBUTIONS ON PARTON CASCADES: M. BENGTSSON, T. SJOSTRAND C
14677 C C
14678 C AVAILABILITY: ON REQUEST OR FROM DESY IBM AND VAX/VMS SYSTEMS: C
14679 C DESY IBM LIBRARY VXDESY DIRECTORY CONTENT C
14680 C T00ING.LUND(MEMBER) DISK$T__:[INGELMAN.LUND] C
14681 C LEPTOINF LEPTO.INFO INFO, NEWS, UPDATES C
14682 C LEPTOTEX LEPTO.TEX MANUAL IN LATEX C
14683 C LEPTO61 LEPTO61.FOR SOURCE CODE C
14684 C LEPTODEM LEPTODEM.FOR DEMO PROGRAM C
14685 C LEPTODEM.COM DEMO COMMAND FILE C
14686 C T00ING.OBJECT(LEPTO61) LEPTO61.OBJ OBJECT CODE C
14687 C C
14688 C MANUAL: G. INGELMAN, UPPSALA PREPRINT TSL/ISV 92-0065 AND C
14689 C IN PROC. `PHYSICS AT HERA', EDS. W. BUCHMUELLER, G. INGELMAN, C
14690 C DESY HAMBURG 1992, VOL. 3, P. 1366 C
14691 C C
14692 C PLEASE REPORT ANY PROBLEMS OR SUGGESTIONS FOR IMPROMEVENTS. C
14693 C C
14694 C######################################################################C
14695 
14696  SUBROUTINE ltimex(TIME)
14697 C...INTERFACE ROUTINE TO TRANSFER A CALL TO SOME MACHINE-DEPENDENT
14698 C...ROUTINE TO GET THE EXECUTION TIME USED SINCE JOB STARTED.
14699 C...NICE, BUT NOT NECESSARY INFORMATION. CAN ALSO BE CALLED BY USER.
14700 
14701  time=0.
14702 C...USE OF CERN LIBRARY ROUTINE Z007, REPLACE/DELETE IF NOT AVAILABLE.
14703  CALL timex(time)
14704  RETURN
14705  END
14706 *CMZ : 1.00/00 09/08/94 17.43.59 BY PIERO ZUCCHELLI
14707 *-- AUTHOR :
14708  FUNCTION lunpik(ID,ISGN)
14709  COMMON / taukle / bra1,brk0,brk0b,brks
14710  REAL*4 bra1,brk0,brk0b,brks
14711  ident=id*isgn
14712  IF (ident.EQ. 1) THEN
14713  ipkdef=-211
14714  ELSEIF (ident.EQ.-1) THEN
14715  ipkdef= 211
14716  ELSEIF (ident.EQ. 2) THEN
14717  ipkdef=111
14718  ELSEIF (ident.EQ.-2) THEN
14719  ipkdef=111
14720  ELSEIF (ident.EQ. 3) THEN
14721  ipkdef=-321
14722  ELSEIF (ident.EQ.-3) THEN
14723  ipkdef= 321
14724  ELSEIF (ident.EQ. 4) THEN
14725 C
14726 C K0 --> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
14727  CALL ranmar(xio,1)
14728  IF (xio.GT.brk0) THEN
14729  ipkdef= 130
14730  ELSE
14731  ipkdef= 310
14732  ENDIF
14733  ELSEIF (ident.EQ.-4) THEN
14734 C
14735 C K0B--> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
14736  CALL ranmar(xio,1)
14737  IF (xio.GT.brk0b) THEN
14738  ipkdef= 130
14739  ELSE
14740  ipkdef= 310
14741  ENDIF
14742  ELSEIF (ident.EQ. 8) THEN
14743  ipkdef= 22
14744  ELSEIF (ident.EQ.-8) THEN
14745  ipkdef= 22
14746  ELSEIF (ident.EQ. 9) THEN
14747  ipkdef= 221
14748  ELSEIF (ident.EQ.-9) THEN
14749  ipkdef= 221
14750  ELSE
14751  print *, 'STOP IN IPKDEF, WRONG IDENT=',ident
14752  stop
14753  ENDIF
14754  lunpik=ipkdef
14755  END
14756 *CMZ : 1.01/14 14/05/95 11.26.28 BY PIERO ZUCCHELLI
14757 *CMZ : 1.01/08 05/03/95 11.35.13 BY PIERO ZUCCHELLI
14758 *CMZ : 1.00/00 19/07/94 17.12.54 BY PIERO ZUCCHELLI
14759 *-- AUTHOR :
14760 C*********************************************************************
14761 
14762  SUBROUTINE lurobo(THE,PHI,BEX,BEY,BEZ)
14763 
14764 C...PURPOSE: TO PERFORM ROTATIONS AND BOOSTS.
14765  IMPLICIT DOUBLE PRECISION(d)
14766  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
14767  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
14768 *KEEP,POLAR.
14769 C--
14770  COMMON /polariz/pol(4000,3)
14771  REAL polarx(4)
14772 *KEND.
14773  SAVE /lujets/,/ludat1/
14774  dimension rot(3,3),pr(3),vr(3),dp(4),dv(4),por(3)
14775 
14776 C...FIND RANGE OF ROTATION/BOOST. CONVERT BOOST TO DOUBLE PRECISION.
14777  imin=1
14778  IF(mstu(1).GT.0) imin=mstu(1)
14779  imax=n
14780  IF(mstu(2).GT.0) imax=mstu(2)
14781  dbx=bex
14782  dby=bey
14783  dbz=bez
14784  goto 30
14785 
14786 C...ENTRY FOR SPECIFIC RANGE AND DOUBLE PRECISION BOOST.
14787  entry ludbrb(imi,ima,the,phi,dbex,dbey,dbez)
14788  imin=imi
14789  IF(imin.LE.0) imin=1
14790  imax=ima
14791  IF(imax.LE.0) imax=n
14792  dbx=dbex
14793  dby=dbey
14794  dbz=dbez
14795 
14796 C...OPTIONAL RESETTING OF V (WHEN NOT SET BEFORE.)
14797  IF(mstu(33).NE.0) THEN
14798  DO 20 i=min(imin,mstu(4)),min(imax,mstu(4))
14799  DO 10 j=1,5
14800  v(i,j)=0.
14801  10 CONTINUE
14802  20 CONTINUE
14803  mstu(33)=0
14804  ENDIF
14805 
14806 C...CHECK RANGE OF ROTATION/BOOST.
14807  30 IF(imin.GT.mstu(4).OR.imax.GT.mstu(4)) THEN
14808  CALL luerrm(11,'(LUROBO:) RANGE OUTSIDE LUJETS MEMORY')
14809  RETURN
14810  ENDIF
14811 
14812 C...ROTATE, TYPICALLY FROM Z AXIS TO DIRECTION (THETA,PHI).
14813  IF(the**2+phi**2.GT.1e-20) THEN
14814  rot(1,1)=cos(the)*cos(phi)
14815  rot(1,2)=-sin(phi)
14816  rot(1,3)=sin(the)*cos(phi)
14817  rot(2,1)=cos(the)*sin(phi)
14818  rot(2,2)=cos(phi)
14819  rot(2,3)=sin(the)*sin(phi)
14820  rot(3,1)=-sin(the)
14821  rot(3,2)=0.
14822  rot(3,3)=cos(the)
14823  DO 60 i=imin,imax
14824  IF(k(i,1).LE.0) goto 60
14825  DO 40 j=1,3
14826  pr(j)=p(i,j)
14827  vr(j)=v(i,j)
14828  por(j)=pol(i,j)
14829  40 CONTINUE
14830  DO 50 j=1,3
14831  pol(i,j)=rot(j,1)*por(1)+rot(j,2)*por(2)+rot(j,3)*por(3)
14832  p(i,j) =rot(j,1)*pr(1)+rot(j,2)*pr(2)+rot(j,3)*pr(3)
14833  v(i,j) =rot(j,1)*vr(1)+rot(j,2)*vr(2)+rot(j,3)*vr(3)
14834  50 CONTINUE
14835  60 CONTINUE
14836 
14837 
14838 
14839 
14840  ENDIF
14841 
14842 C...BOOST, TYPICALLY FROM REST TO MOMENTUM/ENERGY=BETA.
14843  IF(dbx**2+dby**2+dbz**2.GT.1e-20) THEN
14844  db=sqrt(dbx**2+dby**2+dbz**2)
14845  IF(db.GT.0.99999999d0) THEN
14846 C...RESCALE BOOST VECTOR IF TOO CLOSE TO UNITY.
14847  CALL luerrm(3,'(LUROBO:) BOOST VECTOR TOO LARGE')
14848  dbx=dbx*(0.99999999d0/db)
14849  dby=dby*(0.99999999d0/db)
14850  dbz=dbz*(0.99999999d0/db)
14851  db=0.99999999d0
14852  ENDIF
14853  dga=1d0/sqrt(1d0-db**2)
14854  DO 80 i=imin,imax
14855  IF(k(i,1).LE.0) goto 80
14856  DO 70 j=1,4
14857  dp(j)=p(i,j)
14858  dv(j)=v(i,j)
14859  70 CONTINUE
14860  dbp=dbx*dp(1)+dby*dp(2)+dbz*dp(3)
14861  dgabp=dga*(dga*dbp/(1d0+dga)+dp(4))
14862  p(i,1)=dp(1)+dgabp*dbx
14863  p(i,2)=dp(2)+dgabp*dby
14864  p(i,3)=dp(3)+dgabp*dbz
14865  p(i,4)=dga*(dp(4)+dbp)
14866  dbv=dbx*dv(1)+dby*dv(2)+dbz*dv(3)
14867  dgabv=dga*(dga*dbv/(1d0+dga)+dv(4))
14868  v(i,1)=dv(1)+dgabv*dbx
14869  v(i,2)=dv(2)+dgabv*dby
14870  v(i,3)=dv(3)+dgabv*dbz
14871  v(i,4)=dga*(dv(4)+dbv)
14872  80 CONTINUE
14873  ENDIF
14874 
14875  RETURN
14876  END
14877 *CMZ : 1.02/09 14/01/97 15.14.44 by P. Zucchelli
14878 *CMZ : 1.01/51 24/05/96 11.26.15 by Piero Zucchelli
14879 *-- Author :
14880 C*********************************************************************
14881 
14882  SUBROUTINE lustrf(IP)
14883 C...Purpose: to handle the fragmentation of an arbitrary colour singlet
14884 C...jet system according to the Lund string fragmentation model.
14885  IMPLICIT DOUBLE PRECISION(d)
14886  parameter(maxpztry=1000, maxpztryr=10)
14887  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
14888  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
14889  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
14890  SAVE /lujets/,/ludat1/,/ludat2/
14891  dimension dps(5),kfl(3),pmq(3),px(3),py(3),gam(3),ie(2),pr(2),
14892  +in(9),dhm(4),dhg(4),dp(5,5),irank(2),mju(4),iju(3),pju(5,5),
14893  +tju(5),kfjh(2),njs(2),kfjs(2),pjs(4,5),mstu9t(8),paru9t(8)
14894 
14895 C...Function: four-product of two vectors.
14896  four(i,j)=p(i,4)*p(j,4)-p(i,1)*p(j,1)-p(i,2)*p(j,2)-p(i,3)*p(j,3)
14897  dfour(i,j)=dp(i,4)*dp(j,4)-dp(i,1)*dp(j,1)-dp(i,2)*dp(j,2)-
14898  +dp(i,3)*dp(j,3)
14899 
14900 C...Reset counters. Identify parton system.
14901  mstj(91)=0
14902  nsav=n
14903  mstu90=mstu(90)
14904  np=0
14905  kqsum=0
14906  DO 100 j=1,5
14907  dps(j)=0d0
14908  100 CONTINUE
14909  mju(1)=0
14910  mju(2)=0
14911  i=ip-1
14912  110 i=i+1
14913  IF(i.GT.min(n,mstu(4)-mstu(32))) THEN
14914  CALL luerrm(12,'(LUSTRF:) failed to reconstruct jet system')
14915  IF(mstu(21).GE.1) RETURN
14916  ENDIF
14917  IF(k(i,1).NE.1.AND.k(i,1).NE.2.AND.k(i,1).NE.41) goto 110
14918  kc=lucomp(k(i,2))
14919  IF(kc.EQ.0) goto 110
14920  kq=kchg(kc,2)*isign(1,k(i,2))
14921  IF(kq.EQ.0) goto 110
14922  IF(n+5*np+11.GT.mstu(4)-mstu(32)-5) THEN
14923  CALL luerrm(11,'(LUSTRF:) no more memory left in LUJETS')
14924  IF(mstu(21).GE.1) RETURN
14925  ENDIF
14926 
14927 C...Take copy of partons to be considered. Check flavour sum.
14928  np=np+1
14929  DO 120 j=1,5
14930  k(n+np,j)=k(i,j)
14931  p(n+np,j)=p(i,j)
14932  IF(j.NE.4) dps(j)=dps(j)+p(i,j)
14933  120 CONTINUE
14934  dps(4)=dps(4)+sqrt(dble(p(i,1))**2+dble(p(i,2))**2+
14935  +dble(p(i,3))**2+dble(p(i,5))**2)
14936  k(n+np,3)=i
14937  IF(kq.NE.2) kqsum=kqsum+kq
14938  IF(k(i,1).EQ.41) THEN
14939  kqsum=kqsum+2*kq
14940  IF(kqsum.EQ.kq) mju(1)=n+np
14941  IF(kqsum.NE.kq) mju(2)=n+np
14942  ENDIF
14943  IF(k(i,1).EQ.2.OR.k(i,1).EQ.41) goto 110
14944  IF(kqsum.NE.0) THEN
14945  CALL luerrm(12,'(LUSTRF:) unphysical flavour combination')
14946  IF(mstu(21).GE.1) RETURN
14947  ENDIF
14948 
14949 C...Boost copied system to CM frame (for better numerical precision).
14950  IF(abs(dps(3)).LT.0.99d0*dps(4)) THEN
14951  mbst=0
14952  mstu(33)=1
14953  CALL ludbrb(n+1,n+np,0.,0.,-dps(1)/dps(4),-dps(2)/dps(4),
14954  + -dps(3)/dps(4))
14955  ELSE
14956  mbst=1
14957  hhbz=sqrt(max(1d-6,dps(4)+dps(3))/max(1d-6,dps(4)-dps(3)))
14958  DO 130 i=n+1,n+np
14959  hhpmt=p(i,1)**2+p(i,2)**2+p(i,5)**2
14960  IF(p(i,3).GT.0.) THEN
14961  hhpez=(p(i,4)+p(i,3))/hhbz
14962  p(i,3)=0.5*(hhpez-hhpmt/hhpez)
14963  p(i,4)=0.5*(hhpez+hhpmt/hhpez)
14964  ELSE
14965  hhpez=(p(i,4)-p(i,3))*hhbz
14966  p(i,3)=-0.5*(hhpez-hhpmt/hhpez)
14967  p(i,4)=0.5*(hhpez+hhpmt/hhpez)
14968  ENDIF
14969  130 CONTINUE
14970  ENDIF
14971 
14972 C...Search for very nearby partons that may be recombined.
14973  ntryr=0
14974  paru12=paru(12)
14975  paru13=paru(13)
14976  mju(3)=mju(1)
14977  mju(4)=mju(2)
14978  nr=np
14979  140 IF(nr.GE.3) THEN
14980  pdrmin=2.*paru12
14981  DO 150 i=n+1,n+nr
14982  IF(i.EQ.n+nr.AND.iabs(k(n+1,2)).NE.21) goto 150
14983  i1=i+1
14984  IF(i.EQ.n+nr) i1=n+1
14985  IF(k(i,1).EQ.41.OR.k(i1,1).EQ.41) goto 150
14986  IF(mju(1).NE.0.AND.i1.LT.mju(1).AND.iabs(k(i1,2)).NE.21)
14987  + goto 150
14988  IF(mju(2).NE.0.AND.i.GT.mju(2).AND.iabs(k(i,2)).NE.21) goto
14989  + 150
14990  pap=sqrt((p(i,1)**2+p(i,2)**2+p(i,3)**2)*(p(i1,1)**2+ p(i1,2)
14991  + **2+p(i1,3)**2))
14992  pvp=p(i,1)*p(i1,1)+p(i,2)*p(i1,2)+p(i,3)*p(i1,3)
14993  pdr=4.*(pap-pvp)**2/max(1e-6,paru13**2*pap+2.*(pap-pvp))
14994  IF(pdr.LT.pdrmin) THEN
14995  ir=i
14996  pdrmin=pdr
14997  ENDIF
14998  150 CONTINUE
14999 
15000 C...Recombine very nearby partons to avoid machine precision problems.
15001  IF(pdrmin.LT.paru12.AND.ir.EQ.n+nr) THEN
15002  DO 160 j=1,4
15003  p(n+1,j)=p(n+1,j)+p(n+nr,j)
15004  160 CONTINUE
15005  p(n+1,5)=sqrt(max(0.,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
15006  + p(n+1,3)**2))
15007  nr=nr-1
15008  goto 140
15009  ELSEIF(pdrmin.LT.paru12) THEN
15010  DO 170 j=1,4
15011  p(ir,j)=p(ir,j)+p(ir+1,j)
15012  170 CONTINUE
15013  p(ir,5)=sqrt(max(0.,p(ir,4)**2-p(ir,1)**2-p(ir,2)**2-
15014  + p(ir,3)**2))
15015  DO 190 i=ir+1,n+nr-1
15016  k(i,2)=k(i+1,2)
15017  DO 180 j=1,5
15018  p(i,j)=p(i+1,j)
15019  180 CONTINUE
15020  190 CONTINUE
15021  IF(ir.EQ.n+nr-1) k(ir,2)=k(n+nr,2)
15022  nr=nr-1
15023  IF(mju(1).GT.ir) mju(1)=mju(1)-1
15024  IF(mju(2).GT.ir) mju(2)=mju(2)-1
15025  goto 140
15026  ENDIF
15027  ENDIF
15028  ntryr=ntryr+1
15029 
15030 C...Reset particle counter. Skip ahead if no junctions are present;
15031 C...this is usually the case!
15032  nrs=max(5*nr+11,np)
15033  ntry=0
15034  200 ntry=ntry+1
15035  IF(ntry.GT.maxpztry.AND.ntryr.LE.maxpztryr) THEN
15036  paru12=4.*paru12
15037  paru13=2.*paru13
15038  goto 140
15039  ELSEIF(ntry.GT.maxpztry) THEN
15040  CALL luerrm(14,'(LUSTRF:) caught in infinite loop')
15041  IF(mstu(21).GE.1) RETURN
15042  ENDIF
15043  i=n+nrs
15044  mstu(90)=mstu90
15045  IF(mju(1).EQ.0.AND.mju(2).EQ.0) goto 580
15046  DO 570 jt=1,2
15047  njs(jt)=0
15048  IF(mju(jt).EQ.0) goto 570
15049  js=3-2*jt
15050 
15051 C...Find and sum up momentum on three sides of junction. Check flavours.
15052  DO 220 iu=1,3
15053  iju(iu)=0
15054  DO 210 j=1,5
15055  pju(iu,j)=0.
15056  210 CONTINUE
15057  220 CONTINUE
15058  iu=0
15059  DO 240 i1=n+1+(jt-1)*(nr-1),n+nr+(jt-1)*(1-nr),js
15060  IF(k(i1,2).NE.21.AND.iu.LE.2) THEN
15061  iu=iu+1
15062  iju(iu)=i1
15063  ENDIF
15064  DO 230 j=1,4
15065  pju(iu,j)=pju(iu,j)+p(i1,j)
15066  230 CONTINUE
15067  240 CONTINUE
15068  DO 250 iu=1,3
15069  pju(iu,5)=sqrt(pju(iu,1)**2+pju(iu,2)**2+pju(iu,3)**2)
15070  250 CONTINUE
15071  IF(k(iju(3),2)/100.NE.10*k(iju(1),2)+k(iju(2),2).AND. k(iju(3),
15072  + 2)/100.NE.10*k(iju(2),2)+k(iju(1),2)) THEN
15073  CALL luerrm(12,'(LUSTRF:) unphysical flavour combination')
15074  IF(mstu(21).GE.1) RETURN
15075  ENDIF
15076 
15077 C...Calculate (approximate) boost to rest frame of junction.
15078  t12=(pju(1,1)*pju(2,1)+pju(1,2)*pju(2,2)+pju(1,3)*pju(2,3))/
15079  + (pju(1,5)*pju(2,5))
15080  t13=(pju(1,1)*pju(3,1)+pju(1,2)*pju(3,2)+pju(1,3)*pju(3,3))/
15081  + (pju(1,5)*pju(3,5))
15082  t23=(pju(2,1)*pju(3,1)+pju(2,2)*pju(3,2)+pju(2,3)*pju(3,3))/
15083  + (pju(2,5)*pju(3,5))
15084  t11=sqrt((2./3.)*(1.-t12)*(1.-t13)/(1.-t23))
15085  t22=sqrt((2./3.)*(1.-t12)*(1.-t23)/(1.-t13))
15086  tsq=sqrt((2.*t11*t22+t12-1.)*(1.+t12))
15087  t1f=(tsq-t22*(1.+t12))/(1.-t12**2)
15088  t2f=(tsq-t11*(1.+t12))/(1.-t12**2)
15089  DO 260 j=1,3
15090  tju(j)=-(t1f*pju(1,j)/pju(1,5)+t2f*pju(2,j)/pju(2,5))
15091  260 CONTINUE
15092  tju(4)=sqrt(1.+tju(1)**2+tju(2)**2+tju(3)**2)
15093  DO 270 iu=1,3
15094  pju(iu,5)=tju(4)*pju(iu,4)-tju(1)*pju(iu,1)-tju(2)*pju(iu,2)-
15095  + tju(3)*pju(iu,3)
15096  270 CONTINUE
15097 
15098 C...Put junction at rest if motion could give inconsistencies.
15099  IF(pju(1,5)+pju(2,5).GT.pju(1,4)+pju(2,4)) THEN
15100  DO 280 j=1,3
15101  tju(j)=0.
15102  280 CONTINUE
15103  tju(4)=1.
15104  pju(1,5)=pju(1,4)
15105  pju(2,5)=pju(2,4)
15106  pju(3,5)=pju(3,4)
15107  ENDIF
15108 
15109 C...Start preparing for fragmentation of two strings from junction.
15110  ista=i
15111  DO 550 iu=1,2
15112  ns=iju(iu+1)-iju(iu)
15113 
15114 C...Junction strings: find longitudinal string directions.
15115  DO 310 is=1,ns
15116  is1=iju(iu)+is-1
15117  is2=iju(iu)+is
15118  DO 290 j=1,5
15119  dp(1,j)=0.5*p(is1,j)
15120  IF(is.EQ.1) dp(1,j)=p(is1,j)
15121  dp(2,j)=0.5*p(is2,j)
15122  IF(is.EQ.ns) dp(2,j)=-pju(iu,j)
15123  290 CONTINUE
15124  IF(is.EQ.ns) dp(2,4)=sqrt(pju(iu,1)**2+pju(iu,2)**2+pju(iu,
15125  + 3)**2)
15126  IF(is.EQ.ns) dp(2,5)=0.
15127  dp(3,5)=dfour(1,1)
15128  dp(4,5)=dfour(2,2)
15129  dhkc=dfour(1,2)
15130  IF(dp(3,5)+2.*dhkc+dp(4,5).LE.0.) THEN
15131  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
15132  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
15133  dp(3,5)=0d0
15134  dp(4,5)=0d0
15135  dhkc=dfour(1,2)
15136  ENDIF
15137  dhks=sqrt(dhkc**2-dp(3,5)*dp(4,5))
15138  dhk1=0.5*((dp(4,5)+dhkc)/dhks-1.)
15139  dhk2=0.5*((dp(3,5)+dhkc)/dhks-1.)
15140  in1=n+nr+4*is-3
15141  p(in1,5)=sqrt(dp(3,5)+2.*dhkc+dp(4,5))
15142  DO 300 j=1,4
15143  p(in1,j)=(1.+dhk1)*dp(1,j)-dhk2*dp(2,j)
15144  p(in1+1,j)=(1.+dhk2)*dp(2,j)-dhk1*dp(1,j)
15145  300 CONTINUE
15146  310 CONTINUE
15147 
15148 C...Junction strings: initialize flavour, momentum and starting pos.
15149  isav=i
15150  mstu91=mstu(90)
15151  320 ntry=ntry+1
15152  IF(ntry.GT.maxpztry.AND.ntryr.LE.maxpztryr) THEN
15153  paru12=4.*paru12
15154  paru13=2.*paru13
15155  goto 140
15156  ELSEIF(ntry.GT.maxpztry) THEN
15157  CALL luerrm(14,'(LUSTRF:) caught in infinite loop')
15158  IF(mstu(21).GE.1) RETURN
15159  ENDIF
15160  i=isav
15161  mstu(90)=mstu91
15162  irankj=0
15163  ie(1)=k(n+1+(jt/2)*(np-1),3)
15164  in(4)=n+nr+1
15165  in(5)=in(4)+1
15166  in(6)=n+nr+4*ns+1
15167  DO 340 jq=1,2
15168  DO 330 in1=n+nr+2+jq,n+nr+4*ns-2+jq,4
15169  p(in1,1)=2-jq
15170  p(in1,2)=jq-1
15171  p(in1,3)=1.
15172  330 CONTINUE
15173  340 CONTINUE
15174  kfl(1)=k(iju(iu),2)
15175  px(1)=0.
15176  py(1)=0.
15177  gam(1)=0.
15178  DO 350 j=1,5
15179  pju(iu+3,j)=0.
15180  350 CONTINUE
15181 
15182 C...Junction strings: find initial transverse directions.
15183  DO 360 j=1,4
15184  dp(1,j)=p(in(4),j)
15185  dp(2,j)=p(in(4)+1,j)
15186  dp(3,j)=0.
15187  dp(4,j)=0.
15188  360 CONTINUE
15189  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
15190  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
15191  dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
15192  dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
15193  dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
15194  IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1.
15195  IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1.
15196  IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1.
15197  IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1.
15198  dhc12=dfour(1,2)
15199  dhcx1=dfour(3,1)/dhc12
15200  dhcx2=dfour(3,2)/dhc12
15201  dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
15202  dhcy1=dfour(4,1)/dhc12
15203  dhcy2=dfour(4,2)/dhc12
15204  dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
15205  dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
15206  DO 370 j=1,4
15207  dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
15208  p(in(6),j)=dp(3,j)
15209  p(in(6)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
15210  + dhcyx*dp(3,j))
15211  370 CONTINUE
15212 
15213 C...Junction strings: produce new particle, origin.
15214  380 i=i+1
15215  IF(2*i-nsav.GE.mstu(4)-mstu(32)-5) THEN
15216  CALL luerrm(11,'(LUSTRF:) no more memory left in LUJETS')
15217  IF(mstu(21).GE.1) RETURN
15218  ENDIF
15219  irankj=irankj+1
15220  k(i,1)=1
15221  k(i,3)=ie(1)
15222  k(i,4)=0
15223  k(i,5)=0
15224 
15225 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
15226  390 CALL lukfdi(kfl(1),0,kfl(3),k(i,2))
15227  IF(k(i,2).EQ.0) goto 320
15228  IF(mstj(12).GE.3.AND.irankj.EQ.1.AND.iabs(kfl(1)).LE.10.AND.
15229  + iabs(kfl(3)).GT.10) THEN
15230  IF(rlu(0).GT.parj(19)) goto 390
15231  ENDIF
15232  p(i,5)=ulmass(k(i,2))
15233  CALL luptdi(kfl(1),px(3),py(3))
15234  pr(1)=p(i,5)**2+(px(1)+px(3))**2+(py(1)+py(3))**2
15235  CALL luzdis(kfl(1),kfl(3),pr(1),z)
15236  IF(iabs(kfl(1)).GE.4.AND.iabs(kfl(1)).LE.8.AND. mstu(90)
15237  + .LT.8) THEN
15238  mstu(90)=mstu(90)+1
15239  mstu(90+mstu(90))=i
15240  paru(90+mstu(90))=z
15241  ENDIF
15242  gam(3)=(1.-z)*(gam(1)+pr(1)/z)
15243  DO 400 j=1,3
15244  in(j)=in(3+j)
15245  400 CONTINUE
15246 
15247 C...Junction strings: stepping within or from 'low' string region easy.
15248  IF(in(1)+1.EQ.in(2).AND.z*p(in(1)+2,3)*p(in(2)+2,3)* p(in(1),
15249  + 5)**2.GE.pr(1)) THEN
15250  p(in(1)+2,4)=z*p(in(1)+2,3)
15251  p(in(2)+2,4)=pr(1)/(p(in(1)+2,4)*p(in(1),5)**2)
15252  DO 410 j=1,4
15253  p(i,j)=(px(1)+px(3))*p(in(3),j)+(py(1)+py(3))*p(in(3)+1,
15254  + j)
15255  410 CONTINUE
15256  goto 500
15257  ELSEIF(in(1)+1.EQ.in(2)) THEN
15258  p(in(2)+2,4)=p(in(2)+2,3)
15259  p(in(2)+2,1)=1.
15260  in(2)=in(2)+4
15261  IF(in(2).GT.n+nr+4*ns) goto 320
15262  IF(four(in(1),in(2)).LE.1e-2) THEN
15263  p(in(1)+2,4)=p(in(1)+2,3)
15264  p(in(1)+2,1)=0.
15265  in(1)=in(1)+4
15266  ENDIF
15267  ENDIF
15268 
15269 C...Junction strings: find new transverse directions.
15270  420 IF(in(1).GT.n+nr+4*ns.OR.in(2).GT.n+nr+4*ns.OR. in(1)
15271  + .GT.in(2)) goto 320
15272  IF(in(1).NE.in(4).OR.in(2).NE.in(5)) THEN
15273  DO 430 j=1,4
15274  dp(1,j)=p(in(1),j)
15275  dp(2,j)=p(in(2),j)
15276  dp(3,j)=0.
15277  dp(4,j)=0.
15278  430 CONTINUE
15279  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
15280  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
15281  dhc12=dfour(1,2)
15282  IF(dhc12.LE.1e-2) THEN
15283  p(in(1)+2,4)=p(in(1)+2,3)
15284  p(in(1)+2,1)=0.
15285  in(1)=in(1)+4
15286  goto 420
15287  ENDIF
15288  in(3)=n+nr+4*ns+5
15289  dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
15290  dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
15291  dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
15292  IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1.
15293  IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1.
15294  IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1.
15295  IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1.
15296  dhcx1=dfour(3,1)/dhc12
15297  dhcx2=dfour(3,2)/dhc12
15298  dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
15299  dhcy1=dfour(4,1)/dhc12
15300  dhcy2=dfour(4,2)/dhc12
15301  dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
15302  dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
15303  DO 440 j=1,4
15304  dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
15305  p(in(3),j)=dp(3,j)
15306  p(in(3)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
15307  + dhcyx*dp(3,j))
15308  440 CONTINUE
15309 C...Express pT with respect to new axes, if sensible.
15310  pxp=-(px(3)*four(in(6),in(3))+py(3)*four(in(6)+1,in(3)))
15311  pyp=-(px(3)*four(in(6),in(3)+1)+py(3)*four(in(6)+1,in(3)+1)
15312  + )
15313  IF(abs(pxp**2+pyp**2-px(3)**2-py(3)**2).LT.0.01) THEN
15314  px(3)=pxp
15315  py(3)=pyp
15316  ENDIF
15317  ENDIF
15318 
15319 C...Junction strings: sum up known four-momentum, coefficients for m2.
15320  DO 470 j=1,4
15321  dhg(j)=0.
15322  p(i,j)=px(1)*p(in(6),j)+py(1)*p(in(6)+1,j)+px(3)*p(in(3),j)
15323  + + py(3)*p(in(3)+1,j)
15324  DO 450 in1=in(4),in(1)-4,4
15325  p(i,j)=p(i,j)+p(in1+2,3)*p(in1,j)
15326  450 CONTINUE
15327  DO 460 in2=in(5),in(2)-4,4
15328  p(i,j)=p(i,j)+p(in2+2,3)*p(in2,j)
15329  460 CONTINUE
15330  470 CONTINUE
15331  dhm(1)=four(i,i)
15332  dhm(2)=2.*four(i,in(1))
15333  dhm(3)=2.*four(i,in(2))
15334  dhm(4)=2.*four(in(1),in(2))
15335 
15336 C...Junction strings: find coefficients for Gamma expression.
15337  DO 490 in2=in(1)+1,in(2),4
15338  DO 480 in1=in(1),in2-1,4
15339  dhc=2.*four(in1,in2)
15340  dhg(1)=dhg(1)+p(in1+2,1)*p(in2+2,1)*dhc
15341  IF(in1.EQ.in(1)) dhg(2)=dhg(2)-p(in2+2,1)*dhc
15342  IF(in2.EQ.in(2)) dhg(3)=dhg(3)+p(in1+2,1)*dhc
15343  IF(in1.EQ.in(1).AND.in2.EQ.in(2)) dhg(4)=dhg(4)-dhc
15344  480 CONTINUE
15345  490 CONTINUE
15346 
15347 C...Junction strings: solve (m2, Gamma) equation system for energies.
15348  dhs1=dhm(3)*dhg(4)-dhm(4)*dhg(3)
15349  IF(abs(dhs1).LT.1e-4) goto 320
15350  dhs2=dhm(4)*(gam(3)-dhg(1))-dhm(2)*dhg(3)-dhg(4)* (p(i,5)**2-
15351  + dhm(1))+dhg(2)*dhm(3)
15352  dhs3=dhm(2)*(gam(3)-dhg(1))-dhg(2)*(p(i,5)**2-dhm(1))
15353  p(in(2)+2,4)=0.5*(sqrt(max(0d0,dhs2**2-4.*dhs1*dhs3))/
15354  + abs(dhs1)- dhs2/dhs1)
15355  IF(dhm(2)+dhm(4)*p(in(2)+2,4).LE.0.) goto 320
15356  p(in(1)+2,4)=(p(i,5)**2-dhm(1)-dhm(3)*p(in(2)+2,4))/ (dhm(2)+
15357  + dhm(4)*p(in(2)+2,4))
15358 
15359 C...Junction strings: step to new region if necessary.
15360  IF(p(in(2)+2,4).GT.p(in(2)+2,3)) THEN
15361  p(in(2)+2,4)=p(in(2)+2,3)
15362  p(in(2)+2,1)=1.
15363  in(2)=in(2)+4
15364  IF(in(2).GT.n+nr+4*ns) goto 320
15365  IF(four(in(1),in(2)).LE.1e-2) THEN
15366  p(in(1)+2,4)=p(in(1)+2,3)
15367  p(in(1)+2,1)=0.
15368  in(1)=in(1)+4
15369  ENDIF
15370  goto 420
15371  ELSEIF(p(in(1)+2,4).GT.p(in(1)+2,3)) THEN
15372  p(in(1)+2,4)=p(in(1)+2,3)
15373  p(in(1)+2,1)=0.
15374  in(1)=in(1)+js
15375  goto 820
15376  ENDIF
15377 
15378 C...Junction strings: particle four-momentum, remainder, loop back.
15379  500 DO 510 j=1,4
15380  p(i,j)=p(i,j)+p(in(1)+2,4)*p(in(1),j)+p(in(2)+2,4)*p(in(2),
15381  + j)
15382  pju(iu+3,j)=pju(iu+3,j)+p(i,j)
15383  510 CONTINUE
15384  IF(p(i,4).LT.p(i,5)) goto 320
15385  pju(iu+3,5)=tju(4)*pju(iu+3,4)-tju(1)*pju(iu+3,1)- tju(2)*
15386  + pju(iu+3,2)-tju(3)*pju(iu+3,3)
15387  IF(pju(iu+3,5).LT.pju(iu,5)) THEN
15388  kfl(1)=-kfl(3)
15389  px(1)=-px(3)
15390  py(1)=-py(3)
15391  gam(1)=gam(3)
15392  IF(in(3).NE.in(6)) THEN
15393  DO 520 j=1,4
15394  p(in(6),j)=p(in(3),j)
15395  p(in(6)+1,j)=p(in(3)+1,j)
15396  520 CONTINUE
15397  ENDIF
15398  DO 530 jq=1,2
15399  in(3+jq)=in(jq)
15400  p(in(jq)+2,3)=p(in(jq)+2,3)-p(in(jq)+2,4)
15401  p(in(jq)+2,1)=p(in(jq)+2,1)-(3-2*jq)*p(in(jq)+2,4)
15402  530 CONTINUE
15403  goto 380
15404  ENDIF
15405 
15406 C...Junction strings: save quantities left after each string.
15407  IF(iabs(kfl(1)).GT.10) goto 320
15408  i=i-1
15409  kfjh(iu)=kfl(1)
15410  DO 540 j=1,4
15411  pju(iu+3,j)=pju(iu+3,j)-p(i+1,j)
15412  540 CONTINUE
15413  550 CONTINUE
15414 
15415 C...Junction strings: put together to new effective string endpoint.
15416  njs(jt)=i-ista
15417  kfjs(jt)=k(k(mju(jt+2),3),2)
15418  kfls=2*int(rlu(0)+3.*parj(4)/(1.+3.*parj(4)))+1
15419  IF(kfjh(1).EQ.kfjh(2)) kfls=3
15420  IF(ista.NE.i) kfjs(jt)=isign(1000*max(iabs(kfjh(1)), iabs(kfjh(
15421  + 2)))+100*min(iabs(kfjh(1)),iabs(kfjh(2)))+ kfls,kfjh(1))
15422  DO 560 j=1,4
15423  pjs(jt,j)=pju(1,j)+pju(2,j)+p(mju(jt),j)
15424  pjs(jt+2,j)=pju(4,j)+pju(5,j)
15425  560 CONTINUE
15426  pjs(jt,5)=sqrt(max(0.,pjs(jt,4)**2-pjs(jt,1)**2-pjs(jt,2)**2-
15427  + pjs(jt,3)**2))
15428  570 CONTINUE
15429 
15430 C...Open versus closed strings. Choose breakup region for latter.
15431  580 IF(mju(1).NE.0.AND.mju(2).NE.0) THEN
15432  ns=mju(2)-mju(1)
15433  nb=mju(1)-n
15434  ELSEIF(mju(1).NE.0) THEN
15435  ns=n+nr-mju(1)
15436  nb=mju(1)-n
15437  ELSEIF(mju(2).NE.0) THEN
15438  ns=mju(2)-n
15439  nb=1
15440  ELSEIF(iabs(k(n+1,2)).NE.21) THEN
15441  ns=nr-1
15442  nb=1
15443  ELSE
15444  ns=nr+1
15445  w2sum=0.
15446  DO 590 is=1,nr
15447  p(n+nr+is,1)=0.5*four(n+is,n+is+1-nr*(is/nr))
15448  w2sum=w2sum+p(n+nr+is,1)
15449  590 CONTINUE
15450  w2ran=rlu(0)*w2sum
15451  nb=0
15452  600 nb=nb+1
15453  w2sum=w2sum-p(n+nr+nb,1)
15454  IF(w2sum.GT.w2ran.AND.nb.LT.nr) goto 600
15455  ENDIF
15456 
15457 C...Find longitudinal string directions (i.e. lightlike four-vectors).
15458  DO 630 is=1,ns
15459  is1=n+is+nb-1-nr*((is+nb-2)/nr)
15460  is2=n+is+nb-nr*((is+nb-1)/nr)
15461  DO 610 j=1,5
15462  dp(1,j)=p(is1,j)
15463  IF(iabs(k(is1,2)).EQ.21) dp(1,j)=0.5*dp(1,j)
15464  IF(is1.EQ.mju(1)) dp(1,j)=pjs(1,j)-pjs(3,j)
15465  dp(2,j)=p(is2,j)
15466  IF(iabs(k(is2,2)).EQ.21) dp(2,j)=0.5*dp(2,j)
15467  IF(is2.EQ.mju(2)) dp(2,j)=pjs(2,j)-pjs(4,j)
15468  610 CONTINUE
15469  dp(3,5)=dfour(1,1)
15470  dp(4,5)=dfour(2,2)
15471  dhkc=dfour(1,2)
15472  IF(dp(3,5)+2.*dhkc+dp(4,5).LE.0.) THEN
15473  dp(3,5)=dp(1,5)**2
15474  dp(4,5)=dp(2,5)**2
15475  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2+dp(1,5)**2)
15476  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2+dp(2,5)**2)
15477  dhkc=dfour(1,2)
15478  ENDIF
15479  dhks=sqrt(dhkc**2-dp(3,5)*dp(4,5))
15480  dhk1=0.5*((dp(4,5)+dhkc)/dhks-1.)
15481  dhk2=0.5*((dp(3,5)+dhkc)/dhks-1.)
15482  in1=n+nr+4*is-3
15483  p(in1,5)=sqrt(dp(3,5)+2.*dhkc+dp(4,5))
15484  DO 620 j=1,4
15485  p(in1,j)=(1.+dhk1)*dp(1,j)-dhk2*dp(2,j)
15486  p(in1+1,j)=(1.+dhk2)*dp(2,j)-dhk1*dp(1,j)
15487  620 CONTINUE
15488  630 CONTINUE
15489 
15490 C...Begin initialization: sum up energy, set starting position.
15491  isav=i
15492  mstu91=mstu(90)
15493  640 ntry=ntry+1
15494  IF(ntry.GT.maxpztry.AND.ntryr.LE.maxpztryr) THEN
15495  paru12=4.*paru12
15496  paru13=2.*paru13
15497  goto 140
15498  ELSEIF(ntry.GT.maxpztry) THEN
15499  CALL luerrm(14,'(LUSTRF:) caught in infinite loop')
15500  IF(mstu(21).GE.1) RETURN
15501  ENDIF
15502  i=isav
15503  mstu(90)=mstu91
15504  DO 660 j=1,4
15505  p(n+nrs,j)=0.
15506  DO 650 is=1,nr
15507  p(n+nrs,j)=p(n+nrs,j)+p(n+is,j)
15508  650 CONTINUE
15509  660 CONTINUE
15510  DO 680 jt=1,2
15511  irank(jt)=0
15512  IF(mju(jt).NE.0) irank(jt)=njs(jt)
15513  IF(ns.GT.nr) irank(jt)=1
15514  ie(jt)=k(n+1+(jt/2)*(np-1),3)
15515  in(3*jt+1)=n+nr+1+4*(jt/2)*(ns-1)
15516  in(3*jt+2)=in(3*jt+1)+1
15517  in(3*jt+3)=n+nr+4*ns+2*jt-1
15518  DO 670 in1=n+nr+2+jt,n+nr+4*ns-2+jt,4
15519  p(in1,1)=2-jt
15520  p(in1,2)=jt-1
15521  p(in1,3)=1.
15522  670 CONTINUE
15523  680 CONTINUE
15524 
15525 C...Initialize flavour and pT variables for open string.
15526  IF(ns.LT.nr) THEN
15527  px(1)=0.
15528  py(1)=0.
15529  IF(ns.EQ.1.AND.mju(1)+mju(2).EQ.0) CALL luptdi(0,px(1),py(1))
15530  px(2)=-px(1)
15531  py(2)=-py(1)
15532  DO 690 jt=1,2
15533  kfl(jt)=k(ie(jt),2)
15534  IF(mju(jt).NE.0) kfl(jt)=kfjs(jt)
15535  mstj(93)=1
15536  pmq(jt)=ulmass(kfl(jt))
15537  gam(jt)=0.
15538  690 CONTINUE
15539 
15540 C...Closed string: random initial breakup flavour, pT and vertex.
15541  ELSE
15542  kfl(3)=int(1.+(2.+parj(2))*rlu(0))*(-1)**int(rlu(0)+0.5)
15543  CALL lukfdi(kfl(3),0,kfl(1),kdump)
15544  kfl(2)=-kfl(1)
15545  IF(iabs(kfl(1)).GT.10.AND.rlu(0).GT.0.5) THEN
15546  kfl(2)=-(kfl(1)+isign(10000,kfl(1)))
15547  ELSEIF(iabs(kfl(1)).GT.10) THEN
15548  kfl(1)=-(kfl(2)+isign(10000,kfl(2)))
15549  ENDIF
15550  CALL luptdi(kfl(1),px(1),py(1))
15551  px(2)=-px(1)
15552  py(2)=-py(1)
15553  pr3=min(25.,0.1*p(n+nr+1,5)**2)
15554  700 CALL luzdis(kfl(1),kfl(2),pr3,z)
15555  zr=pr3/(z*p(n+nr+1,5)**2)
15556  IF(zr.GE.1.) goto 700
15557  DO 710 jt=1,2
15558  mstj(93)=1
15559  pmq(jt)=ulmass(kfl(jt))
15560  gam(jt)=pr3*(1.-z)/z
15561  in1=n+nr+3+4*(jt/2)*(ns-1)
15562  p(in1,jt)=1.-z
15563  p(in1,3-jt)=jt-1
15564  p(in1,3)=(2-jt)*(1.-z)+(jt-1)*z
15565  p(in1+1,jt)=zr
15566  p(in1+1,3-jt)=2-jt
15567  p(in1+1,3)=(2-jt)*(1.-zr)+(jt-1)*zr
15568  710 CONTINUE
15569  ENDIF
15570 
15571 C...Find initial transverse directions (i.e. spacelike four-vectors).
15572  DO 750 jt=1,2
15573  IF(jt.EQ.1.OR.ns.EQ.nr-1) THEN
15574  in1=in(3*jt+1)
15575  in3=in(3*jt+3)
15576  DO 720 j=1,4
15577  dp(1,j)=p(in1,j)
15578  dp(2,j)=p(in1+1,j)
15579  dp(3,j)=0.
15580  dp(4,j)=0.
15581  720 CONTINUE
15582  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
15583  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
15584  dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
15585  dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
15586  dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
15587  IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1.
15588  IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1.
15589  IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1.
15590  IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1.
15591  dhc12=dfour(1,2)
15592  dhcx1=dfour(3,1)/dhc12
15593  dhcx2=dfour(3,2)/dhc12
15594  dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
15595  dhcy1=dfour(4,1)/dhc12
15596  dhcy2=dfour(4,2)/dhc12
15597  dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
15598  dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
15599  DO 730 j=1,4
15600  dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
15601  p(in3,j)=dp(3,j)
15602  p(in3+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
15603  + dhcyx*dp(3,j))
15604  730 CONTINUE
15605  ELSE
15606  DO 740 j=1,4
15607  p(in3+2,j)=p(in3,j)
15608  p(in3+3,j)=p(in3+1,j)
15609  740 CONTINUE
15610  ENDIF
15611  750 CONTINUE
15612 
15613 C...Remove energy used up in junction string fragmentation.
15614  IF(mju(1)+mju(2).GT.0) THEN
15615  DO 770 jt=1,2
15616  IF(njs(jt).EQ.0) goto 770
15617  DO 760 j=1,4
15618  p(n+nrs,j)=p(n+nrs,j)-pjs(jt+2,j)
15619  760 CONTINUE
15620  770 CONTINUE
15621  ENDIF
15622 
15623 C...Produce new particle: side, origin.
15624  780 i=i+1
15625  IF(2*i-nsav.GE.mstu(4)-mstu(32)-5) THEN
15626  CALL luerrm(11,'(LUSTRF:) no more memory left in LUJETS')
15627  IF(mstu(21).GE.1) RETURN
15628  ENDIF
15629  jt=1.5+rlu(0)
15630  IF(iabs(kfl(3-jt)).GT.10) jt=3-jt
15631  IF(iabs(kfl(3-jt)).GE.4.AND.iabs(kfl(3-jt)).LE.8) jt=3-jt
15632  jr=3-jt
15633  js=3-2*jt
15634  irank(jt)=irank(jt)+1
15635  k(i,1)=1
15636  k(i,3)=ie(jt)
15637  k(i,4)=0
15638  k(i,5)=0
15639 
15640 C...Generate flavour, hadron and pT.
15641  790 CALL lukfdi(kfl(jt),0,kfl(3),k(i,2))
15642  IF(k(i,2).EQ.0) goto 640
15643  IF(mstj(12).GE.3.AND.irank(jt).EQ.1.AND.iabs(kfl(jt)).LE.10.AND.
15644  +iabs(kfl(3)).GT.10) THEN
15645  IF(rlu(0).GT.parj(19)) goto 790
15646  ENDIF
15647  p(i,5)=ulmass(k(i,2))
15648  CALL luptdi(kfl(jt),px(3),py(3))
15649  pr(jt)=p(i,5)**2+(px(jt)+px(3))**2+(py(jt)+py(3))**2
15650 
15651 C...Final hadrons for small invariant mass.
15652  mstj(93)=1
15653  pmq(3)=ulmass(kfl(3))
15654  parjst=parj(33)
15655  IF(mstj(11).EQ.2) parjst=parj(34)
15656  wmin=parjst+pmq(1)+pmq(2)+parj(36)*pmq(3)
15657  IF(iabs(kfl(jt)).GT.10.AND.iabs(kfl(3)).GT.10) wmin=
15658  +wmin-0.5*parj(36)*pmq(3)
15659  wrem2=four(n+nrs,n+nrs)
15660  IF(wrem2.LT.0.10) goto 640
15661  IF(wrem2.LT.max(wmin*(1.+(2.*rlu(0)-1.)*parj(37)),
15662  +parj(32)+pmq(1)+pmq(2))**2) goto 940
15663 
15664 C...Choose z, which gives Gamma. Shift z for heavy flavours.
15665  CALL luzdis(kfl(jt),kfl(3),pr(jt),z)
15666  IF(iabs(kfl(jt)).GE.4.AND.iabs(kfl(jt)).LE.8.AND.
15667  +mstu(90).LT.8) THEN
15668  mstu(90)=mstu(90)+1
15669  mstu(90+mstu(90))=i
15670  paru(90+mstu(90))=z
15671  ENDIF
15672  kfl1a=iabs(kfl(1))
15673  kfl2a=iabs(kfl(2))
15674  IF(max(mod(kfl1a,10),mod(kfl1a/1000,10),mod(kfl2a,10),
15675  +mod(kfl2a/1000,10)).GE.4) THEN
15676  pr(jr)=(pmq(jr)+pmq(3))**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2
15677  pw12=sqrt(max(0.,(wrem2-pr(1)-pr(2))**2-4.*pr(1)*pr(2)))
15678  z=(wrem2+pr(jt)-pr(jr)+pw12*(2.*z-1.))/(2.*wrem2)
15679  pr(jr)=(pmq(jr)+parjst)**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2
15680  IF((1.-z)*(wrem2-pr(jt)/z).LT.pr(jr)) goto 940
15681  ENDIF
15682  gam(3)=(1.-z)*(gam(jt)+pr(jt)/z)
15683  DO 800 j=1,3
15684  in(j)=in(3*jt+j)
15685  800 CONTINUE
15686 
15687 C...Stepping within or from 'low' string region easy.
15688  IF(in(1)+1.EQ.in(2).AND.z*p(in(1)+2,3)*p(in(2)+2,3)*
15689  +p(in(1),5)**2.GE.pr(jt)) THEN
15690  p(in(jt)+2,4)=z*p(in(jt)+2,3)
15691  p(in(jr)+2,4)=pr(jt)/(p(in(jt)+2,4)*p(in(1),5)**2)
15692  DO 810 j=1,4
15693  p(i,j)=(px(jt)+px(3))*p(in(3),j)+(py(jt)+py(3))*p(in(3)+1,j)
15694  810 CONTINUE
15695  goto 900
15696  ELSEIF(in(1)+1.EQ.in(2)) THEN
15697  p(in(jr)+2,4)=p(in(jr)+2,3)
15698  p(in(jr)+2,jt)=1.
15699  in(jr)=in(jr)+4*js
15700  IF(js*in(jr).GT.js*in(4*jr)) goto 640
15701  IF(four(in(1),in(2)).LE.1e-2) THEN
15702  p(in(jt)+2,4)=p(in(jt)+2,3)
15703  p(in(jt)+2,jt)=0.
15704  in(jt)=in(jt)+4*js
15705  ENDIF
15706  ENDIF
15707 
15708 C...Find new transverse directions (i.e. spacelike string vectors).
15709  820 IF(js*in(1).GT.js*in(3*jr+1).OR.js*in(2).GT.js*in(3*jr+2).OR.
15710  +in(1).GT.in(2)) goto 640
15711  IF(in(1).NE.in(3*jt+1).OR.in(2).NE.in(3*jt+2)) THEN
15712  DO 830 j=1,4
15713  dp(1,j)=p(in(1),j)
15714  dp(2,j)=p(in(2),j)
15715  dp(3,j)=0.
15716  dp(4,j)=0.
15717  830 CONTINUE
15718  dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
15719  dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
15720  dhc12=dfour(1,2)
15721  IF(dhc12.LE.1e-2) THEN
15722  p(in(jt)+2,4)=p(in(jt)+2,3)
15723  p(in(jt)+2,jt)=0.
15724  in(jt)=in(jt)+4*js
15725  goto 820
15726  ENDIF
15727  in(3)=n+nr+4*ns+5
15728  dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
15729  dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
15730  dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
15731  IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1.
15732  IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1.
15733  IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1.
15734  IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1.
15735  dhcx1=dfour(3,1)/dhc12
15736  dhcx2=dfour(3,2)/dhc12
15737  dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
15738  dhcy1=dfour(4,1)/dhc12
15739  dhcy2=dfour(4,2)/dhc12
15740  dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
15741  dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
15742  DO 840 j=1,4
15743  dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
15744  p(in(3),j)=dp(3,j)
15745  p(in(3)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
15746  + dhcyx*dp(3,j))
15747  840 CONTINUE
15748 C...Express pT with respect to new axes, if sensible.
15749  pxp=-(px(3)*four(in(3*jt+3),in(3))+py(3)*
15750  + four(in(3*jt+3)+1,in(3)))
15751  pyp=-(px(3)*four(in(3*jt+3),in(3)+1)+py(3)*
15752  + four(in(3*jt+3)+1,in(3)+1))
15753  IF(abs(pxp**2+pyp**2-px(3)**2-py(3)**2).LT.0.01) THEN
15754  px(3)=pxp
15755  py(3)=pyp
15756  ENDIF
15757  ENDIF
15758 
15759 C...Sum up known four-momentum. Gives coefficients for m2 expression.
15760  DO 870 j=1,4
15761  dhg(j)=0.
15762  p(i,j)=px(jt)*p(in(3*jt+3),j)+py(jt)*p(in(3*jt+3)+1,j)+ px(3)*
15763  + p(in(3),j)+py(3)*p(in(3)+1,j)
15764  DO 850 in1=in(3*jt+1),in(1)-4*js,4*js
15765  p(i,j)=p(i,j)+p(in1+2,3)*p(in1,j)
15766  850 CONTINUE
15767  DO 860 in2=in(3*jt+2),in(2)-4*js,4*js
15768  p(i,j)=p(i,j)+p(in2+2,3)*p(in2,j)
15769  860 CONTINUE
15770  870 CONTINUE
15771  dhm(1)=four(i,i)
15772  dhm(2)=2.*four(i,in(1))
15773  dhm(3)=2.*four(i,in(2))
15774  dhm(4)=2.*four(in(1),in(2))
15775 
15776 C...Find coefficients for Gamma expression.
15777  DO 890 in2=in(1)+1,in(2),4
15778  DO 880 in1=in(1),in2-1,4
15779  dhc=2.*four(in1,in2)
15780  dhg(1)=dhg(1)+p(in1+2,jt)*p(in2+2,jt)*dhc
15781  IF(in1.EQ.in(1)) dhg(2)=dhg(2)-js*p(in2+2,jt)*dhc
15782  IF(in2.EQ.in(2)) dhg(3)=dhg(3)+js*p(in1+2,jt)*dhc
15783  IF(in1.EQ.in(1).AND.in2.EQ.in(2)) dhg(4)=dhg(4)-dhc
15784  880 CONTINUE
15785  890 CONTINUE
15786 
15787 C...Solve (m2, Gamma) equation system for energies taken.
15788  dhs1=dhm(jr+1)*dhg(4)-dhm(4)*dhg(jr+1)
15789  IF(abs(dhs1).LT.1e-4) goto 640
15790  dhs2=dhm(4)*(gam(3)-dhg(1))-dhm(jt+1)*dhg(jr+1)-dhg(4)*
15791  +(p(i,5)**2-dhm(1))+dhg(jt+1)*dhm(jr+1)
15792  dhs3=dhm(jt+1)*(gam(3)-dhg(1))-dhg(jt+1)*(p(i,5)**2-dhm(1))
15793  p(in(jr)+2,4)=0.5*(sqrt(max(0d0,dhs2**2-4.*dhs1*dhs3))/abs(dhs1)-
15794  +dhs2/dhs1)
15795  IF(dhm(jt+1)+dhm(4)*p(in(jr)+2,4).LE.0.) goto 640
15796  p(in(jt)+2,4)=(p(i,5)**2-dhm(1)-dhm(jr+1)*p(in(jr)+2,4))/
15797  +(dhm(jt+1)+dhm(4)*p(in(jr)+2,4))
15798 
15799 C...Step to new region if necessary.
15800  IF(p(in(jr)+2,4).GT.p(in(jr)+2,3)) THEN
15801  p(in(jr)+2,4)=p(in(jr)+2,3)
15802  p(in(jr)+2,jt)=1.
15803  in(jr)=in(jr)+4*js
15804  IF(js*in(jr).GT.js*in(4*jr)) goto 640
15805  IF(four(in(1),in(2)).LE.1e-2) THEN
15806  p(in(jt)+2,4)=p(in(jt)+2,3)
15807  p(in(jt)+2,jt)=0.
15808  in(jt)=in(jt)+4*js
15809  ENDIF
15810  goto 820
15811  ELSEIF(p(in(jt)+2,4).GT.p(in(jt)+2,3)) THEN
15812  p(in(jt)+2,4)=p(in(jt)+2,3)
15813  p(in(jt)+2,jt)=0.
15814  in(jt)=in(jt)+4*js
15815  goto 820
15816  ENDIF
15817 
15818 C...Four-momentum of particle. Remaining quantities. Loop back.
15819  900 DO 910 j=1,4
15820  p(i,j)=p(i,j)+p(in(1)+2,4)*p(in(1),j)+p(in(2)+2,4)*p(in(2),j)
15821  p(n+nrs,j)=p(n+nrs,j)-p(i,j)
15822  910 CONTINUE
15823  IF(p(i,4).LT.p(i,5)) goto 640
15824  kfl(jt)=-kfl(3)
15825  pmq(jt)=pmq(3)
15826  px(jt)=-px(3)
15827  py(jt)=-py(3)
15828  gam(jt)=gam(3)
15829  IF(in(3).NE.in(3*jt+3)) THEN
15830  DO 920 j=1,4
15831  p(in(3*jt+3),j)=p(in(3),j)
15832  p(in(3*jt+3)+1,j)=p(in(3)+1,j)
15833  920 CONTINUE
15834  ENDIF
15835  DO 930 jq=1,2
15836  in(3*jt+jq)=in(jq)
15837  p(in(jq)+2,3)=p(in(jq)+2,3)-p(in(jq)+2,4)
15838  p(in(jq)+2,jt)=p(in(jq)+2,jt)-js*(3-2*jq)*p(in(jq)+2,4)
15839  930 CONTINUE
15840  goto 780
15841 
15842 C...Final hadron: side, flavour, hadron, mass.
15843  940 i=i+1
15844  k(i,1)=1
15845  k(i,3)=ie(jr)
15846  k(i,4)=0
15847  k(i,5)=0
15848  CALL lukfdi(kfl(jr),-kfl(3),kfldmp,k(i,2))
15849  IF(k(i,2).EQ.0) goto 640
15850  p(i,5)=ulmass(k(i,2))
15851  pr(jr)=p(i,5)**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2
15852 
15853 C...Final two hadrons: find common setup of four-vectors.
15854  jq=1
15855  IF(p(in(4)+2,3)*p(in(5)+2,3)*four(in(4),in(5)).LT.p(in(7),3)*
15856  +p(in(8),3)*four(in(7),in(8))) jq=2
15857  dhc12=four(in(3*jq+1),in(3*jq+2))
15858  dhr1=four(n+nrs,in(3*jq+2))/dhc12
15859  dhr2=four(n+nrs,in(3*jq+1))/dhc12
15860  IF(in(4).NE.in(7).OR.in(5).NE.in(8)) THEN
15861  px(3-jq)=-four(n+nrs,in(3*jq+3))-px(jq)
15862  py(3-jq)=-four(n+nrs,in(3*jq+3)+1)-py(jq)
15863  pr(3-jq)=p(i+(jt+jq-3)**2-1,5)**2+(px(3-jq)+(2*jq-3)*js*
15864  + px(3))**2+(py(3-jq)+(2*jq-3)*js*py(3))**2
15865  ENDIF
15866 
15867 C...Solve kinematics for final two hadrons, if possible.
15868  wrem2=wrem2+(px(1)+px(2))**2+(py(1)+py(2))**2
15869  fd=(sqrt(pr(1))+sqrt(pr(2)))/sqrt(wrem2)
15870  IF(mju(1)+mju(2).NE.0.AND.i.EQ.isav+2.AND.fd.GE.1.) goto 200
15871  IF(fd.GE.1.) goto 640
15872  fa=wrem2+pr(jt)-pr(jr)
15873  IF(mstj(11).NE.2) prev=0.5*exp(max(-50.,log(fd)*parj(38)*
15874  +(pr(1)+pr(2))**2))
15875  IF(mstj(11).EQ.2) prev=0.5*fd**parj(39)
15876  fb=sign(sqrt(max(0.,fa**2-4.*wrem2*pr(jt))),js*(rlu(0)-prev))
15877  kfl1a=iabs(kfl(1))
15878  kfl2a=iabs(kfl(2))
15879  IF(max(mod(kfl1a,10),mod(kfl1a/1000,10),mod(kfl2a,10),
15880  +mod(kfl2a/1000,10)).GE.6) fb=sign(sqrt(max(0.,fa**2-
15881  +4.*wrem2*pr(jt))),float(js))
15882  DO 950 j=1,4
15883  p(i-1,j)=(px(jt)+px(3))*p(in(3*jq+3),j)+(py(jt)+py(3))* p(in(3*
15884  + jq+3)+1,j)+0.5*(dhr1*(fa+fb)*p(in(3*jq+1),j)+ dhr2*(fa-fb)*
15885  + p(in(3*jq+2),j))/wrem2
15886  p(i,j)=p(n+nrs,j)-p(i-1,j)
15887  950 CONTINUE
15888  IF(p(i-1,4).LT.p(i-1,5).OR.p(i,4).LT.p(i,5)) goto 640
15889 
15890 C...Mark jets as fragmented and give daughter pointers.
15891  n=i-nrs+1
15892  DO 960 i=nsav+1,nsav+np
15893  im=k(i,3)
15894  k(im,1)=k(im,1)+10
15895  IF(mstu(16).NE.2) THEN
15896  k(im,4)=nsav+1
15897  k(im,5)=nsav+1
15898  ELSE
15899  k(im,4)=nsav+2
15900  k(im,5)=n
15901  ENDIF
15902  960 CONTINUE
15903 
15904 C...Document string system. Move up particles.
15905  nsav=nsav+1
15906  k(nsav,1)=11
15907  k(nsav,2)=92
15908  k(nsav,3)=ip
15909  k(nsav,4)=nsav+1
15910  k(nsav,5)=n
15911  DO 970 j=1,4
15912  p(nsav,j)=dps(j)
15913  v(nsav,j)=v(ip,j)
15914  970 CONTINUE
15915  p(nsav,5)=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))
15916  v(nsav,5)=0.
15917  DO 990 i=nsav+1,n
15918  DO 980 j=1,5
15919  k(i,j)=k(i+nrs-1,j)
15920  p(i,j)=p(i+nrs-1,j)
15921  v(i,j)=0.
15922  980 CONTINUE
15923  990 CONTINUE
15924  mstu91=mstu(90)
15925  DO 1000 iz=mstu90+1,mstu91
15926  mstu9t(iz)=mstu(90+iz)-nrs+1-nsav+n
15927  paru9t(iz)=paru(90+iz)
15928  1000 CONTINUE
15929  mstu(90)=mstu90
15930 
15931 C...Order particles in rank along the chain. Update mother pointer.
15932  DO 1020 i=nsav+1,n
15933  DO 1010 j=1,5
15934  k(i-nsav+n,j)=k(i,j)
15935  p(i-nsav+n,j)=p(i,j)
15936  1010 CONTINUE
15937  1020 CONTINUE
15938  i1=nsav
15939  DO 1050 i=n+1,2*n-nsav
15940  IF(k(i,3).NE.ie(1)) goto 1050
15941  i1=i1+1
15942  DO 1030 j=1,5
15943  k(i1,j)=k(i,j)
15944  p(i1,j)=p(i,j)
15945  1030 CONTINUE
15946  IF(mstu(16).NE.2) k(i1,3)=nsav
15947  DO 1040 iz=mstu90+1,mstu91
15948  IF(mstu9t(iz).EQ.i) THEN
15949  mstu(90)=mstu(90)+1
15950  mstu(90+mstu(90))=i1
15951  paru(90+mstu(90))=paru9t(iz)
15952  ENDIF
15953  1040 CONTINUE
15954  1050 CONTINUE
15955  DO 1080 i=2*n-nsav,n+1,-1
15956  IF(k(i,3).EQ.ie(1)) goto 1080
15957  i1=i1+1
15958  DO 1060 j=1,5
15959  k(i1,j)=k(i,j)
15960  p(i1,j)=p(i,j)
15961  1060 CONTINUE
15962  IF(mstu(16).NE.2) k(i1,3)=nsav
15963  DO 1070 iz=mstu90+1,mstu91
15964  IF(mstu9t(iz).EQ.i) THEN
15965  mstu(90)=mstu(90)+1
15966  mstu(90+mstu(90))=i1
15967  paru(90+mstu(90))=paru9t(iz)
15968  ENDIF
15969  1070 CONTINUE
15970  1080 CONTINUE
15971 
15972 C...Boost back particle system. Set production vertices.
15973  IF(mbst.EQ.0) THEN
15974  mstu(33)=1
15975  CALL ludbrb(nsav+1,n,0.,0.,dps(1)/dps(4),dps(2)/dps(4),
15976  + dps(3)/dps(4))
15977  ELSE
15978  DO 1090 i=nsav+1,n
15979  hhpmt=p(i,1)**2+p(i,2)**2+p(i,5)**2
15980  IF(p(i,3).GT.0.) THEN
15981  hhpez=(p(i,4)+p(i,3))*hhbz
15982  p(i,3)=0.5*(hhpez-hhpmt/hhpez)
15983  p(i,4)=0.5*(hhpez+hhpmt/hhpez)
15984  ELSE
15985  hhpez=(p(i,4)-p(i,3))/hhbz
15986  p(i,3)=-0.5*(hhpez-hhpmt/hhpez)
15987  p(i,4)=0.5*(hhpez+hhpmt/hhpez)
15988  ENDIF
15989  1090 CONTINUE
15990  ENDIF
15991  DO 1110 i=nsav+1,n
15992  DO 1100 j=1,4
15993  v(i,j)=v(ip,j)
15994  1100 CONTINUE
15995  1110 CONTINUE
15996 
15997  RETURN
15998  END
15999 *CMZ : 1.01/51 24/05/96 10.09.46 by Piero Zucchelli
16000 *CMZ : 1.01/50 04/04/96 11.50.00 by Piero Zucchelli
16001 *CMZ : 1.01/40 20/11/95 12.56.04 by Piero Zucchelli
16002 *CMZ : 1.01/14 14/05/95 11.23.54 BY PIERO ZUCCHELLI
16003 *CMZ : 1.01/12 14/05/95 11.19.11 BY PIERO ZUCCHELLI
16004 *CMZ : 1.01/10 04/05/95 19.29.38 BY PIERO ZUCCHELLI
16005 *CMZ : 1.01/08 05/03/95 11.58.58 BY PIERO ZUCCHELLI
16006 *CMZ : 1.00/00 15/08/94 07.10.58 BY PIERO ZUCCHELLI
16007 *-- AUTHOR :
16008  FUNCTION lutoge(KF)
16009 ************************************************************************
16010 * *
16011 * RETURNS IN LUTOGE THE GEANT CODE OF A PARTICLE WITH *
16012 * LNUD CODE KF *
16013 * IPALUP,IPALUM ESTABLISH A CORRESPONDENCE TABLE BETWEEN *
16014 * GEANT AND LUND PARTICLE CODES( FOR "STABLE" PARTICLES). *
16015 * *
16016 ************************************************************************
16017  dimension ipalup(4232),ipalum(4232)
16018 
16019 * DATA IPALUP/10*0,3,4,6,4,34,4,0,4,0,0,8,1,10,37,35,39,7,17,
16020 * + 12*0,16,10,2*0,14,13,19,20,21,22,23,9*0,18,41,11*0,24,4048*0/
16021 * DATA IPALUM/10*0,2,4,5,4,33,4,0,4,0,0,9,1,10,38,36,40,7,17,
16022 * + 12*0,16,10,2*0,15,25,27,28,29,30,31,9*0,26,12*0,32,4048*0/
16023 
16024 
16025  DATA ipalup/4232*0/
16026  DATA ipalum/4232*0/
16027 
16028 
16029 
16030 
16031 * LEPTON SECTOR
16032 
16033 * gamma
16034  ipalup(22)=1
16035  ipalum(22)=1
16036 * electron
16037  ipalup(11)=3
16038  ipalum(11)=2
16039 * neutrinos
16040  ipalup(12)=4
16041  ipalum(12)=4
16042  ipalup(14)=4
16043  ipalum(14)=4
16044  ipalup(16)=4
16045  ipalum(16)=4
16046 * muons
16047  ipalup(13)=6
16048  ipalum(13)=5
16049 * taus
16050  ipalup(15)=34
16051  ipalum(15)=33
16052 
16053 
16054 * MESON SECTOR
16055 
16056 * pi0
16057  ipalup(111)=7
16058  ipalum(111)=7
16059 * piplus/minus
16060  ipalup(211)=8
16061  ipalum(211)=9
16062 * K0long
16063  ipalup(130)=10
16064  ipalum(130)=10
16065 * K0short
16066  ipalup(310)=16
16067  ipalum(310)=16
16068 * K+
16069  ipalup(321)=11
16070  ipalum(321)=12
16071 * D+
16072  ipalup(411)=35
16073  ipalum(411)=36
16074 * D0
16075  ipalup(421)=37
16076  ipalum(421)=38
16077 * D_s+
16078  ipalup(431)=39
16079  ipalum(431)=40
16080 
16081 
16082 
16083 * BARYONS SECTOR
16084 
16085 * neutron
16086  ipalup(2112)=13
16087  ipalum(2112)=25
16088 * proton
16089  ipalup(2212)=14
16090  ipalum(2212)=15
16091 * sigma - and +
16092  ipalup(3112)=21
16093  ipalum(3112)=29
16094 * lambda 0
16095  ipalup(3122)=18
16096  ipalum(3122)=26
16097 * sigma + and -
16098  ipalup(3222)=19
16099  ipalum(3222)=27
16100 * Xi-
16101  ipalup(3312)=23
16102  ipalum(3312)=31
16103 * Xi0
16104  ipalup(3322)=22
16105  ipalum(3322)=30
16106 * Lambda_c
16107  ipalum(4122)=42
16108  ipalup(4122)=41
16109 * Xi_c0
16110  ipalum(4132)=45
16111  ipalup(4132)=46
16112 * Xi_c+
16113  ipalum(4232)=44
16114  ipalup(4232)=43
16115 
16116 
16117  IF (kf.GT.0) THEN
16118  lutoge=ipalup(kf)
16119  ELSE
16120  lutoge=ipalum(-kf)
16121  ENDIF
16122 
16123 
16124 
16125  IF (lutoge .EQ. 0.AND.abs(kf).GT.10) THEN
16126  WRITE(*,*)' +++ LUTOGE: UNKNOWN LUND CODE',kf,' - GEANTINO '
16127  lutoge=48
16128  CALL lulist(3)
16129  ENDIF
16130  END
16131 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
16132 *CMZ : 1.01/08 05/03/95 11.39.25 BY PIERO ZUCCHELLI
16133 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
16134 *-- AUTHOR :
16135 C ********************************************************************
16136 
16137  SUBROUTINE lwbb(ENU)
16138 
16139 C...GIVES ENERGY (ENU) OF A (ANTI-)NEUTRINO CHOSEN FROM A SIMPLE
16140 C...PARAMETRIZATION OF A WIDE BAND BEAM.
16141 
16142  DATA emean,slope,emin,emax/30.,0.02,12.,300./
16143  a1=1./(emean-12.)
16144  a2=exp(emean*slope)
16145  10 enu=300.*rlu(0)
16146  IF(enu.LT.emean)THEN
16147  e=a1*(enu-12.)
16148  ELSE
16149  e=a2*exp(-enu*slope)
16150  ENDIF
16151  IF(enu.LT.emin.OR.enu.GT.emax) goto 10
16152  IF(e.LT.rlu(0)) goto 10
16153  RETURN
16154  END
16155 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
16156 *CMZ : 1.01/08 05/03/95 11.39.25 BY PIERO ZUCCHELLI
16157 *CMZ : 1.00/00 26/07/94 18.10.50 BY PIERO ZUCCHELLI
16158 *CMZ : 1.00/00 15/07/94 14.06.01 BY PIERO ZUCCHELLI
16159 *-- AUTHOR :
16160 C **********************************************************************
16161 
16162  SUBROUTINE lweits(LFILE)
16163 
16164 C...INTEGRATES THE QCD MATRIX ELEMENTS TO OBTAIN PROBABILITIES FOR
16165 C...QG- AND QQ-EVENTS AS A FUNCTION OF (X,W). ALSO FINDS VARIOUS
16166 C...MAXIMUM VALUES TO BE USED FOR THE QCD SIMULATION. RESULTS STORED
16167 C...IN COMMON LGRID AND OPTIONALLY WRITTEN TO LOGICAL FILE LFILE.
16168 
16169  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
16170  COMMON /linter/ pari(40),ewqc(2,2,8),qc(8),zl(2,4),zq(2,8),pq(17)
16171  COMMON /loptim/ optx(4),opty(4),optq2(4),optw2(4),comfac
16172  COMMON /lgrid/ nxx,nww,xx(20),ww(15),pqg(20,15,3),pqqb(20,15,2),
16173  +qgmax(20,15,3),qqbmax(20,15,2),ycut(20,15),xtot(20,15),np
16174  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
16175  dimension wwi(15,4),xxi(20,4)
16176  EXTERNAL dsigma
16177  DATA wwi/5.,6.,7.,8.,9.,10.,11.,12.,13.,14.,15.,17.5,20.,22.5,25.,
16178  +5.,7.5,10.,12.5,15.,17.5,20.,22.5,25.,27.5,30.,32.5,35.,40.,45.,
16179  +5.,10.,20.,30.,50.,75.,100.,125.,150.,175.,200.,225.,250.,300.,
16180  +350.,5.,10.,20.,35.,60.,100.,150.,225.,350.,500.,700.,1000.,
16181  +1400.,1900.,2500./
16182  DATA xxi/
16183  +.001,.002,.004,.006,.008,.01,.02,.04,.06,.08,
16184  + .1,.125,.15,.2,.25,.3,.45,.6,.75,.99,
16185  +.001,.002,.004,.006,.008,.01,.02,.04,.06,.08,
16186  + .1,.125,.15,.2,.25,.3,.45,.6,.75,.99,
16187  +.0001,.0003,.0006,.001,.0025,.0050,.0075,
16188  + .01,.02,.04,.06,.08,.1,.125,.15,.2,.3,.5,.75,.99,
16189  +.0001,.0003,.0006,.001,.0025,.0050,.0075,
16190  + .01,.02,.04,.06,.08,.1,.125,.15,.2,.3,.5,.75,.99/
16191  DATA ncall/0/
16192 
16193  ncall=ncall+1
16194  lst2=lst(2)
16195  lst(2)=-3
16196  wmax=sqrt(parl(21))
16197 
16198  IF(lst(3).GE.4.OR.(lst(3).EQ.3.AND.ncall.EQ.1)) WRITE(6,10000)
16199  +parl(11),lst(13),mstu(112),paru(112), parl(8),parl(9),parl(12),
16200  +parl(13)
16201  IF(lst(17).EQ.0) THEN
16202  np=1
16203  ipmax=2
16204  IF(lst(3).GE.4.OR.(lst(3).EQ.3.AND.ncall.EQ.1)) WRITE(6,10100)
16205  ELSE
16206  np=3
16207  IF(lst(23).EQ.1) np=2
16208  ipmax=3
16209  IF(lst(3).GE.4.OR.(lst(3).EQ.3.AND.ncall.EQ.1)) WRITE(6,10200)
16210  ENDIF
16211 
16212  IF(lst(19).GE.1.AND.lst(19).LE.4) THEN
16213 C...GRID TAKEN FROM DATA IN ARRAYS WWI, XXI.
16214  DO 10 iw=1,nww
16215  10 ww(iw)=wwi(iw,lst(19))
16216  DO 20 ix=1,nxx
16217  20 xx(ix)=xxi(ix,lst(19))
16218  ELSE
16219 C...GRID SPECIFIED BY USER.
16220  WRITE(6,*)' Read next nww,nxx '
16221  READ(5,*) nww,nxx
16222  READ(5,*) (ww(iw),iw=1,nww)
16223  READ(5,*) (xx(ix),ix=1,nxx)
16224  IF(xx(nxx).GT..99) xx(nxx)=.99
16225  ENDIF
16226  IF(lst(3).GE.4.OR.(lst(3).EQ.3.AND.ncall.EQ.1)) WRITE(6,10300)
16227  +lst(19),nww,nxx,ww,xx
16228  IF(wmax.GT.ww(nww)) THEN
16229  IF(lst(3).GE.1) WRITE(6,10400) wmax,ww(nww)
16230  IF(lst(3).GE.2) THEN
16231  WRITE(6,10700)
16232  stop
16233  ENDIF
16234  ENDIF
16235  IF(lst(3).GE.4.OR.(lst(3).EQ.3.AND.ncall.EQ.1)) WRITE(6,10500)
16236 
16237  lw=0
16238  DO 70 iw=1,nww
16239  w=ww(iw)
16240  IF(lw.GT.0) goto 80
16241  IF(w.GT.wmax) lw=lw+1
16242  w2=w**2
16243  lx=0
16244  DO 60 ix=1,nxx
16245  x=xx(ix)
16246  IF(lx.GT.0) goto 70
16247  IF(x.GT.1.-w2/wmax**2) lx=lx+1
16248  CALL lepto
16249  pqcom=pari(31)*pq(17)*comfac
16250 * WRITE(*,*)'PQCOM=',PQCOM
16251  parl(25)=ulalps(q2)
16252  pari(20)=pq(17)
16253  xtot(ix,iw)=pq(17)
16254  parl(27)=max(parl(9)**2/w2,parl(8))
16255  yclow=parl(27)
16256  iycut=0
16257  30 iycut=iycut+1
16258  rqg=0.
16259  rqqb=0.
16260  xpmin=dble(x)/(1.d0-2.d0*(1.d0-dble(x))*dble(parl(27)))
16261  xpmax=dble(x)/(dble(x)+(1.d0-dble(x))*dble(parl(27)))
16262  IF(xpmin.GE.xpmax) goto 50
16263 C...Y_CUT>0.5 CAN GIVE XPMIN<0
16264  IF(xpmin.LE.0.) goto 50
16265  DO 40 ip=1,np
16266  IF(lst(17).EQ.0) THEN
16267  pari(15)=0.
16268  pari(16)=0.
16269  pari(18)=0.
16270  pari(19)=0.
16271  ELSE
16272  pari(14+ip)=0.
16273  IF(ip.LE.2) pari(17+ip)=0.
16274  ENDIF
16275  lst(20)=ip
16276  lst(24)=2
16277  eps=parl(11)
16278  CALL gadap(xpmin,xpmax,dsigma,eps,result)
16279 * WRITE(*,*)'AFTER GADAP1 IX,DSIGMA',IX,RESULT
16280  rqg=rqg+result
16281  pqg(ix,iw,ip)=result/parl(25)
16282  IF(lst(17).EQ.0) THEN
16283  qgmax(ix,iw,1)=pari(15)
16284  qgmax(ix,iw,2)=pari(16)
16285  ELSE
16286  pqg(ix,iw,ip)=result*pari(20)/pari(23+ip)/parl(25)
16287  qgmax(ix,iw,ip)=pari(14+ip)
16288  ENDIF
16289  IF(ip.EQ.3) goto 40
16290  lst(24)=3
16291  eps=parl(11)
16292  CALL gadap(xpmin,xpmax,dsigma,eps,result)
16293 * WRITE(*,*)'AFTER GADAP2 IX,DSIGMA',IX,RESULT
16294  rqqb=rqqb+result
16295  pqqb(ix,iw,ip)=result/parl(25)
16296  IF(lst(17).EQ.0) THEN
16297  qqbmax(ix,iw,1)=pari(18)
16298  qqbmax(ix,iw,2)=pari(19)
16299  ELSE
16300  pqqb(ix,iw,ip)=result*pari(20)/pari(23+ip)/parl(25)
16301  qgmax(ix,iw,ip)=pari(17+ip)
16302  ENDIF
16303  40 CONTINUE
16304  50 CONTINUE
16305  rq=1.-rqg-rqqb
16306 * WRITE(*,*)'RQG,RQQB',RQG,RQBB
16307 
16308  IF(rq.LT.0.) THEN
16309 C...QCD PROBABILITIES > 1, INCREASE CUTOFF.
16310  yclow=parl(27)
16311  pot=sqrt(1./(rqg+rqqb))
16312  parl(27)=(1./parl(12)+0.01)*(parl(12)*parl(27))**pot
16313 * WRITE(*,*)'RQ<=',RQ
16314  goto 30
16315  ELSEIF(iycut.GT.1.AND.rq.GT.parl(13)) THEN
16316 C...CUTOFF INCREASED TOO MUCH, TRY LOWER.
16317  parl(27)=(parl(27)+yclow)/2.
16318 * WRITE(*,*)'RQ>=',RQ
16319  goto 30
16320  ENDIF
16321  ycut(ix,iw)=parl(27)
16322  IF(lst(39).EQ.-91) THEN
16323 C...INCLUDE 3-JET CROSS SECTION IN DENOMINATOR
16324  qtot=1.+rqg+rqqb
16325  rqg =rqg/qtot
16326  rqqb=rqqb/qtot
16327  rq=1.-rqg-rqqb
16328  ENDIF
16329  IF(lst(3).GE.4.OR.(lst(3).EQ.3.AND.ncall.EQ.1)) WRITE(6,
16330  + 10600) w,x,y,q2,parl(25),pqcom,parl(27),iycut, rq,rqg,rqqb,
16331  + (qgmax(ix,iw,ip),ip=1,ipmax), (qqbmax(ix,iw,ip),ip=1,min(2,
16332  + ipmax))
16333  60 CONTINUE
16334  70 CONTINUE
16335  80 CONTINUE
16336 
16337  lst(2)=lst2
16338  IF(lfile.LT.0) THEN
16339 C...WRITE RESULTS ON LOGICAL FILE NUMBER IABS(LFILE)
16340  WRITE(iabs(lfile)) lst,parl,nxx,nww,np,xx,ww
16341  WRITE(iabs(lfile))(((pqg(ix,iw,ip),ix=1,nxx),iw=1,nww),ip=1,np),
16342  + (((pqqb(ix,iw,ip),ix=1,nxx),iw=1,nww),ip=1,np),
16343  + (((qgmax(ix,iw,ip),ix=1,nxx),iw=1,nww),ip=1,ipmax),
16344  + (((qqbmax(ix,iw,ip),ix=1,nxx),iw=1,nww),ip=1,min(2,ipmax)),
16345  + ycut
16346  IF(np.NE.1) WRITE(iabs(lfile)) xtot
16347  CLOSE(iabs(lfile))
16348  ENDIF
16349  RETURN
16350 
16351 10000 FORMAT('1',/,5x,'INTEGRATION OF 1ST ORDER QCD MATRIX ELEMENTS',
16352  + /,5x,'============================================',
16353  +/,' FOR GLUON RADIATION (QG-EVENT) AND BOSON-GLUON FUSION ',
16354  +'(QQ-EVENT) PROBABILITY.',
16355  +//,' REQUIRED PRECISION IN INTEGRATION, PARL(11) =',f8.4,
16356  +//,' HEAVIEST FLAVOUR PRODUCED IN BOSON-GLUON FUSION, LST(13) =',
16357  +i5,//,' ALPHA-STRONG PARAMETERS: # FLAVOURS, MSTU(112) =',i3,
16358  +/,25x,' QCD LAMBDA, PARU(112) =',f6.3,' GEV',
16359  +//,' CUTS ON MATRIX ELEMENTS:',
16360  +/,' PARL(8), PARL(9), PARL(12), PARL(13) =',4f8.4,/)
16361 10100 FORMAT(' LEPTON ENERGY NOT ALLOWED TO VARY IN SIMULATION.',/)
16362 10200 FORMAT(' LEPTON ENERGY ALLOWED TO VARY IN SIMULATION, ',/,
16363  +' Y IN TABLE BELOW CALCULATED ASSUMING MAX ENERGY.',/)
16364 10300 FORMAT(' GRID CHOICE, LST(19) =',i3,5x,'# GRID POINTS IN W, X =',
16365  +2i5,/,' W-VALUES IN ARRAY WW:',/,10f8.1,/,5f8.1,
16366  +/,' X-VALUES IN ARRAY XX:',/,10f8.4,/,10f8.4,/)
16367 10400 FORMAT(' WARNING: MAX W OUTSIDE GRID, WMAX, GRID-MAX =',2f12.1)
16368 10500 FORMAT(//,6x,'W',7x,'X',7x,'Y',6x,'Q**2',1x,'ALPHA',1x,'DSIGMA',
16369  +9x,'CUT',' IT',2x,'Q-EVENT',1x,'QG-EVENT',
16370  +1x,'QQ-EVENT',' MAX OF MATRIX ELEMENTS QG & QQ; L,R OR T,S,I',
16371  +/,1x,132(1h-),/)
16372 10600 FORMAT(f7.1,2f8.4,1pg10.3,0pf6.2,1pg11.3,0pf8.4,i3,3f9.4,1p,5e9.2)
16373 10700 FORMAT(' EXECUTION STOPPED ',/)
16374  END
16375 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
16376 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
16377 *-- AUTHOR :
16378 C **********************************************************************
16379 
16380  SUBROUTINE lxp(XP,IFAIL)
16381 
16382 C...CHOOSE VALUE OF XP ACCORDING TO QCD MATRIX ELEMENTS WEIGHTED BY
16383 C...STRUCTURE FUNCTIONS.
16384 
16385  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
16386  COMMON /linter/ pari(40),ewqc(2,2,8),qc(8),zl(2,4),zq(2,8),pq(17)
16387  DOUBLE PRECISION dxpmax
16388 
16389  ifail=1
16390  xpmin=dble(x)/(1.d0-2.d0*(1.d0-dble(x))*dble(parl(27)))
16391  dxpmax=dble(x)/(dble(x)+(1.d0-dble(x))*dble(parl(27)))
16392  xpmax=sngl(dxpmax)
16393  IF(xpmin.GE.xpmax) RETURN
16394  ap=1.-xpmin
16395  bp=(1.d0-dxpmax)/ap
16396  IF(lst(24).EQ.2) THEN
16397  qxpmax=pari(15)
16398  IF(lst(17).NE.0) qxpmax=pari(24)*pari(15)+pari(25)*pari(16)+
16399  + pari(26)*pari(17)
16400  ELSE
16401  qxpmax=pari(18)
16402  IF(lst(17).NE.0) qxpmax=pari(24)*pari(18)+pari(25)*pari(19)
16403  ENDIF
16404 C...SAFETY FACTOR ON MAX VALUE.
16405  qxpmax=qxpmax*1.05
16406  loop=0
16407  10 loop=loop+1
16408  IF(loop.GT.1000) RETURN
16409  xp=1.-ap*bp**rlu(0)
16410  xpweit=dsigma(xp)/qxpmax
16411  IF(xpweit.LT.rlu(0)) goto 10
16412  ifail=0
16413  RETURN
16414  END
16415 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
16416 *CMZ : 1.01/08 05/03/95 11.39.25 BY PIERO ZUCCHELLI
16417 *CMZ : 1.01/01 20/09/94 14.43.37 BY PIERO ZUCCHELLI
16418 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
16419 *-- AUTHOR :
16420 C **********************************************************************
16421 
16422  SUBROUTINE lxsect
16423 
16424 C...INTEGRATE DIFFERENTIAL CROSS-SECTION USING GADAP, RIWIAD OR DIVONNE
16425 
16426  COMMON /linteg/ ntot,npass
16427  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
16428  COMMON /lintrl/ psave(3,4,5),ksave(4),xmin,xmax,ymin,ymax,
16429  +q2min,q2max,w2min,w2max,ilep,inu,ig,iz
16430  DOUBLE PRECISION acc,value,erriw,flow,fhigh
16431  COMMON /params/ acc,ndim,nsub,iter
16432  COMMON /answer/ value,erriw
16433  COMMON /bndlmt/ flow,fhigh
16434  COMMON /sample/ npoint
16435  dimension xminus(2),xplus(2)
16436  EXTERNAL dcross,dlower,dupper,riwfun
16437  common/linpatch/ncalls,ncall
16438 
16439  ncall=ncall+1
16440  CALL ltimex(ti1)
16441  ntot=0
16442  npass=0
16443  sigma=0.
16444  errest=0.
16445  ndim=2
16446 C...PARAMETERS FOR RIWIAD INTEGRATION.
16447  acc=parl(15)
16448  nsub=100
16449  iter=100
16450 C...PARAMETERS FOR DIVON INTEGRATION.
16451  DO 10 i=1,2
16452  xminus(i)=0.
16453  10 xplus(i)=1.
16454  eps=parl(15)
16455  maxnum=50000
16456  flow=-1.d0
16457  fhigh=1.d+20
16458  npoint=100
16459 C...ADDITIONAL PARAMETERS FOR DETAILED DIVON INTEGRATION.
16460  sprdmx=2.
16461  maxpts=50000
16462  jdeg=0
16463  npt=1000
16464 
16465  sigma=0.
16466  errest=0.
16467  IF(lst(3).GE.4.OR.(lst(3).EQ.3.AND.ncall.EQ.1)) WRITE(6,10000)
16468  IF(lst(10).EQ.1) THEN
16469 C...INTEGRATION USING GADAP.
16470  IF(lst(3).GE.4.OR.(lst(3).EQ.3.AND.ncall.EQ.1)) WRITE(6,10100)
16471  accur=parl(15)
16472  it=0
16473  20 it=it+1
16474  errest=accur
16475  CALL gadap2(xmin,xmax,dlower,dupper,dcross,errest,sigma)
16476  IF(lst(3).GE.4.OR.(lst(3).EQ.3.AND.ncall.EQ.1)) WRITE(6,10200)
16477  + it,ntot,npass,sigma
16478  IF(sigma.GT.1.) THEN
16479  IF(lst(3).GE.4.OR.(lst(3).EQ.3.AND.ncall.EQ.1)) WRITE(6,
16480  + 10300) accur
16481  ELSE
16482  IF(lst(3).GE.4.OR.(lst(3).EQ.3.AND.ncall.EQ.1)) WRITE(6,
16483  + 10400) accur,accur/max(1.e-22,sigma),parl(15)
16484  accur=max(1.e-22,sigma*parl(15))
16485  IF(it.LT.2) goto 20
16486  ENDIF
16487  ELSEIF(lst(10).EQ.2) THEN
16488 C...INTEGRATION USING RIWIAD. WHEN RIWIAD CANNOT BE LOADED:
16489 C...ACTIVATE NEXT TWO LINES AND DEACTIVATE RIWIAD CALL.
16490 C WRITE(6,*) ' RIWIAD NOT AVAILABLE, EXECUTION STOPPED.'
16491 C STOP
16492  IF(lst(3).GE.4.OR.(lst(3).EQ.3.AND.ncall.EQ.1)) WRITE(6,10500)
16493  + sngl(acc),nsub,iter
16494  CALL riwiad(riwfun)
16495  sigma=sngl(value)
16496  errest=sngl(erriw)
16497  ELSEIF(lst(10).EQ.3) THEN
16498 C...INTEGRATION USING SIMPLE DIVONNE. WHEN DIVONNE CANNOT BE LOADED:
16499 C...ACTIVATE NEXT TWO LINES AND DEACTIVATE DIVONNE CALL.
16500 C WRITE(6,*) ' DIVONNE NOT AVAILABLE, EXECUTION STOPPED.'
16501 C STOP
16502  IF(lst(3).GE.4.OR.(lst(3).EQ.3.AND.ncall.EQ.1)) WRITE(6,10600)
16503  + eps,maxnum,sngl(flow),sngl(fhigh),npoint
16504  CALL divon(ndim,xminus,xplus,eps,maxnum,sigma,errest)
16505  ELSEIF(lst(10).EQ.4) THEN
16506 C...INTEGRATION USING DETAILED DIVONNE. WHEN DIVONNE CANNOT BE LOADED:
16507 C...ACTIVATE NEXT TWO LINES AND DEACTIVATE PARTN AND INTGRL CALLS.
16508 C WRITE(6,*) ' DIVONNE NOT AVAILABLE, EXECUTION STOPPED.'
16509 C STOP
16510  IF(lst(3).GE.4.OR.(lst(3).EQ.3.AND.ncall.EQ.1)) WRITE(6,10700)
16511  + eps,maxnum, sngl(flow),sngl(fhigh),npoint,sprdmx,maxpts,jdeg,
16512  + npt
16513  CALL partn(ndim,xminus,xplus,sprdmx,maxpts)
16514  CALL intgrl(ndim,jdeg,npt,sigma,errest)
16515  ELSE
16516  IF(lst(3).GE.1) WRITE(6,*) ' WARNING: LST(10) = ',lst(10),
16517  + ' NOT ALLOWED.'
16518  ENDIF
16519  CALL ltimex(ti2)
16520  IF(lst(3).GE.4.OR.(lst(3).EQ.3.AND.ncall.EQ.1)
16521  +.OR.(lst(3).GE.1.AND.npass.EQ.0)) THEN
16522  WRITE(6,10800) sigma,errest,ntot,npass,ti2-ti1
16523  IF(lst(3).GE.1.AND.npass.EQ.0) WRITE(6,10900)
16524  ENDIF
16525  parl(23)=sigma
16526 
16527  RETURN
16528 10000 FORMAT(/,' INTEGRATION OF CROSS SECTION:',/,1x,28('-'))
16529 10100 FORMAT(5x,'USING GADAP = ADAPTIVE GAUSSIAN INTEGRATION')
16530 10200 FORMAT(5x,'ITERATION #',i3,/,
16531  +10x,'# FUNCTION EVALUATIONS; TOTAL & NON-ZERO =',2i8,/,
16532  +10x,'SIGMA =',g10.2,' PB')
16533 10300 FORMAT(10x,'REQUIRED RELATIVE ERROR = ',g10.2)
16534 10400 FORMAT(10x,'EFFECTIVE ABSOLUTE ERROR = ',g10.2,/,
16535  + 10x,'EFFECTIVE RELATIVE ERROR = ',g10.2,/,
16536  + 10x,'REQUIRED RELATIVE ERROR = ',g10.2)
16537 10500 FORMAT(5x,'USING RIWIAD WITH PARAMETERS: REL. ACC. = ',f10.4,
16538  +/,5x,'# OF SUBVOLUMES = ',i5,5x,'MAX # ITERATIONS = ',i5)
16539 10600 FORMAT(5x,'USING AUTOMATIC DIVONNE WITH PARAMETERS: ',
16540  +'REL. ACC. = ',f10.4,/,5x,'MAX # FUNCTION CALLS = ',i5,
16541  +/,5x,'LOWER AND UPPER BOUND ON INTEGRAND =',2e12.4,
16542  +/,5x,'# SAMPLE POINTS/REGION =',i5)
16543 10700 FORMAT(5x,'USING DETAILED DIVONNE WITH PARAMETERS: ',
16544  +'REL. ACC. = ',f10.4,/,5x,'MAX # FUNCTION CALLS = ',i5,
16545  +/,5x,'LOWER AND UPPER BOUND ON INTEGRAND =',2e12.4,
16546  +/,5x,'# SAMPLE POINTS/REGION =',i5,
16547  +/,5x,'SPRDMX, MAXPTS, JDEG, NPT =',f5.2,3i10)
16548 10800 FORMAT(/,' ===> CROSS-SECTION =',1p,g12.3,
16549  +' PB, ERROR ESTIMATE = ',g12.3,/,
16550  +6x,'# OF INTEGRAND EVALUATIONS; TOTAL & NON-ZERO =',2i8,/,
16551  +6x,'CPU TIME FOR INTEGRATION =',g12.3,' SECONDS',/)
16552 10900 FORMAT(' WARNING: INTEGRAND ALWAYS ZERO, PROBABLY NO ALLOWED',
16553  +' PHASE SPACE DUE TO CUTS',/,
16554  +10x,'CHECK, IN PARTICULAR, CUT(11) TO CUT(14)')
16555  END
16556 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
16557 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
16558 *-- AUTHOR :
16559 C **********************************************************************
16560 
16561  SUBROUTINE lzp(XP,ZP,IFAIL)
16562 
16563 C...CHOOSE VALUE OF ZP ACCORDING TO QCD MATRIX ELEMENTS.
16564 
16565  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
16566  COMMON /linter/ pari(40),ewqc(2,2,8),qc(8),zl(2,4),zq(2,8),pq(17)
16567  DATA c1,c2/0.2122066,0.0795775/,dzpmax,szp,cp/3*0./
16568  fqg(dz,dx,da,db,dc)=da*(dz**2+dx**2)/(1.-dx)+2.*da*dx*dz*(1.-dz)
16569  &+2.*da*(1.-dz)+4.*db*dx*dz*(1.-dz)+dc*(dz**2+dx**2)/(1.-dx)+
16570  &2.*dc*(dx+dz)*(1.-dz)
16571  fqq(dz,dx,da,db,dc,dd,de)=da*dd*(dz**2+(1.-dz)**2)+db*de*dz*
16572  &(1.-dz)+dc*dd*(2.*dz-1.)
16573 
16574  ifail=1
16575  ih=1
16576  IF(lst(30).EQ.1) ih=2
16577  zpmin=(1.-x)*xp/(xp-x)*parl(27)
16578  IF(zpmin.GE.0.5) RETURN
16579  zpmax=1.-zpmin
16580  i=iabs(lst(25))
16581  ap=1.-zpmin
16582  bp=zpmin/ap
16583  IF(lst(23).EQ.2) THEN
16584  a=pari(24)
16585  b=pari(25)
16586  csign=-lst(30)*isign(1,lst(25))*pari(26)
16587  ELSE
16588  a=(ewqc(1,ih,i)+ewqc(2,ih,i))*pari(24)
16589  b=(ewqc(1,ih,i)+ewqc(2,ih,i))*pari(25)
16590  c=(ewqc(1,ih,i)-ewqc(2,ih,i))*pari(26)
16591  csign=-c*lst(30)*isign(1,lst(25))
16592  ENDIF
16593  IF(lst(24).EQ.2) THEN
16594  dzpmax=max(fqg(zpmin,xp,a,b,csign),fqg(zpmax,xp,a,b,csign))
16595  aa=2.*(a+csign)/(1.-xp)-4.*a*xp-8.*b*xp-4.*csign
16596  IF(abs(aa).GT.1.e-20) THEN
16597  bb=2.*a*(xp-1.)+4.*b*xp+2.*csign*(1.-xp)
16598  z1=-bb/aa
16599  IF(z1.GT.zpmin.AND.z1.LT.zpmax) THEN
16600  dzpmax=max(dzpmax,fqg(z1,xp,a,b,csign))
16601  ENDIF
16602  ENDIF
16603  dzpmax=dzpmax*c1*1.05
16604  ELSEIF(lst(24).EQ.3) THEN
16605  cp=1./bp**2
16606  d=xp**2+(1.-xp)**2
16607  e=8.*xp*(1-xp)
16608  dzpmax=max(fqq(zpmin,xp,a,b,csign,d,e),
16609  & fqq(zpmax,xp,a,b,csign,d,e))
16610  aa=4.*a*d-2.*b*e
16611  IF(abs(aa).GT.1.e-20) THEN
16612  bb=b*e-2.*a*d+2.*csign*d
16613  z1=-bb/aa
16614  IF(z1.GT.zpmin.AND.z1.LT.zpmax) THEN
16615  dzpmax=max(dzpmax,fqq(z1,xp,a,b,csign,d,e))
16616  ENDIF
16617  ENDIF
16618  dzpmax=dzpmax*c2*1.05
16619  ENDIF
16620  ipart=lst(24)-1
16621  loop=0
16622  10 loop=loop+1
16623  IF(loop.GT.1000) RETURN
16624  IF(lst(24).EQ.2) THEN
16625  zp=1.-ap*bp**rlu(0)
16626  szp=1.-zp
16627  ELSEIF(lst(24).EQ.3) THEN
16628  dp=bp*cp**rlu(0)
16629  zp=dp/(1.+dp)
16630  szp=zp*(1.-zp)
16631  ENDIF
16632  zpweit=szp*(a*dqcd(0,ipart,1,xp,zp,0.)+b*dqcd(0,ipart,2,xp,zp,0.)
16633  &+csign*dqcd(0,ipart,3,xp,zp,0.))/dzpmax
16634  IF(zpweit.LT.rlu(0)) goto 10
16635  ifail=0
16636  RETURN
16637  END
16638 *CMZ : 1.01/45 08/01/96 11.37.02 by Piero Zucchelli
16639 *CMZ : 1.01/44 05/01/96 18.04.59 by Piero Zucchelli
16640 *CMZ : 1.01/40 10/11/95 19.03.13 by Piero Zucchelli
16641 *-- Author :
16642  SUBROUTINE mzini
16643 *-----------------------------------------------------*
16644 * *
16645 * INITIALIZE BANKS *
16646 * *
16647 *-----------------------------------------------------*
16648 *KEEP,zebra.
16649 
16650  parameter(nnq=1000000)
16651 *
16652  dimension lq(nnq),iq(nnq),q(nnq)
16653  equivalence(q(1),iq(1),lq(9),jstruc(8))
16654  COMMON /quest/iquest(100)
16655  COMMON /xqstor/ixevt,ifence(16),jgeev,jstruc(99),jrefer(100),
16656  +div12(nnq)
16657  COMMON /fzlun/lunfz
16658  common/mzioall/iogenf
16659 
16660 *KEEP,info.
16661  common/infonew/irdate,irtime
16662 *KEND.
16663 *
16664 *--- INITIALISATION OF ZEBRA
16665 *
16666  CALL mzform('GENF','5I 2H',iogenf)
16667  RETURN
16668  END
16669 *CMZ : 1.01/51 23/05/96 16.08.27 by Piero Zucchelli
16670 *CMZ : 1.01/38 18/10/95 18.27.55 by Piero Zucchelli
16671 *CMZ : 1.01/37 04/09/95 15.00.03 BY PIERO ZUCCHELLI
16672 *-- AUTHOR : PIERO ZUCCHELLI 04/09/95
16673 
16674 
16675  SUBROUTINE orth(PO,P,PB)
16676 
16677 * ASSUMPTION: BEAM ALONG Z!
16678 
16679  REAL*4 bdir(3),pb2(3),p(3),pb(3),pv(3)
16680 
16681 
16682  bdir(1)=0.
16683  bdir(2)=0.
16684  bdir(3)=1.
16685 
16686 * ORTHOGONALIZE BEAM DIRECTION AND BASE DIRECTION
16687 
16688 
16689  bdirl=sqrt(bdir(1)**2+bdir(2)**2+bdir(3)**2)
16690 
16691 
16692 * PB DOT BEAM DIRECTION
16693  pbdb=0
16694 
16695  DO i=1,3
16696  bdir(i)=bdir(i)/bdirl
16697  pbdb=pbdb+pb(i)*bdir(i)
16698  ENDDO
16699 
16700  DO i=1,3
16701  pb2(i)=pb(i) - pbdb*bdir(i)
16702  ENDDO
16703 
16704 * PB2 INOW IS ORTHOGONAL TO BEAM DIRECTION: NORMALIZE IT
16705  pb2l=sqrt(pb2(1)**2+pb2(2)**2+pb2(3)**2)
16706  IF (pb2l.EQ.0) THEN
16707  po=0
16708  RETURN
16709  ENDIF
16710 
16711  DO i=1,3
16712  pb2(i)=pb2(i)/pb2l
16713  ENDDO
16714 
16715 
16716 * CALCULATE ALPHAS
16717 
16718  a1=0
16719  a2=0
16720 
16721  DO i=1,3
16722  a1=a1+p(i)*bdir(i)
16723  a2=a2+p(i)*pb2(i)
16724  ENDDO
16725 
16726 
16727  po=0
16728  DO i=1,3
16729  pv(i)=p(i)-a1*bdir(i)-a2*pb2(i)
16730  po=po+pv(i)**2
16731  ENDDO
16732 
16733  IF (po.GT.0) THEN
16734  po=sqrt(po)
16735  ELSE
16736  po=0
16737  ENDIF
16738 
16739  RETURN
16740  END
16741 *CMZ : 1.01/08 05/03/95 11.35.13 BY PIERO ZUCCHELLI
16742 *CMZ : 1.01/01 23/09/94 12.17.27 BY PIERO ZUCCHELLI
16743 *-- AUTHOR : PIERO ZUCCHELLI 23/09/94
16744 
16745  SUBROUTINE parupd
16746 
16747  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
16748  COMMON /lintrl/ psave(3,4,5),ksave(4),xmin,xmax,ymin,ymax,
16749  +q2min,q2max,w2min,w2max,ilep,inu,ig,iz
16750  COMMON /linter/ pari(40),ewqc(2,2,8),qc(8),zl(2,4),zq(2,8),pq(17)
16751 
16752 *KEEP,JETTA.
16753 C--
16754  parameter(icento=100)
16755  parameter(isiz=93)
16756  parameter(iof1=32)
16757  parameter(iof2=83)
16758  parameter(lux_level=4)
16759  INTEGER*4 jtau(100),jpri(100),jstro(100)
16760  REAL*4 ftuple(isiz)
16761  common/jettagl/jtau,jpri,jstro
16762  common/ntupla/ftuple,isfirst
16763  common/beam/spec(icento)
16764  COMMON /maxspec/rmaxspec,rintspec
16765  common/sav/xminsav(icento),xmaxsav(icento),yminsav(icento),
16766  & ymaxsav(icento),q2minsav(icento),q2maxsav(icento),
16767  & w2minsav(icento),w2maxsav(icento),parimax(icento),
16768  & ppsave(icento,3,4,5),paricor(icento),index,sigmasav(icento),
16769  & xmsigma,xsect
16770 
16771 *KEND.
16772 
16773 
16774  IF (pari(32).NE.paricor(index)) THEN
16775  paricor(index)=pari(32)
16776  parimax(index)=pari(lst(23))
16777  ENDIF
16778 
16779  RETURN
16780  END
16781 *CMZ : 1.01/14 14/05/95 11.26.28 BY PIERO ZUCCHELLI
16782 *CMZ : 1.01/08 05/03/95 11.39.27 BY PIERO ZUCCHELLI
16783 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
16784 *-- AUTHOR :
16785  FUNCTION phint(IDUM)
16786 C.----------------------------------------------------------------------
16787 C.
16788 C. PHINT: PHOTOS INTERFERENCE
16789 C.
16790 C. PURPOSE: CALCULATES INTERFERENCE BETWEEN EMISSION OF PHOTONS FROM
16791 C. DIFFERENT POSSIBLE CHAGED DAUGHTERS STORED IN
16792 C. THE HEP COMMON /PHOEVT/.
16793 C.
16794 C. INPUT PARAMETER: COMMONS /PHOEVT/ /PHOMOM/ /PHOPHS/
16795 C.
16796 C.
16797 C. OUTPUT PARAMETERS:
16798 C.
16799 C.
16800 C. AUTHOR(S): Z. WAS, CREATED AT: 10/08/93
16801 C. LAST UPDATE:
16802 C.
16803 C.----------------------------------------------------------------------
16804 
16805 C-- IMPLICIT NONE
16806  REAL phint
16807  REAL phocha
16808  INTEGER idum
16809  INTEGER nmxpho
16810  parameter(nmxpho=2000)
16811  INTEGER idpho,istpho,jdapho,jmopho,nevpho,npho
16812  REAL ppho,vpho
16813  common/phoevt/nevpho,npho,istpho(nmxpho),idpho(nmxpho),
16814  +jmopho(2,nmxpho),jdapho(2,nmxpho),ppho(5,nmxpho),vpho(4,nmxpho)
16815  DOUBLE PRECISION mchsqr,mnesqr
16816  REAL pneutr
16817  common/phomom/mchsqr,mnesqr,pneutr(5)
16818  DOUBLE PRECISION costhg,sinthg
16819  REAL xphmax,xphoto
16820  common/phophs/xphmax,xphoto,costhg,sinthg
16821  REAL mpasqr,xx,beta
16822  LOGICAL ifint
16823  INTEGER k,ident
16824 C
16825  DO k=jdapho(2,1),jdapho(1,1),-1
16826  IF(idpho(k).NE.22) THEN
16827  ident=k
16828  goto 10
16829  ENDIF
16830  ENDDO
16831  10 CONTINUE
16832 C CHECK IF THERE IS A PHOTON
16833  ifint= npho.GT.ident
16834 C CHECK IF IT IS TWO BODY + GAMMAS REACTION
16835  ifint= ifint.AND.(ident-jdapho(1,1)).EQ.1
16836 C CHECK IF TWO BODY WAS PARTICLE ANTIPARTICLE
16837  ifint= ifint.AND.idpho(jdapho(1,1)).EQ.-idpho(ident)
16838 C CHECK IF PARTICLES WERE CHARGED
16839  ifint= ifint.AND.phocha(ident).NE.0
16840 C CALCULATES INTERFERENCE WEIGHT CONTRIBUTION
16841  IF(ifint) THEN
16842  mpasqr = ppho(5,1)**2
16843  xx=4.*mchsqr/mpasqr*(1.-xphoto)/(1.-xphoto+(mchsqr-mnesqr)/
16844  + mpasqr)**2
16845  beta=sqrt(1.-xx)
16846  phint = 2d0/(1d0+costhg**2*beta**2)
16847  ELSE
16848  phint = 1d0
16849  ENDIF
16850  END
16851 *CMZ : 1.01/14 14/05/95 11.26.28 BY PIERO ZUCCHELLI
16852 *CMZ : 1.01/08 05/03/95 11.39.27 BY PIERO ZUCCHELLI
16853 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
16854 *-- AUTHOR :
16855  SUBROUTINE phlupa(IPOINT)
16856 C.----------------------------------------------------------------------
16857 C.
16858 C. PHLUPA: DEBUGGING TOOL
16859 C.
16860 C. PURPOSE: NONE, EVENTUALLY MAY PRINTOUT CONTENT OF THE
16861 C. /PHOEVT/ COMMON
16862 C.
16863 C. INPUT PARAMETERS: COMMON /PHOEVT/ AND /PHNUM/
16864 C. LATTER MAY HAVE NUMBER OF THE EVENT.
16865 C.
16866 C. OUTPUT PARAMETERS: NONE
16867 C.
16868 C. AUTHOR(S): Z. WAS CREATED AT: 30/05/93
16869 C. LAST UPDATE: 10/08/93
16870 C.
16871 C.----------------------------------------------------------------------
16872  INTEGER nmxpho
16873  parameter(nmxpho=2000)
16874  INTEGER idpho,istpho,jdapho,jmopho,nevpho,npho
16875  REAL ppho,vpho
16876  common/phoevt/nevpho,npho,istpho(nmxpho),idpho(nmxpho),
16877  +jmopho(2,nmxpho),jdapho(2,nmxpho),ppho(5,nmxpho),vpho(4,nmxpho)
16878  COMMON /phnum/ iev
16879  INTEGER phlun
16880  common/pholun/phlun
16881  dimension sum(5)
16882  IF (ipoint.LT.3000) RETURN
16883  iout=56
16884  IF (iev.LT.1000) THEN
16885  DO i=1,5
16886  sum(i)=0.0
16887  ENDDO
16888  WRITE(phlun,*) 'EVENT NR=',iev, 'WE ARE TESTING /PHOEVT/ AT '
16889  + //'IPOINT=',ipoint
16890  WRITE(phlun,10000)
16891  i=1
16892  WRITE(phlun,10100) idpho(i),ppho(1,i),ppho(2,i),ppho(3,i),
16893  + ppho(4, i),ppho(5,i),jdapho(1,i),jdapho(2,i)
16894  i=2
16895  WRITE(phlun,10100) idpho(i),ppho(1,i),ppho(2,i),ppho(3,i),
16896  + ppho(4, i),ppho(5,i),jdapho(1,i),jdapho(2,i)
16897  WRITE(phlun,*) ' '
16898  DO i=3,npho
16899  WRITE(phlun,10100) idpho(i),ppho(1,i),ppho(2,i),ppho(3,i),
16900  + ppho(4,i),ppho(5,i),jmopho(1,i),jmopho(2,i)
16901  DO j=1,4
16902  sum(j)=sum(j)+ppho(j,i)
16903  ENDDO
16904  ENDDO
16905  sum(5)=sqrt(abs(sum(4)**2-sum(1)**2-sum(2)**2-sum(3)**2))
16906  WRITE(phlun,10200) sum
16907 10000 FORMAT(1x,' ID ','P_X ','P_Y ','P_Z ',
16908  + 'E ','M ',
16909  + 'ID-MO_DA1','ID-MO DA2' )
16910 10100 FORMAT(1x,i4,5(f9.3),2i9)
16911 10200 FORMAT(1x,' SUM',5(f9.3))
16912  ENDIF
16913  END
16914 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
16915 *-- AUTHOR :
16916  FUNCTION phoan1(X,Y)
16917 C.----------------------------------------------------------------------
16918 C.
16919 C. PHOTOS: PHOTON RADIATION IN DECAYS CALCULATION OF ANGLE '1'
16920 C.
16921 C. PURPOSE: CALCULATE ANGLE FROM X AND Y
16922 C.
16923 C. INPUT PARAMETERS: X, Y
16924 C.
16925 C. OUTPUT PARAMETER: FUNCTION VALUE
16926 C.
16927 C. AUTHOR(S): S. JADACH CREATED AT: 01/01/89
16928 C. B. VAN EIJK LAST UPDATE: 02/01/90
16929 C.
16930 C.----------------------------------------------------------------------
16931 C-- IMPLICIT NONE
16932  DOUBLE PRECISION phoan1
16933  REAL x,y
16934  REAL pi,twopi
16935  common/phpico/pi,twopi
16936  IF (abs(y).LT.abs(x)) THEN
16937  phoan1=atan(abs(y/x))
16938  IF (x.LE.0.) phoan1=pi-phoan1
16939  ELSE
16940  phoan1=acos(x/sqrt(x**2+y**2))
16941  ENDIF
16942  IF (y.LT.0.) phoan1=twopi-phoan1
16943  RETURN
16944  END
16945 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
16946 *-- AUTHOR :
16947  FUNCTION phoan2(X,Y)
16948 C.----------------------------------------------------------------------
16949 C.
16950 C. PHOTOS: PHOTON RADIATION IN DECAYS CALCULATION OF ANGLE '2'
16951 C.
16952 C. PURPOSE: CALCULATE ANGLE FROM X AND Y
16953 C.
16954 C. INPUT PARAMETERS: X, Y
16955 C.
16956 C. OUTPUT PARAMETER: FUNCTION VALUE
16957 C.
16958 C. AUTHOR(S): S. JADACH CREATED AT: 01/01/89
16959 C. B. VAN EIJK LAST UPDATE: 02/01/90
16960 C.
16961 C.----------------------------------------------------------------------
16962 C-- IMPLICIT NONE
16963  DOUBLE PRECISION phoan2
16964  REAL x,y
16965  REAL pi,twopi
16966  common/phpico/pi,twopi
16967  IF (abs(y).LT.abs(x)) THEN
16968  phoan2=atan(abs(y/x))
16969  IF (x.LE.0.) phoan2=pi-phoan2
16970  ELSE
16971  phoan2=acos(x/sqrt(x**2+y**2))
16972  ENDIF
16973  RETURN
16974  END
16975 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
16976 *-- AUTHOR :
16977  SUBROUTINE phobo3(ANGLE,PVEC)
16978 C.----------------------------------------------------------------------
16979 C.
16980 C. PHOTOS: PHOTON RADIATION IN DECAYS BOOST ROUTINE '3'
16981 C.
16982 C. PURPOSE: BOOST VECTOR PVEC ALONG Z-AXIS WHERE ANGLE = EXP(ETA),
16983 C. ETA IS THE HYPERBOLIC VELOCITY.
16984 C.
16985 C. INPUT PARAMETERS: ANGLE, PVEC
16986 C.
16987 C. OUTPUT PARAMETER: PVEC
16988 C.
16989 C. AUTHOR(S): S. JADACH CREATED AT: 01/01/89
16990 C. B. VAN EIJK LAST UPDATE: 02/01/90
16991 C.
16992 C.----------------------------------------------------------------------
16993 C-- IMPLICIT NONE
16994  DOUBLE PRECISION qpl,qmi,angle
16995  REAL pvec(4)
16996  qpl=(pvec(4)+pvec(3))*angle
16997  qmi=(pvec(4)-pvec(3))/angle
16998  pvec(3)=(qpl-qmi)/2.
16999  pvec(4)=(qpl+qmi)/2.
17000  RETURN
17001  END
17002 *CMZ : 1.01/50 23/05/96 10.22.20 by Piero Zucchelli
17003 *CMZ : 1.01/08 05/03/95 11.39.27 BY PIERO ZUCCHELLI
17004 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
17005 *-- AUTHOR :
17006  SUBROUTINE phobos(IP,PBOOS1,PBOOS2,FIRST,LAST)
17007 C.----------------------------------------------------------------------
17008 C.
17009 C. PHOBOS: PHOTON RADIATION IN DECAYS BOOST ROUTINE
17010 C.
17011 C. PURPOSE: BOOST PARTICLES IN CASCADE DECAY TO PARENT REST FRAME
17012 C. AND BOOST BACK WITH MODIFIED BOOST VECTOR.
17013 C.
17014 C. INPUT PARAMETERS: IP: POINTER OF PARTICLE STARTING CHAIN
17015 C. TO BE BOOSTED
17016 C. PBOOS1: BOOST VECTOR TO REST FRAME,
17017 C. PBOOS2: BOOST VECTOR TO MODIFIED FRAME,
17018 C. FIRST: POINTER TO FIRST PARTICLE TO BE BOOS-
17019 C. TED (/HEPEVT/),
17020 C. LAST: POINTER TO LAST PARTICLE TO BE BOOS-
17021 C. TED (/HEPEVT/).
17022 C.
17023 C. OUTPUT PARAMETERS: COMMON /HEPEVT/.
17024 C.
17025 C. AUTHOR(S): B. VAN EIJK CREATED AT: 13/02/90
17026 C. Z. WAS LAST UPDATE: 16/11/93
17027 C.
17028 C.----------------------------------------------------------------------
17029 C-- IMPLICIT NONE
17030  DOUBLE PRECISION bet1(3),bet2(3),gam1,gam2,pb,data
17031  INTEGER i,j,first,last,maxsta,nstack,ip
17032  parameter(maxsta=2000)
17033  INTEGER stack(maxsta)
17034  REAL pboos1(5),pboos2(5)
17035  INTEGER nmxhep
17036  parameter(nmxhep=2000)
17037  INTEGER idhep,isthep,jdahep,jmohep,nevhep,nhep
17038  DOUBLE PRECISION phep,vhep
17039  common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),
17040  +jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)
17041  IF ((last.EQ.0).OR.(last.LT.first)) RETURN
17042  nstack=0
17043  DO 10 j=1,3
17044  bet1(j)=-pboos1(j)/pboos1(5)
17045  10 bet2(j)=pboos2(j)/pboos2(5)
17046  gam1=pboos1(4)/pboos1(5)
17047  gam2=pboos2(4)/pboos2(5)
17048 C--
17049 C-- BOOST VECTOR TO PARENT REST FRAME...
17050  20 DO 50 i=first,last
17051  pb=bet1(1)*phep(1,i)+bet1(2)*phep(2,i)+bet1(3)*phep(3,i)
17052  IF (jmohep(1,i).EQ.ip) THEN
17053  DO 30 j=1,3
17054  30 phep(j,i)=phep(j,i)+bet1(j)*(phep(4,i)+pb/(gam1+1.))
17055  phep(4,i)=gam1*phep(4,i)+pb
17056 C--
17057 C-- ...AND BOOST BACK TO MODIFIED PARENT FRAME.
17058  pb=bet2(1)*phep(1,i)+bet2(2)*phep(2,i)+bet2(3)*phep(3,i)
17059  DO 40 j=1,3
17060  40 phep(j,i)=phep(j,i)+bet2(j)*(phep(4,i)+pb/(gam2+1.))
17061  phep(4,i)=gam2*phep(4,i)+pb
17062  IF (jdahep(1,i).NE.0) THEN
17063  nstack=nstack+1
17064 C--
17065 C-- CHECK ON STACK LENGTH...
17066  IF (nstack.GT.maxsta) THEN
17067  data=nstack
17068  CALL phoerr(7,'PHOBOS',data)
17069  ENDIF
17070  stack(nstack)=i
17071  ENDIF
17072  ENDIF
17073  50 CONTINUE
17074  IF (nstack.NE.0) THEN
17075 C--
17076 C-- NOW GO ONE STEP FURTHER IN THE DECAY TREE...
17077  first=jdahep(1,stack(nstack))
17078  last=jdahep(2,stack(nstack))
17079  ip=stack(nstack)
17080  nstack=nstack-1
17081  goto 20
17082  ENDIF
17083  RETURN
17084  END
17085 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
17086 *-- AUTHOR :
17087  FUNCTION phocha(IDHEP)
17088 C.----------------------------------------------------------------------
17089 C.
17090 C. PHOTOS: PHOTON RADIATION IN DECAYS CHARGE DETERMINATION
17091 C.
17092 C. PURPOSE: CALCULATE THE CHARGE OF PARTICLE WITH CODE IDHEP. THE
17093 C. CODE OF THE PARTICLE IS DEFINED BY THE PARTICLE DATA
17094 C. GROUP IN PHYS. LETT. B204 (1988) 1.
17095 C.
17096 C. INPUT PARAMETER: IDHEP
17097 C.
17098 C. OUTPUT PARAMETER: FUNTION VALUE = CHARGE OF PARTICLE WITH CODE
17099 C. IDHEP
17100 C.
17101 C. AUTHOR(S): E. BARBERIO AND B. VAN EIJK CREATED AT: 29/11/89
17102 C. LAST UPDATE: 02/01/90
17103 C.
17104 C.----------------------------------------------------------------------
17105 C-- IMPLICIT NONE
17106  REAL phocha
17107  INTEGER idhep,idabs,q1,q2,q3
17108 C--
17109 C-- ARRAY 'CHARGE' CONTAINS THE CHARGE OF THE FIRST 101 PARTICLES AC-
17110 C-- CORDING TO THE PDG PARTICLE CODE... (0 IS ADDED FOR CONVENIENCE)
17111  REAL charge(0:100)
17112  DATA charge/ 0.,
17113  &-0.3333333333, 0.6666666667, -0.3333333333, 0.6666666667,
17114  &-0.3333333333, 0.6666666667, -0.3333333333, 0.6666666667,
17115  & 2*0., -1., 0., -1., 0., -1., 0., -1., 6*0., 1., 12*0., 1., 63*0./
17116  idabs=abs(idhep)
17117  IF (idabs.LE.100) THEN
17118 C--
17119 C-- CHARGE OF QUARK, LEPTON, BOSON ETC....
17120  phocha = charge(idabs)
17121  ELSE
17122 C--
17123 C-- CHECK ON PARTICLE BUILD OUT OF QUARKS, UNPACK ITS CODE...
17124  q3=mod(idabs/1000,10)
17125  q2=mod(idabs/100,10)
17126  q1=mod(idabs/10,10)
17127  IF (q3.EQ.0) THEN
17128 C--
17129 C-- ...MESON...
17130  IF(mod(q2,2).EQ.0) THEN
17131  phocha=charge(q2)-charge(q1)
17132  ELSE
17133  phocha=charge(q1)-charge(q2)
17134  ENDIF
17135  ELSE
17136 C--
17137 C-- ...DIQUARKS OR BARYON.
17138  phocha=charge(q1)+charge(q2)+charge(q3)
17139  ENDIF
17140  ENDIF
17141 C--
17142 C-- FIND THE SIGN OF THE CHARGE...
17143  IF (idhep.LT.0.) phocha=-phocha
17144  RETURN
17145  END
17146 *CMZ : 1.01/14 14/05/95 11.26.28 BY PIERO ZUCCHELLI
17147 *CMZ : 1.01/08 05/03/95 11.39.27 BY PIERO ZUCCHELLI
17148 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
17149 *-- AUTHOR :
17150  SUBROUTINE phochk(JFIRST)
17151 C.----------------------------------------------------------------------
17152 C.
17153 C. PHOCHK: CHECKING BRANCH.
17154 C.
17155 C. PURPOSE: CHECKS WHETHER PARTICLES IN THE COMMON BLOCK /PHOEVT/
17156 C. CAN BE SERVED BY PHOMAK.
17157 C. JFIRST IS THE POSITION IN /HEPEVT/ (!) OF THE FIRST DAUGHTER
17158 C. OF SUB-BRANCH UNDER ACTION.
17159 C.
17160 C.
17161 C. AUTHOR(S): Z. WAS CREATED AT: 22/10/92
17162 C. LAST UPDATE: 16/10/93
17163 C.
17164 C.----------------------------------------------------------------------
17165 C ********************
17166 C-- IMPLICIT NONE
17167  INTEGER nmxpho
17168  parameter(nmxpho=2000)
17169  INTEGER idpho,istpho,jdapho,jmopho,nevpho,npho
17170  REAL ppho,vpho
17171  common/phoevt/nevpho,npho,istpho(nmxpho),idpho(nmxpho),
17172  +jmopho(2,nmxpho),jdapho(2,nmxpho),ppho(5,nmxpho),vpho(4,nmxpho)
17173  LOGICAL chkif
17174  common/phoif/chkif(nmxpho)
17175  INTEGER nmxhep
17176  parameter(nmxhep=2000)
17177  LOGICAL qedrad
17178  common/phoqed/qedrad(nmxhep)
17179  INTEGER jfirst
17180  LOGICAL f
17181  INTEGER idabs,nlast,i,ippar
17182  LOGICAL interf,isec,iftop
17183  REAL fint,fsec
17184  COMMON /phokey/ interf,fint,isec,fsec,iftop
17185  LOGICAL ifrad
17186  INTEGER ident,k
17187 C THESE ARE OK .... IF YOU DO NOT LIKE SOMEBODY ELSE, ADD HERE.
17188  f(idabs)=
17189  + ( ((idabs.GT.9).AND.(idabs.LE.40)) .OR. (idabs.GT.100) )
17190  + .AND.(idabs.NE.21)
17191  + .AND.(idabs.NE.2101).AND.(idabs.NE.3101).AND.(idabs.NE.3201)
17192  + .AND.(idabs.NE.1103).AND.(idabs.NE.2103).AND.(idabs.NE.2203)
17193  + .AND.(idabs.NE.3103).AND.(idabs.NE.3203).AND.(idabs.NE.3303)
17194 C
17195  nlast = npho
17196 C
17197  ippar=1
17198 C CHECKING FOR GOOD PARTICLES
17199  DO 10 i=ippar,nlast
17200  idabs = abs(idpho(i))
17201 C POSSIBLY CALL ON PHZODE IS A DEAD (TO BE OMITTED) CODE.
17202  chkif(i)= f(idabs) .AND.f(abs(idpho(1))) .AND. (idpho(2).EQ.0)
17203  IF(i.GT.2) chkif(i)=chkif(i).AND.qedrad(jfirst+i-ippar-2)
17204  10 CONTINUE
17205 C--
17206 C NOW WE GO TO SPECIAL CASES, WHERE CHKIF(I) WILL BE OVERWRITTEN
17207 C--
17208  IF(iftop) THEN
17209 C SPECIAL CASE OF TOP PAIR PRODUCTION
17210  DO k=jdapho(2,1),jdapho(1,1),-1
17211  IF(idpho(k).NE.22) THEN
17212  ident=k
17213  goto 20
17214  ENDIF
17215  ENDDO
17216  20 CONTINUE
17217  ifrad=((idpho(1).EQ.21).AND.(idpho(2).EQ.21))
17218  + .OR. ((abs(idpho(1)).LE.6).AND.((idpho(2)).EQ.(-idpho(1))))
17219  ifrad=ifrad
17220  + .AND.(abs(idpho(3)).EQ.6).AND.((idpho(4)).EQ.(-idpho(3)))
17221  + .AND.(ident.EQ.4)
17222  IF(ifrad) THEN
17223  DO 30 i=ippar,nlast
17224  chkif(i)= .true.
17225  IF(i.GT.2) chkif(i)=chkif(i).AND.qedrad(jfirst+i-ippar-2)
17226  30 CONTINUE
17227  ENDIF
17228  ENDIF
17229 C--
17230 C--
17231  IF(iftop) THEN
17232 C SPECIAL CASE OF TOP DECAY
17233  DO k=jdapho(2,1),jdapho(1,1),-1
17234  IF(idpho(k).NE.22) THEN
17235  ident=k
17236  goto 40
17237  ENDIF
17238  ENDDO
17239  40 CONTINUE
17240  ifrad=((abs(idpho(1)).EQ.6).AND.(idpho(2).EQ.0))
17241  ifrad=ifrad
17242  + .AND.((abs(idpho(3)).EQ.24).AND.(abs(idpho(4)).EQ.5)
17243  + .OR.(abs(idpho(3)).EQ.5).AND.(abs(idpho(4)).EQ.24))
17244  + .AND.(ident.EQ.4)
17245  IF(ifrad) THEN
17246  DO 50 i=ippar,nlast
17247  chkif(i)= .true.
17248  IF(i.GT.2) chkif(i)=chkif(i).AND.qedrad(jfirst+i-ippar-2)
17249  50 CONTINUE
17250  ENDIF
17251  ENDIF
17252 C--
17253 C--
17254  END
17255 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
17256 *-- AUTHOR :
17257  SUBROUTINE phocin
17258 C.----------------------------------------------------------------------
17259 C.
17260 C. PHOTOS: PHOTON COMMON INITIALISATION
17261 C.
17262 C. PURPOSE: INITIALISATION OF PARAMETERS IN COMMON BLOCKS.
17263 C.
17264 C. INPUT PARAMETERS: NONE
17265 C.
17266 C. OUTPUT PARAMETERS: COMMONS /PHOLUN/, /PHOPHO/, /PHOCOP/, /PHPICO/
17267 C. AND /PHSEED/.
17268 C.
17269 C. AUTHOR(S): B. VAN EIJK CREATED AT: 26/11/89
17270 C. Z. WAS LAST UPDATE: 10/08/93
17271 C.
17272 C.----------------------------------------------------------------------
17273 C-- IMPLICIT NONE
17274  INTEGER nmxhep
17275  parameter(nmxhep=2000)
17276  LOGICAL qedrad
17277  common/phoqed/qedrad(nmxhep)
17278  INTEGER phlun
17279  common/pholun/phlun
17280  REAL alpha,xphcut
17281  common/phocop/alpha,xphcut
17282  REAL pi,twopi
17283  common/phpico/pi,twopi
17284  INTEGER iseed,i97,j97
17285  REAL uran,cran,cdran,cmran
17286  common/phseed/iseed(2),i97,j97,uran(97),cran,cdran,cmran
17287  INTEGER phomes
17288  parameter(phomes=10)
17289  INTEGER status
17290  common/phosta/status(phomes)
17291  LOGICAL interf,isec,iftop
17292  REAL fint,fsec
17293  COMMON /phokey/ interf,fint,isec,fsec,iftop
17294  INTEGER init,i
17295  SAVE init
17296  DATA init/ 0/
17297 C--
17298 C-- RETURN IF ALREADY INITIALIZED...
17299  IF (init.NE.0) RETURN
17300  init=1
17301 C--
17302 C-- PRESET SWITCH FOR PHOTON EMISSION TO 'TRUE' FOR EACH PARTICLE IN
17303 C-- /HEPEVT/, THIS INTERFACE IS NEEDED FOR KORALB AND KORALZ...
17304  DO 10 i=1,nmxhep
17305  10 qedrad(i)=.true.
17306 C--
17307 C-- LOGICAL OUTPUT UNIT FOR PRINTING OF PHOTOS ERROR MESSAGES
17308  phlun=6
17309 C--
17310 C-- SET CUT PARAMETER FOR PHOTON RADIATION
17311  xphcut=0.01
17312 C--
17313 C-- DEFINE SOME CONSTANTS
17314  alpha=0.00729735039
17315  pi=3.14159265358979324
17316  twopi=6.28318530717958648
17317 C--
17318 C-- DEFAULT SEEDS MARSAGLIA AND ZAMAN RANDOM NUMBER GENERATOR
17319  iseed(1)=1802
17320  iseed(2)=9373
17321 C--
17322 C-- IITIALIZATION FOR EXTRA OPTIONS
17323 C-- (1)
17324 C-- INTERFERENCE WEIGHT FOR TWO BODY SYMMETRIC CHANNELS ONLY.
17325  interf=.true.
17326 C-- (2)
17327 C-- SECOND ORDER - DOUBLE PHOTON SWITCH
17328  isec=.true.
17329 C-- (3)
17330 C-- EMISION IN THE HARD PROCESS G G (Q QBAR) --> T TBAR
17331 C-- T --> W B
17332  iftop=.true.
17333 C--
17334 C-- FURTHER INITIALIZATION DONE AUTOMATICALLY
17335  IF (interf) THEN
17336 C-- BEST CHOICE IS IF FINT=2**N WHERE N+1 IS MAXIMAL NUMBER OF CHARGED DAUGHTE
17337 C-- SEE REPORT ON OVERWEIHTED EVENTS
17338  fint=2.0
17339  ELSE
17340  fint=1.0
17341  ENDIF
17342 C-- INITIALISE STATUS COUNTER FOR WARNING MESSAGES
17343  DO 20 i=1,phomes
17344  20 status(i)=0
17345  RETURN
17346  END
17347 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
17348 *-- AUTHOR :
17349  FUNCTION phocor(MPASQR,MCHREN,ME)
17350 C.----------------------------------------------------------------------
17351 C.
17352 C. PHOTOS: PHOTON RADIATION IN DECAYS CORRECTION WEIGHT FROM
17353 C. MATRIX ELEMENTS
17354 C.
17355 C. PURPOSE: CALCULATE PHOTON ANGLE. THE RESHAPING FUNCTIONS WILL
17356 C. HAVE TO DEPEND ON THE SPIN S OF THE CHARGED PARTICLE.
17357 C. WE DEFINE: ME = 2 * S + 1 !
17358 C.
17359 C. INPUT PARAMETERS: MPASQR: PARENT MASS SQUARED,
17360 C. MCHREN: RENORMALISED MASS OF CHARGED SYSTEM,
17361 C. ME: 2 * SPIN + 1 DETERMINES MATRIX ELEMENT
17362 C.
17363 C. OUTPUT PARAMETER: FUNCTION VALUE.
17364 C.
17365 C. AUTHOR(S): Z. WAS, B. VAN EIJK CREATED AT: 26/11/89
17366 C. LAST UPDATE: 21/03/93
17367 C.
17368 C.----------------------------------------------------------------------
17369 C-- IMPLICIT NONE
17370  DOUBLE PRECISION mpasqr,mchren,beta,xx,yy,data
17371  INTEGER me
17372  REAL phocor,phofac,wt1,wt2,wt3
17373  DOUBLE PRECISION mchsqr,mnesqr
17374  REAL pneutr
17375  common/phomom/mchsqr,mnesqr,pneutr(5)
17376  DOUBLE PRECISION costhg,sinthg
17377  REAL xphmax,xphoto
17378  common/phophs/xphmax,xphoto,costhg,sinthg
17379  INTEGER irep
17380  REAL probh,corwt,xf
17381  common/phopro/irep,probh,corwt,xf
17382 C--
17383 C-- SHAPING (MODIFIED BY ZW)...
17384  xx=4.*mchsqr/mpasqr*(1.-xphoto)/(1.-xphoto+(mchsqr-mnesqr)/
17385  &mpasqr)**2
17386  IF (me.EQ.1) THEN
17387  yy=1.
17388  wt3=(1.-xphoto/xphmax)/((1.+(1.-xphoto/xphmax)**2)/2.)
17389  ELSEIF (me.EQ.2) THEN
17390  yy=0.5*(1.-xphoto/xphmax+1./(1.-xphoto/xphmax))
17391  wt3=1.
17392  ELSEIF ((me.EQ.3).OR.(me.EQ.4).OR.(me.EQ.5)) THEN
17393  yy=1.
17394  wt3=(1.+(1.-xphoto/xphmax)**2-(xphoto/xphmax)**3)/(1.+(1.
17395  & -xphoto/xphmax)** 2)
17396  ELSE
17397  data=(me-1.)/2.
17398  CALL phoerr(6,'PHOCOR',data)
17399  yy=1.
17400  wt3=1.
17401  ENDIF
17402  beta=sqrt(1.-xx)
17403  wt1=(1.-costhg*sqrt(1.-mchren))/(1.-costhg*beta)
17404  wt2=(1.-xx/yy/(1.-beta**2*costhg**2))*(1.+costhg*beta)/2.
17405  wt2=wt2*phofac(1)
17406  phocor=wt1*wt2*wt3
17407  corwt=phocor
17408  IF (phocor.GT.1.) THEN
17409  data=phocor
17410  CALL phoerr(3,'PHOCOR',data)
17411  ENDIF
17412  RETURN
17413  END
17414 *CMZ : 1.01/14 14/05/95 11.26.28 BY PIERO ZUCCHELLI
17415 *CMZ : 1.01/08 05/03/95 11.39.27 BY PIERO ZUCCHELLI
17416 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
17417 *-- AUTHOR :
17418  SUBROUTINE phodo(IP,NCHARB,NEUDAU)
17419 C.----------------------------------------------------------------------
17420 C.
17421 C. PHOTOS: PHOTON RADIATION IN DECAYS DOING OF KINEMATICS
17422 C.
17423 C. PURPOSE: STARTING FROM THE CHARGED PARTICLE ENERGY/MOMENTUM,
17424 C. PNEUTR, PHOTON ENERGY FRACTION AND PHOTON ANGLE WITH
17425 C. RESPECT TO THE AXIS FORMED BY CHARGED PARTICLE ENERGY/
17426 C. MOMENTUM VECTOR AND PNEUTR, SCALE THE ENERGY/MOMENTUM,
17427 C. KEEPING THE ORIGINAL DIRECTION OF THE NEUTRAL SYSTEM IN
17428 C. THE LAB. FRAME UNTOUCHED.
17429 C.
17430 C. INPUT PARAMETERS: IP: POINTER TO DECAYING PARTICLE IN
17431 C. /PHOEVT/ AND THE COMMON ITSELF
17432 C. NCHARB: POINTER TO THE CHARGED RADIATING
17433 C. DAUGHTER IN /PHOEVT/.
17434 C. NEUDAU: POINTER TO THE FIRST NEUTRAL DAUGHTER
17435 C. OUTPUT PARAMETERS: COMMON /PHOEVT/, WITH PHOTON ADDED.
17436 C.
17437 C. AUTHOR(S): Z. WAS, B. VAN EIJK CREATED AT: 26/11/89
17438 C. LAST UPDATE: 27/05/93
17439 C.
17440 C.----------------------------------------------------------------------
17441 C-- IMPLICIT NONE
17442  DOUBLE PRECISION phoan1,phoan2,angle,fi1,fi3,fi4,fi5,th1,th3,th4
17443  DOUBLE PRECISION parne,qnew,qold,data
17444  INTEGER ip,fi3dum,i,j,neudau,first,last
17445  INTEGER ncharb
17446  REAL ephoto,pmavir,photri
17447  REAL gneut,phoran,ccosth,ssinth,pvec(4)
17448  INTEGER nmxpho
17449  parameter(nmxpho=2000)
17450  INTEGER idpho,istpho,jdapho,jmopho,nevpho,npho
17451  REAL ppho,vpho
17452  common/phoevt/nevpho,npho,istpho(nmxpho),idpho(nmxpho),
17453  +jmopho(2,nmxpho),jdapho(2,nmxpho),ppho(5,nmxpho),vpho(4,nmxpho)
17454  DOUBLE PRECISION mchsqr,mnesqr
17455  REAL pneutr
17456  common/phomom/mchsqr,mnesqr,pneutr(5)
17457  DOUBLE PRECISION costhg,sinthg
17458  REAL xphmax,xphoto
17459  common/phophs/xphmax,xphoto,costhg,sinthg
17460  REAL pi,twopi
17461  common/phpico/pi,twopi
17462 C--
17463  ephoto=xphoto*ppho(5,ip)/2.
17464  pmavir=sqrt(ppho(5,ip)*(ppho(5,ip)-2.*ephoto))
17465 C--
17466 C-- RECONSTRUCT KINEMATICS OF CHARGED PARTICLE AND NEUTRAL SYSTEM
17467  fi1=phoan1(pneutr(1),pneutr(2))
17468 C--
17469 C-- CHOOSE AXIS ALONG Z OF PNEUTR, CALCULATE ANGLE BETWEEN X AND Y
17470 C-- COMPONENTS AND Z AND X-Y PLANE AND PERFORM LORENTZ TRANSFORM...
17471  th1=phoan2(pneutr(3),sqrt(pneutr(1)**2+pneutr(2)**2))
17472  CALL phoro3(-fi1,pneutr(1))
17473  CALL phoro2(-th1,pneutr(1))
17474 C--
17475 C-- TAKE AWAY PHOTON ENERGY FROM CHARGED PARTICLE AND PNEUTR ! THUS
17476 C-- THE ONSHELL CHARGED PARTICLE DECAYS INTO VIRTUAL CHARGED PARTICLE
17477 C-- AND PHOTON. THE VIRTUAL CHARGED PARTICLE MASS BECOMES:
17478 C-- SQRT(PPHO(5,IP)*(PPHO(5,IP)-2*EPHOTO)). CONSTRUCT NEW PNEUTR MO-
17479 C-- MENTUM IN THE REST FRAME OF THE PARENT:
17480 C-- 1) SCALING PARAMETERS...
17481  qnew=photri(pmavir,pneutr(5),ppho(5,ncharb))
17482  qold=pneutr(3)
17483  gneut=(qnew**2+qold**2+mnesqr)/(qnew*qold+sqrt((qnew**2+mnesqr)*
17484  +(qold**2+mnesqr)))
17485  IF (gneut.LT.1.) THEN
17486  data=0.
17487  CALL phoerr(4,'PHOKIN',data)
17488  ENDIF
17489  parne=gneut-sqrt(max(gneut**2-1.0,0.))
17490 C--
17491 C-- 2) ...REDUCTIVE BOOST...
17492  CALL phobo3(parne,pneutr)
17493 C--
17494 C-- ...CALCULATE PHOTON ENERGY IN THE REDUCED SYSTEM...
17495  npho=npho+1
17496  istpho(npho)=1
17497  idpho(npho) =22
17498 C-- PHOTON MOTHER AND DAUGHTER POINTERS !
17499  jmopho(1,npho)=ip
17500  jmopho(2,npho)=0
17501  jdapho(1,npho)=0
17502  jdapho(2,npho)=0
17503  ppho(4,npho)=ephoto*ppho(5,ip)/pmavir
17504 C--
17505 C-- ...AND PHOTON MOMENTA
17506  ccosth=-costhg
17507  ssinth=sinthg
17508  th3=phoan2(ccosth,ssinth)
17509  fi3=twopi*phoran(fi3dum)
17510  ppho(1,npho)=ppho(4,npho)*sinthg*cos(fi3)
17511  ppho(2,npho)=ppho(4,npho)*sinthg*sin(fi3)
17512 C--
17513 C-- MINUS SIGN BECAUSE AXIS OPPOSITE DIRECTION OF CHARGED PARTICLE !
17514  ppho(3,npho)=-ppho(4,npho)*costhg
17515  ppho(5,npho)=0.
17516 C--
17517 C-- ROTATE IN ORDER TO GET PHOTON ALONG Z-AXIS
17518  CALL phoro3(-fi3,pneutr(1))
17519  CALL phoro3(-fi3,ppho(1,npho))
17520  CALL phoro2(-th3,pneutr(1))
17521  CALL phoro2(-th3,ppho(1,npho))
17522  angle=ephoto/ppho(4,npho)
17523 C--
17524 C-- BOOST TO THE REST FRAME OF DECAYING PARTICLE
17525  CALL phobo3(angle,pneutr(1))
17526  CALL phobo3(angle,ppho(1,npho))
17527 C--
17528 C-- BACK IN THE PARENT REST FRAME BUT PNEUTR NOT YET ORIENTED !
17529  fi4=phoan1(pneutr(1),pneutr(2))
17530  th4=phoan2(pneutr(3),sqrt(pneutr(1)**2+pneutr(2)**2))
17531  CALL phoro3(fi4,pneutr(1))
17532  CALL phoro3(fi4,ppho(1,npho))
17533 C--
17534  DO 10 i=2,4
17535  10 pvec(i)=0.
17536  pvec(1)=1.
17537  CALL phoro3(-fi3,pvec)
17538  CALL phoro2(-th3,pvec)
17539  CALL phobo3(angle,pvec)
17540  CALL phoro3(fi4,pvec)
17541  CALL phoro2(-th4,pneutr)
17542  CALL phoro2(-th4,ppho(1,npho))
17543  CALL phoro2(-th4,pvec)
17544  fi5=phoan1(pvec(1),pvec(2))
17545 C--
17546 C-- CHARGED PARTICLE RESTORES ORIGINAL DIRECTION
17547  CALL phoro3(-fi5,pneutr)
17548  CALL phoro3(-fi5,ppho(1,npho))
17549  CALL phoro2(th1,pneutr(1))
17550  CALL phoro2(th1,ppho(1,npho))
17551  CALL phoro3(fi1,pneutr)
17552  CALL phoro3(fi1,ppho(1,npho))
17553 C-- SEE WHETHER NEUTRAL SYSTEM HAS MULTIPLICITY LARGER THAN 1...
17554  IF ((jdapho(2,ip)-jdapho(1,ip)).GT.1) THEN
17555 C-- FIND POINTERS TO COMPONENTS OF 'NEUTRAL' SYSTEM
17556 C--
17557  first=neudau
17558  last=jdapho(2,ip)
17559  DO 20 i=first,last
17560  IF (i.NE.ncharb.AND.(jmopho(1,i).EQ.ip)) THEN
17561 C--
17562 C-- RECONSTRUCT KINEMATICS...
17563  CALL phoro3(-fi1,ppho(1,i))
17564  CALL phoro2(-th1,ppho(1,i))
17565 C--
17566 C-- ...REDUCTIVE BOOST
17567  CALL phobo3(parne,ppho(1,i))
17568 C--
17569 C-- ROTATE IN ORDER TO GET PHOTON ALONG Z-AXIS
17570  CALL phoro3(-fi3,ppho(1,i))
17571  CALL phoro2(-th3,ppho(1,i))
17572 C--
17573 C-- BOOST TO THE REST FRAME OF DECAYING PARTICLE
17574  CALL phobo3(angle,ppho(1,i))
17575 C--
17576 C-- BACK IN THE PARENT REST-FRAME BUT PNEUTR NOT YET ORIENTED.
17577  CALL phoro3(fi4,ppho(1,i))
17578  CALL phoro2(-th4,ppho(1,i))
17579 C--
17580 C-- CHARGED PARTICLE RESTORES ORIGINAL DIRECTION
17581  CALL phoro3(-fi5,ppho(1,i))
17582  CALL phoro2(th1,ppho(1,i))
17583  CALL phoro3(fi1,ppho(1,i))
17584  ENDIF
17585  20 CONTINUE
17586  ELSE
17587 C--
17588 C-- ...ONLY ONE 'NEUTRAL' PARTICLE IN ADDITION TO PHOTON!
17589  DO 30 j=1,4
17590  30 ppho(j,neudau)=pneutr(j)
17591  ENDIF
17592 C--
17593 C-- ALL 'NEUTRALS' TREATED, FILL /PHOEVT/ FOR CHARGED PARTICLE...
17594  DO 40 j=1,3
17595  40 ppho(j,ncharb)=-(ppho(j,npho)+pneutr(j))
17596  ppho(4,ncharb)=ppho(5,ip)-(ppho(4,npho)+pneutr(4))
17597 C--
17598  END
17599 *CMZ : 1.01/50 19/04/96 12.03.42 by Piero Zucchelli
17600 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
17601 *-- AUTHOR :
17602  SUBROUTINE phoene(MPASQR,MCHREN,BETA,IDENT)
17603 C.----------------------------------------------------------------------
17604 C.
17605 C. PHOTOS: PHOTON RADIATION IN DECAYS CALCULATION OF PHOTON ENERGY
17606 C. FRACTION
17607 C.
17608 C. PURPOSE: SUBROUTINE RETURNS PHOTON ENERGY FRACTION (IN (PARENT
17609 C. MASS)/2 UNITS) FOR THE DECAY BREMSSTRAHLUNG.
17610 C.
17611 C. INPUT PARAMETERS: MPASQR: MASS OF DECAYING SYSTEM SQUARED,
17612 C. XPHCUT: MINIMUM ENERGY FRACTION OF PHOTON,
17613 C. XPHMAX: MAXIMUM ENERGY FRACTION OF PHOTON.
17614 C.
17615 C. OUTPUT PARAMETER: MCHREN: RENORMALISED MASS SQUARED,
17616 C. BETA: BETA FACTOR DUE TO RENORMALISATION,
17617 C. XPHOTO: PHOTON ENERGY FRACTION,
17618 C. XF: CORRECTION FACTOR FOR PHOFAC.
17619 C.
17620 C. AUTHOR(S): S. JADACH, Z. WAS CREATED AT: 01/01/89
17621 C. B. VAN EIJK LAST UPDATE: 26/03/93
17622 C.
17623 C.----------------------------------------------------------------------
17624 C-- IMPLICIT NONE
17625 
17626  DOUBLE PRECISION mpasqr,mchren,biglog,beta,data
17627  INTEGER iwt1,irn,iwt2
17628  REAL prsoft,prhard,phoran,phofac
17629  DOUBLE PRECISION mchsqr,mnesqr
17630  REAL pneutr
17631  INTEGER ident
17632  REAL phocha
17633  common/phomom/mchsqr,mnesqr,pneutr(5)
17634  DOUBLE PRECISION costhg,sinthg
17635  REAL xphmax,xphoto
17636  common/phophs/xphmax,xphoto,costhg,sinthg
17637  REAL alpha,xphcut
17638  common/phocop/alpha,xphcut
17639  REAL pi,twopi
17640  common/phpico/pi,twopi
17641  INTEGER irep
17642  REAL probh,corwt,xf
17643  common/phopro/irep,probh,corwt,xf
17644  LOGICAL interf,isec,iftop
17645  REAL fint,fsec
17646  COMMON /phokey/ interf,fint,isec,fsec,iftop
17647 C--
17648  IF (xphmax.LE.xphcut) THEN
17649  xphoto=0.0
17650  RETURN
17651  ENDIF
17652 C-- PROBABILITIES FOR HARD AND SOFT BREMSTRAHLUNG...
17653  mchren=4.*mchsqr/mpasqr/(1.+mchsqr/mpasqr)**2
17654  beta=sqrt(1.-mchren)
17655  biglog=log(mpasqr/mchsqr*(1.+beta)**2/4.*(1.+mchsqr/mpasqr)**2)
17656  prhard=alpha/pi/beta*biglog*(log(xphmax/xphcut)-.75+xphcut/
17657  &xphmax-.25*xphcut**2/xphmax**2)
17658  prhard=prhard*phocha(ident)**2*fint*fsec
17659  IF (irep.EQ.0) probh=0.
17660  prhard=prhard*phofac(0)
17661  probh=prhard
17662  prsoft=1.-prhard
17663 C--
17664 C-- CHECK ON KINEMATICAL BOUNDS
17665  IF (prsoft.LT.0.1) THEN
17666  data=prsoft
17667  CALL phoerr(2,'PHOENE',data)
17668  ENDIF
17669  IF (phoran(iwt1).LT.prsoft) THEN
17670 C--
17671 C-- NO PHOTON... (IE. PHOTON TOO SOFT)
17672  xphoto=0.
17673  ELSE
17674 C--
17675 C-- HARD PHOTON... (IE. PHOTON HARD ENOUGH).
17676 C-- CALCULATE ALTARELLI-PARISI KERNEL
17677  10 xphoto=exp(phoran(irn)*log(xphcut/xphmax))
17678  xphoto=xphoto*xphmax
17679  IF (phoran(iwt2).GT.((1.+(1.-xphoto/xphmax)**2)/2.)) goto 10
17680  ENDIF
17681 C--
17682 C-- CALCULATE PARAMETER FOR PHOFAC FUNCTION
17683  xf=4.*mchsqr*mpasqr/(mpasqr+mchsqr-mnesqr)**2
17684  RETURN
17685  END
17686 *CMZ : 1.02/02 12/01/97 17.54.22 by P. Zucchelli
17687 *CMZ : 1.01/14 14/05/95 11.26.28 BY PIERO ZUCCHELLI
17688 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
17689 *-- AUTHOR :
17690  SUBROUTINE phoerr(IMES,TEXT,DATA)
17691 C.----------------------------------------------------------------------
17692 C.
17693 C. PHOTOS: PHOTON RADIATION IN DECAYS ERRROR HANDLING
17694 C.
17695 C. PURPOSE: INFORM USER ABOUT (FATAL) ERRORS AND WARNINGS GENERATED
17696 C. BY EITHER THE USER OR THE PROGRAM.
17697 C.
17698 C. INPUT PARAMETERS: IMES, TEXT, DATA
17699 C.
17700 C. OUTPUT PARAMETERS: NONE
17701 C.
17702 C. AUTHOR(S): B. VAN EIJK CREATED AT: 29/11/89
17703 C. LAST UPDATE: 10/01/92
17704 C.
17705 C.----------------------------------------------------------------------
17706 C-- IMPLICIT NONE
17707  DOUBLE PRECISION data
17708  INTEGER imes,ierror
17709  REAL sdata
17710  INTEGER phlun
17711  common/pholun/phlun
17712  INTEGER phomes
17713  parameter(phomes=10)
17714  INTEGER status
17715  common/phosta/status(phomes)
17716  CHARACTER text*(*)
17717  SAVE ierror
17718 C-- SECURITY STOP SWITCH
17719  LOGICAL isec
17720  SAVE isec
17721  DATA ierror/ 0/
17722  DATA isec /.true./
17723  IF (imes.LE.phomes) status(imes)=status(imes)+1
17724 C--
17725 C-- COUNT NUMBER OF NON-FATAL ERRORS...
17726  IF ((imes.EQ. 6).AND.(status(imes).GE.2)) RETURN
17727  IF ((imes.EQ.10).AND.(status(imes).GE.2)) RETURN
17728  sdata=DATA
17729  WRITE(phlun,10000)
17730  WRITE(phlun,11100)
17731  goto(10,20,30,40,50,60,70,80,90,100),imes
17732  WRITE(phlun,11200) imes
17733  goto 120
17734  10 WRITE(phlun,10100) text,int(sdata)
17735  goto 110
17736  20 WRITE(phlun,10200) text,sdata
17737  goto 110
17738  30 WRITE(phlun,10300) text,sdata
17739  goto 110
17740  40 WRITE(phlun,10400) text
17741  goto 110
17742  50 WRITE(phlun,10500) text,int(sdata)
17743  goto 110
17744  60 WRITE(phlun,10600) text,sdata
17745  goto 130
17746  70 WRITE(phlun,10700) text,int(sdata)
17747  goto 110
17748  80 WRITE(phlun,10800) text,int(sdata)
17749  goto 110
17750  90 WRITE(phlun,10900) text,int(sdata)
17751  goto 110
17752  100 WRITE(phlun,11000) text,sdata
17753  goto 130
17754  110 CONTINUE
17755  WRITE(phlun,11300)
17756  WRITE(phlun,11100)
17757  WRITE(phlun,10000)
17758  IF (isec) THEN
17759  stop
17760  ELSE
17761  goto 130
17762  ENDIF
17763  120 ierror=ierror+1
17764  IF (ierror.GE.10) THEN
17765  WRITE(phlun,11400)
17766  WRITE(phlun,11100)
17767  WRITE(phlun,10000)
17768  IF (isec) THEN
17769  stop
17770  ELSE
17771  goto 130
17772  ENDIF
17773  ENDIF
17774  130 WRITE(phlun,11100)
17775  WRITE(phlun,10000)
17776  RETURN
17777 10000 FORMAT(1h ,80('*'))
17778 10100 FORMAT(1h ,'* ',a,': TOO MANY CHARGED PARTICLES, NCHARG =',i6,t81,
17779  &'*')
17780 10200 FORMAT(1h ,'* ',a,': TOO MUCH BREMSSTRAHLUNG REQUIRED, PRSOFT = ',
17781  &f15.6,t81,'*')
17782 10300 FORMAT(1h ,'* ',a,': COMBINED WEIGHT IS EXCEEDING 1., WEIGHT = ',
17783  &f15.6,t81,'*')
17784 10400 FORMAT(1h ,'* ',a,
17785  &': ERROR IN RESCALING CHARGED AND NEUTRAL VECTORS',t81,'*')
17786 10500 FORMAT(1h ,'* ',a,
17787  &': NON MATCHING CHARGED PARTICLE POINTER, NCHARG = ',i5,t81,'*')
17788 10600 FORMAT(1h ,'* ',a,
17789  &': DO YOU REALLY WORK WITH A PARTICLE OF SPIN: ',f4.1,' ?',t81,
17790  &'*')
17791 10700 FORMAT(1h ,'* ',a, ': STACK LENGTH EXCEEDED, NSTACK = ',i5 ,t81,
17792  &'*')
17793 10800 FORMAT(1h ,'* ',a,
17794  &': RANDOM NUMBER GENERATOR SEED(1) OUT OF RANGE: ',i8,t81,'*')
17795 10900 FORMAT(1h ,'* ',a,
17796  &': RANDOM NUMBER GENERATOR SEED(2) OUT OF RANGE: ',i8,t81,'*')
17797 11000 FORMAT(1h ,'* ',a,
17798  &': AVAILABLE PHASE SPACE BELOW CUT-OFF: ',f15.6,' GEV/C^2',t81,
17799  &'*')
17800 11100 FORMAT(1h ,'*',t81,'*')
17801 11200 FORMAT(1h ,'* FUNNY ERROR MESSAGE: ',i4,' ! WHAT TO DO ?',t81,'*')
17802 11300 FORMAT(1h ,'* FATAL ERROR MESSAGE, I STOP THIS RUN !',t81,'*')
17803 11400 FORMAT(1h ,'* 10 ERROR MESSAGES GENERATED, I STOP THIS RUN !',t81,
17804  &'*')
17805  END
17806 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
17807 *-- AUTHOR :
17808  FUNCTION phofac(MODE)
17809 C.----------------------------------------------------------------------
17810 C.
17811 C. PHOTOS: PHOTON RADIATION IN DECAYS CONTROL FACTOR
17812 C.
17813 C. PURPOSE: THIS IS THE CONTROL FUNCTION FOR THE PHOTON SPECTRUM AND
17814 C. FINAL WEIGHTING. IT IS CALLED FROM PHOENE FOR GENERA-
17815 C. TING THE RAW PHOTON ENERGY SPECTRUM (MODE=0) AND IN PHO-
17816 C. COR TO SCALE THE FINAL WEIGHT (MODE=1). THE FACTOR CON-
17817 C. SISTS OF 3 TERMS. ADDITION OF THE FACTOR FF WHICH MUL-
17818 C. TIPLIES PHOFAC FOR MODE=0 AND DIVIDES PHOFAC FOR MODE=1,
17819 C. DOES NOT AFFECT THE RESULTS FOR THE MC GENERATION. AN
17820 C. APPROPRIATE CHOICE FOR FF CAN SPEED UP THE CALCULATION.
17821 C. NOTE THAT A TOO SMALL VALUE OF FF MAY CAUSE WEIGHT OVER-
17822 C. FLOW IN PHOCOR AND WILL GENERATE A WARNING, HALTING THE
17823 C. EXECUTION. PRX SHOULD BE INCLUDED FOR REPEATED CALLS
17824 C. FOR THE SAME EVENT, ALLOWING MORE PARTICLES TO RADIATE
17825 C. PHOTONS. AT THE FIRST CALL IREP=0, FOR MORE THAN 1
17826 C. CHARGED DECAY PRODUCTS, IREP >= 1. THUS, PRSOFT (NO
17827 C. PHOTON RADIATION PROBABILITY IN THE PREVIOUS CALLS)
17828 C. APPROPRIATELY SCALES THE STRENGTH OF THE BREMSSTRAHLUNG.
17829 C.
17830 C. INPUT PARAMETERS: MODE, PROBH, XF
17831 C.
17832 C. OUTPUT PARAMETER: FUNCTION VALUE
17833 C.
17834 C. AUTHOR(S): S. JADACH, Z. WAS CREATED AT: 01/01/89
17835 C. B. VAN EIJK LAST UPDATE: 13/02/90
17836 C.
17837 C.----------------------------------------------------------------------
17838 C-- IMPLICIT NONE
17839  REAL phofac,ff,prx
17840  INTEGER mode
17841  INTEGER irep
17842  REAL probh,corwt,xf
17843  common/phopro/irep,probh,corwt,xf
17844  SAVE prx,ff
17845  DATA prx,ff/ 0., 0./
17846  IF (mode.EQ.0) THEN
17847  IF (irep.EQ.0) prx=1.
17848  prx=prx/(1.-probh)
17849  ff=1.
17850 C--
17851 C-- FOLLOWING OPTIONS ARE NOT CONSIDERED FOR THE TIME BEING...
17852 C-- (1) GOOD CHOICE, BUT DOES NOT SAVE VERY MUCH TIME:
17853 C-- FF=(1.0-SQRT(XF)/2.0)/(1.0+SQRT(XF)/2.0)
17854 C-- (2) TAKEN FROM THE BLUE, BUT WORKS WITHOUT WEIGHT OVERFLOWS...
17855 C-- FF=(1.-XF/(1-(1-SQRT(XF))**2))*(1+(1-SQRT(XF))/SQRT(1-XF))/2
17856  phofac=ff*prx
17857  ELSE
17858  phofac=1./ff
17859  ENDIF
17860  END
17861 *CMZ : 1.01/50 23/05/96 10.22.20 by Piero Zucchelli
17862 *CMZ : 1.01/08 05/03/95 11.39.27 BY PIERO ZUCCHELLI
17863 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
17864 *-- AUTHOR :
17865  SUBROUTINE phoin(IP,BOOST,NHEP0)
17866 C.----------------------------------------------------------------------
17867 C.
17868 C. PHOIN: PHOTOS INPUT
17869 C.
17870 C. PURPOSE: COPIES IP BRANCH OF THE COMMON /HEPEVT/ INTO /PHOEVT/
17871 C. MOVES BRANCH INTO ITS CMS SYSTEM.
17872 C.
17873 C. INPUT PARAMETERS: IP: POINTER OF PARTICLE STARTING BRANCH
17874 C. TO BE COPIED
17875 C. BOOST: FLAG WHETHER BOOST TO CMS WAS OR WAS
17876 C . NOT PERFORMED.
17877 C.
17878 C. OUTPUT PARAMETERS: COMMONS: /PHOEVT/, /PHOCMS/
17879 C.
17880 C. AUTHOR(S): Z. WAS CREATED AT: 24/05/93
17881 C. LAST UPDATE: 16/11/93
17882 C.
17883 C.----------------------------------------------------------------------
17884 C-- IMPLICIT NONE
17885  INTEGER nmxhep
17886  parameter(nmxhep=2000)
17887  INTEGER idhep,isthep,jdahep,jmohep,nevhep,nhep
17888  DOUBLE PRECISION phep,vhep
17889  common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),
17890  +jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)
17891  INTEGER nmxpho
17892  parameter(nmxpho=2000)
17893  INTEGER idpho,istpho,jdapho,jmopho,nevpho,npho
17894  REAL ppho,vpho
17895  common/phoevt/nevpho,npho,istpho(nmxpho),idpho(nmxpho),
17896  +jmopho(2,nmxpho),jdapho(2,nmxpho),ppho(5,nmxpho),vpho(4,nmxpho)
17897  INTEGER ip,ip2,i,first,last,ll,na
17898  LOGICAL boost
17899  INTEGER j,nhep0
17900  DOUBLE PRECISION bet(3),gam,pb
17901  COMMON /phocms/ bet,gam
17902  LOGICAL interf,isec,iftop
17903  REAL fint,fsec
17904  COMMON /phokey/ interf,fint,isec,fsec,iftop
17905 C--
17906 C LET'S CALCULATE SIZE OF THE LITTLE COMMON ENTRY
17907  first=jdahep(1,ip)
17908  last =jdahep(2,ip)
17909  npho=3+last-first+nhep-nhep0
17910  nevpho=npho
17911 C LET'S TAKE IN DECAYING PARTICLE
17912  idpho(1)=idhep(ip)
17913  jdapho(1,1)=3
17914  jdapho(2,1)=3+last-first
17915  DO i=1,5
17916  ppho(i,1)=phep(i,ip)
17917  ENDDO
17918 C LET'S TAKE IN EVENTUAL SECOND MOTHER
17919  ip2=jmohep(2,jdahep(1,ip))
17920  IF((ip2.NE.0).AND.(ip2.NE.ip)) THEN
17921  idpho(2)=idhep(ip2)
17922  jdapho(1,2)=3
17923  jdapho(2,2)=3+last-first
17924  DO i=1,5
17925  ppho(i,2)=phep(i,ip2)
17926  ENDDO
17927  ELSE
17928  idpho(2)=0
17929  DO i=1,5
17930  ppho(i,2)=0.0
17931  ENDDO
17932  ENDIF
17933 C LET'S TAKE IN DAUGHTERS
17934  DO ll=0,last-first
17935  idpho(3+ll)=idhep(first+ll)
17936  jmopho(1,3+ll)=jmohep(1,first+ll)
17937  IF (jmohep(1,first+ll).EQ.ip) jmopho(1,3+ll)=1
17938  DO i=1,5
17939  ppho(i,3+ll)=phep(i,first+ll)
17940  ENDDO
17941  ENDDO
17942  IF (nhep.GT.nhep0) THEN
17943 C LET'S TAKE IN ILLEGITIMATE DAUGHTERS
17944  na=3+last-first
17945  DO ll=1,nhep-nhep0
17946  idpho(na+ll)=idhep(nhep0+ll)
17947  jmopho(1,na+ll)=jmohep(1,nhep0+ll)
17948  IF (jmohep(1,nhep0+ll).EQ.ip) jmopho(1,na+ll)=1
17949  DO i=1,5
17950  ppho(i,na+ll)=phep(i,nhep0+ll)
17951  ENDDO
17952  ENDDO
17953 C-- THERE IS NHEP-NHEP0 DAUGTERS MORE.
17954  jdapho(2,1)=3+last-first+nhep-nhep0
17955  ENDIF
17956  CALL phlupa(1)
17957 C SPECIAL CASE OF T TBAR PRODUCTION PROCESS
17958  IF(iftop) CALL photwo(0)
17959  boost=.false.
17960 C-- CHECK WHETHER PARENT IS IN ITS REST FRAME...
17961  IF ( (abs(ppho(4,1)-ppho(5,1)).GT.ppho(5,1)*1.e-8)
17962  + .AND.(ppho(5,1).NE.0)) THEN
17963  boost=.true.
17964 C--
17965 C-- BOOST DAUGHTER PARTICLES TO REST FRAME OF PARENT...
17966 C-- RESULTANT NEUTRAL SYSTEM ALREADY CALCULATED IN REST FRAME !
17967  DO 10 j=1,3
17968  10 bet(j)=-ppho(j,1)/ppho(5,1)
17969  gam=ppho(4,1)/ppho(5,1)
17970  DO 30 i=jdapho(1,1),jdapho(2,1)
17971  pb=bet(1)*ppho(1,i)+bet(2)*ppho(2,i)+bet(3)*ppho(3,i)
17972  DO 20 j=1,3
17973  20 ppho(j,i)=ppho(j,i)+bet(j)*(ppho(4,i)+pb/(gam+1.))
17974  30 ppho(4,i)=gam*ppho(4,i)+pb
17975 C-- FINALLY BOOST MOTHER AS WELL
17976  i=1
17977  pb=bet(1)*ppho(1,i)+bet(2)*ppho(2,i)+bet(3)*ppho(3,i)
17978  DO j=1,3
17979  ppho(j,i)=ppho(j,i)+bet(j)*(ppho(4,i)+pb/(gam+1.))
17980  ENDDO
17981  ppho(4,i)=gam*ppho(4,i)+pb
17982  ENDIF
17983 C SPECIAL CASE OF T TBAR PRODUCTION PROCESS
17984  IF(iftop) CALL photwo(1)
17985  CALL phlupa(2)
17986  END
17987 *CMZ : 1.01/14 14/05/95 11.26.28 BY PIERO ZUCCHELLI
17988 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
17989 *-- AUTHOR :
17990  SUBROUTINE phoinf
17991 C.----------------------------------------------------------------------
17992 C.
17993 C. PHOTOS: PHOTON RADIATION IN DECAYS GENERAL INFO
17994 C.
17995 C. PURPOSE: PRINT PHOTOS INFO
17996 C.
17997 C. INPUT PARAMETERS: PHOLUN
17998 C.
17999 C. OUTPUT PARAMETERS: PHOVN1, PHOVN2
18000 C.
18001 C. AUTHOR(S): B. VAN EIJK CREATED AT: 12/04/90
18002 C. LAST UPDATE: 02/10/93
18003 C.
18004 C.----------------------------------------------------------------------
18005 C-- IMPLICIT NONE
18006  INTEGER iv1,iv2,iv3
18007  INTEGER phovn1,phovn2
18008  common/phover/phovn1,phovn2
18009  INTEGER phlun
18010  common/pholun/phlun
18011  LOGICAL interf,isec,iftop
18012  REAL fint,fsec
18013  COMMON /phokey/ interf,fint,isec,fsec,iftop
18014  REAL alpha,xphcut
18015  common/phocop/alpha,xphcut
18016 C--
18017 C-- PHOTOS VERSION NUMBER AND RELEASE DATE
18018  phovn1=200
18019  phovn2=161193
18020 C--
18021 C-- PRINT INFO
18022  WRITE(phlun,10000)
18023  WRITE(phlun,10200)
18024  WRITE(phlun,10100)
18025  WRITE(phlun,10300)
18026  iv1=phovn1/100
18027  iv2=phovn1-iv1*100
18028  WRITE(phlun,10400) iv1,iv2
18029  iv1=phovn2/10000
18030  iv2=(phovn2-iv1*10000)/100
18031  iv3=phovn2-iv1*10000-iv2*100
18032  WRITE(phlun,10500) iv1,iv2,iv3
18033  WRITE(phlun,10300)
18034  WRITE(phlun,10100)
18035  WRITE(phlun,10600)
18036  WRITE(phlun,10100)
18037  WRITE(phlun,11100)
18038  WRITE(phlun,10100)
18039  WRITE(phlun,10200)
18040  WRITE(phlun,10100)
18041  WRITE(phlun,11000) interf,isec,iftop,alpha,xphcut
18042  WRITE(phlun,10100)
18043  IF (interf) WRITE(phlun,10700)
18044  IF (isec) WRITE(phlun,10800)
18045  IF (iftop) WRITE(phlun,10900)
18046  WRITE(phlun,10100)
18047  WRITE(phlun,10200)
18048  RETURN
18049 10000 FORMAT(1h1)
18050 10100 FORMAT(1h ,'*',t81,'*')
18051 10200 FORMAT(1h ,80('*'))
18052 10300 FORMAT(1h ,'*',26x,26('='),t81,'*')
18053 10400 FORMAT(1h ,'*',28x,'PHOTOS, VERSION: ',i2,'.',i2,t81,'*')
18054 10500 FORMAT(1h ,'*',28x,'RELEASED AT: ',i2,'/',i2,'/',i2,t81,'*')
18055 10600 FORMAT(1h ,'*',18x,'PHOTOS QED CORRECTIONS IN PARTICLE DECAYS',
18056  &t81,'*')
18057 10700 FORMAT(1h ,'*',18x,'OPTION WITH INTERFERENCE IS ACTIVE ',
18058  &t81,'*')
18059 10800 FORMAT(1h ,'*',18x,'OPTION WITH DOUBLE PHOTONS IS ACTIVE ',
18060  &t81,'*')
18061 10900 FORMAT(1h ,'*',18x,'EMISION IN T TBAR PRODUCTION IS ACTIVE ',
18062  &t81,'*')
18063 11000 FORMAT(1h ,'*',18x,'INTERNAL INPUT PARAMETERS:',t81,'*'
18064  &,/, 1h ,'*',t81,'*'
18065  &,/, 1h ,'*',18x,'INTERF=',l2,' ISEC=',l2,' IFTOP=',l2,t81,'*'
18066  &,/, 1h ,'*',18x,'ALPHA_QED=',f8.5,' XPHCUT=',f8.5,t81,'*')
18067 11100 FORMAT(1h ,'*',9x,'MONTE CARLO PROGRAM - BY E. BARBERIO, B. VAN EI
18068  &JK AND Z. WAS',t81,'*',/,
18069  & 1h ,'*',9x,'FROM VERSION 2.0 ON - BY E.B. AND Z.W.',t81,'*')
18070  END
18071 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
18072 *-- AUTHOR :
18073 C.----------------------------------------------------------------------
18074 C.
18075 C. PHOTOS: PHOTOS CDE'S
18076 C.
18077 C. PURPOSE: KEEP DEFINITIONS FOR PHOTOS QED CORRECTION MONTE CARLO.
18078 C.
18079 C. INPUT PARAMETERS: NONE
18080 C.
18081 C. OUTPUT PARAMETERS: NONE
18082 C.
18083 C. AUTHOR(S): Z. WAS, B. VAN EIJK CREATED AT: 29/11/89
18084 C. LAST UPDATE: 10/08/93
18085 C.
18086 C. =========================================================
18087 C. GENERAL STRUCTURE INFORMATION: =
18088 C. =========================================================
18089 C: ROUTINES:
18090 C. 1) INITIALIZATION:
18091 C. PHOCDE
18092 C. PHOINI
18093 C. PHOCIN
18094 C. PHOINF
18095 C. 2) GENERAL INTERFACE:
18096 C. PHOTOS
18097 C. PHOBOS
18098 C. PHOIN
18099 C. PHOTWO (SPECIFIC INTERFACE
18100 C. PHOOUT
18101 C. PHOCHK
18102 C. PHTYPE (SPECIFIC INTERFACE
18103 C. PHOMAK (SPECIFIC INTERFACE
18104 C. 3) QED PHOTON GENERATION:
18105 C. PHINT
18106 C. PHOPRE
18107 C. PHOOMA
18108 C. PHOENE
18109 C. PHOCOR
18110 C. PHOFAC
18111 C. PHODO
18112 C. 4) UTILITIES:
18113 C. PHOTRI
18114 C. PHOAN1
18115 C. PHOAN2
18116 C. PHOBO3
18117 C. PHORO2
18118 C. PHORO3
18119 C. PHORIN
18120 C. PHORAN
18121 C. PHOCHA
18122 C. PHOSPI
18123 C. PHOERR
18124 C. PHOREP
18125 C. PHLUPA
18126 C. COMMONS:
18127 C. NAME USED IN SECT. # OF OCC. COMMENT
18128 C. PHOQED 1) 2) 3 FLAGS WHETHER EMISSON TO BE GENER.
18129 C. PHOLUN 1) 4) 5 OUTPUT DEVICE NUMBER
18130 C. PHOCOP 1) 3) 4 PHOTON COUPLING & MIN ENERGY
18131 C. PHPICO 1) 3) 4) 5 PI & 2*PI
18132 C. PHSEED 1) 4) 3 RN SEED
18133 C. PHOSTA 1) 4) 3 STATUS INFORMATION
18134 C. PHOKEY 1) 2) 3) 7 KEYS FOR NONSTANDARD APPLICATION
18135 C. PHOVER 1) 1 VERSION INFO FOR OUTSIDE
18136 C. HEPEVT 2) 6 PDG COMMON
18137 C. PHOEVT 2) 3) 9 PDG BRANCH
18138 C. PHOIF 2) 3) 2 EMISSION FLAGS FOR PDG BRANCH
18139 C. PHOMOM 3) 5 PARAM OF CHAR-NEUTR SYSTEM
18140 C. PHOPHS 3) 5 PHOTON MOMENTUM PARAMETERS
18141 C. PHOPRO 3) 4 VAR. FOR PHOTON REP. (IN BRANCH)
18142 C. PHOCMS 2) 3 PARAMETERS OF BOOST TO BRANCH CMS
18143 C. PHNUM 4) 1 EVENT NUMBER FROM OUTSIDE
18144 C.----------------------------------------------------------------------
18145  SUBROUTINE phoini
18146 C.----------------------------------------------------------------------
18147 C.
18148 C. PHOTOS: PHOTON RADIATION IN DECAYS INITIALISATION
18149 C.
18150 C. PURPOSE: INITIALISATION ROUTINE FOR THE PHOTOS QED RADIATION
18151 C. PACKAGE. SHOULD BE CALLED AT LEAST ONCE BEFORE A CALL
18152 C. TO THE STEERING PROGRAM 'PHOTOS' IS MADE.
18153 C.
18154 C. INPUT PARAMETERS: NONE
18155 C.
18156 C. OUTPUT PARAMETERS: NONE
18157 C.
18158 C. AUTHOR(S): Z. WAS, B. VAN EIJK CREATED AT: 26/11/89
18159 C. LAST UPDATE: 12/04/90
18160 C.
18161 C.----------------------------------------------------------------------
18162 C-- IMPLICIT NONE
18163  INTEGER init
18164  SAVE init
18165  DATA init/ 0/
18166 C--
18167 C-- RETURN IF ALREADY INITIALIZED...
18168  IF (init.NE.0) RETURN
18169  init=1
18170 C--
18171 C-- PRESET PARAMETERS IN PHOTOS COMMONS
18172  CALL phocin
18173 C--
18174 C-- PRINT INFO
18175  CALL phoinf
18176 C--
18177 C-- INITIALIZE MARSAGLIA AND ZAMAN RANDOM NUMBER GENERATOR
18178  CALL phorin
18179  RETURN
18180  END
18181 *CMZ : 1.01/50 23/05/96 10.22.20 by Piero Zucchelli
18182 *CMZ : 1.01/08 05/03/95 11.39.27 BY PIERO ZUCCHELLI
18183 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
18184 *-- AUTHOR :
18185  SUBROUTINE phomak(IPPAR,NHEP0)
18186 C.----------------------------------------------------------------------
18187 C.
18188 C. PHOMAK: PHOTOS MAKE
18189 C.
18190 C. PURPOSE: SINGLE OR DOUBLE BREMSTRAHLUNG RADIATIVE CORRECTIONS
18191 C. ARE GENERATED IN THE DECAY OF THE IPPAR-TH PARTICLE IN
18192 C. THE HEP COMMON /HEPEVT/. EXAMPLE OF THE USE OF
18193 C. GENERAL TOOLS.
18194 C.
18195 C. INPUT PARAMETER: IPPAR: POINTER TO DECAYING PARTICLE IN
18196 C. /HEPEVT/ AND THE COMMON ITSELF
18197 C.
18198 C. OUTPUT PARAMETERS: COMMON /HEPEVT/, EITHER WITH OR WITHOUT A
18199 C. PARTICLES ADDED.
18200 C.
18201 C. AUTHOR(S): Z. WAS, CREATED AT: 26/05/93
18202 C. LAST UPDATE:
18203 C.
18204 C.----------------------------------------------------------------------
18205 C-- IMPLICIT NONE
18206  DOUBLE PRECISION data
18207  REAL phoran
18208  INTEGER ip,ippar,ncharg
18209  INTEGER wtdum,idum,nhep0
18210  INTEGER ncharb,neudau
18211  REAL rn,wt,phint
18212  LOGICAL boost
18213  INTEGER nmxhep
18214  parameter(nmxhep=2000)
18215  INTEGER idhep,isthep,jdahep,jmohep,nevhep,nhep
18216  DOUBLE PRECISION phep,vhep
18217  common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),
18218  +jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)
18219  LOGICAL interf,isec,iftop
18220  REAL fint,fsec
18221  COMMON /phokey/ interf,fint,isec,fsec,iftop
18222 C--
18223  ip=ippar
18224  idum=1
18225  ncharg=0
18226 C--
18227  CALL phoin(ip,boost,nhep0)
18228  CALL phochk(jdahep(1,ip))
18229  wt=0.0
18230  CALL phopre(1,wt,neudau,ncharb)
18231  IF (wt.EQ.0.0) RETURN
18232  rn=phoran(wtdum)
18233 C PHODO IS CALLING PHORAN, THUS CHANGE OF SERIES IF IT IS MOVED BEFORE IF.
18234  CALL phodo(1,ncharb,neudau)
18235  IF (interf) wt=wt*phint(idum)/fint
18236  data=wt
18237  IF (wt.GT.1.0) CALL phoerr(3,'WT_INT',data)
18238  IF (rn.LE.wt) THEN
18239  CALL phoout(ip,boost,nhep0)
18240  ENDIF
18241  RETURN
18242  END
18243 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
18244 *-- AUTHOR :
18245  SUBROUTINE phooma(IFIRST,ILAST,POINTR)
18246 C.----------------------------------------------------------------------
18247 C.
18248 C. PHOTOS: PHOTON RADIATION IN DECAYS ORDER MASS VECTOR
18249 C.
18250 C. PURPOSE: ORDER THE CONTENTS OF ARRAY 'POINTR' ACCORDING TO THE
18251 C. DECREASING VALUE IN THE ARRAY 'MASS'.
18252 C.
18253 C. INPUT PARAMETERS: IFIRST, ILAST: POINTERS TO THE VECTOR LOCA-
18254 C. TION BE SORTED,
18255 C. POINTR: UNSORTED ARRAY WITH POINTERS TO
18256 C. /PHOEVT/.
18257 C.
18258 C. OUTPUT PARAMETER: POINTR: SORTED ARRAYS WITH RESPECT TO
18259 C. PARTICLE MASS 'PPHO(5,*)'.
18260 C.
18261 C. AUTHOR(S): B. VAN EIJK CREATED AT: 28/11/89
18262 C. LAST UPDATE: 27/05/93
18263 C.
18264 C.----------------------------------------------------------------------
18265 C-- IMPLICIT NONE
18266  INTEGER nmxpho
18267  parameter(nmxpho=2000)
18268  INTEGER idpho,istpho,jdapho,jmopho,nevpho,npho
18269  REAL ppho,vpho
18270  common/phoevt/nevpho,npho,istpho(nmxpho),idpho(nmxpho),
18271  &jmopho(2,nmxpho),jdapho(2,nmxpho),ppho(5,nmxpho),vpho(4,nmxpho)
18272  INTEGER ifirst,ilast,i,j,bufpoi,pointr(nmxpho)
18273  REAL bufmas,mass(nmxpho)
18274  IF (ifirst.EQ.ilast) RETURN
18275 C--
18276 C-- COPY PARTICLE MASSES
18277  DO 10 i=ifirst,ilast
18278  10 mass(i)=ppho(5,pointr(i))
18279 C--
18280 C-- ORDER THE MASSES IN A DECREASING SERIES
18281  DO 30 i=ifirst,ilast-1
18282  DO 20 j=i+1,ilast
18283  IF (mass(j).LE.mass(i)) goto 20
18284  bufpoi=pointr(j)
18285  pointr(j)=pointr(i)
18286  pointr(i)=bufpoi
18287  bufmas=mass(j)
18288  mass(j)=mass(i)
18289  mass(i)=bufmas
18290  20 CONTINUE
18291  30 CONTINUE
18292  RETURN
18293  END
18294 *CMZ : 1.01/50 23/05/96 10.22.20 by Piero Zucchelli
18295 *CMZ : 1.01/14 14/05/95 11.26.28 BY PIERO ZUCCHELLI
18296 *CMZ : 1.01/08 05/03/95 11.39.27 BY PIERO ZUCCHELLI
18297 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
18298 *-- AUTHOR :
18299  SUBROUTINE phoout(IP,BOOST,NHEP0)
18300 C.----------------------------------------------------------------------
18301 C.
18302 C. PHOOUT: PHOTOS OUTPUT
18303 C.
18304 C. PURPOSE: COPIES BACK IP BRANCH OF THE COMMON /HEPEVT/ FROM /PHOEVT/
18305 C. MOVES BRANCH BACK FROM ITS CMS SYSTEM.
18306 C.
18307 C. INPUT PARAMETERS: IP: POINTER OF PARTICLE STARTING BRANCH
18308 C. TO BE GIVEN BACK.
18309 C. BOOST: FLAG WHETHER BOOST TO CMS WAS OR WAS
18310 C . NOT PERFORMED.
18311 C.
18312 C. OUTPUT PARAMETERS: COMMON /PHOEVT/,
18313 C.
18314 C. AUTHOR(S): Z. WAS CREATED AT: 24/05/93
18315 C. LAST UPDATE:
18316 C.
18317 C.----------------------------------------------------------------------
18318 C-- IMPLICIT NONE
18319  INTEGER nmxhep
18320  parameter(nmxhep=2000)
18321  INTEGER idhep,isthep,jdahep,jmohep,nevhep,nhep
18322  DOUBLE PRECISION phep,vhep
18323  common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),
18324  +jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)
18325  INTEGER nmxpho
18326  parameter(nmxpho=2000)
18327  INTEGER idpho,istpho,jdapho,jmopho,nevpho,npho
18328  REAL ppho,vpho
18329  common/phoevt/nevpho,npho,istpho(nmxpho),idpho(nmxpho),
18330  +jmopho(2,nmxpho),jdapho(2,nmxpho),ppho(5,nmxpho),vpho(4,nmxpho)
18331  INTEGER ip,ll,first,last,i
18332  LOGICAL boost
18333  INTEGER nn,j,k,nhep0,na
18334  DOUBLE PRECISION bet(3),gam,pb
18335  COMMON /phocms/ bet,gam
18336  IF(npho.EQ.nevpho) RETURN
18337 C-- WHEN PARENT WAS NOT IN ITS REST-FRAME, BOOST BACK...
18338  CALL phlupa(10)
18339  IF (boost) THEN
18340  DO 20 j=jdapho(1,1),jdapho(2,1)
18341  pb=-bet(1)*ppho(1,j)-bet(2)*ppho(2,j)-bet(3)*ppho(3,j)
18342  DO 10 k=1,3
18343  10 ppho(k,j)=ppho(k,j)-bet(k)*(ppho(4,j)+pb/(gam+1.))
18344  20 ppho(4,j)=gam*ppho(4,j)+pb
18345 C-- ...BOOST PHOTON, OR WHATEVER ELSE HAS SHOWN UP
18346  DO nn=nevpho+1,npho
18347  pb=-bet(1)*ppho(1,nn)-bet(2)*ppho(2,nn)-bet(3)*ppho(3,nn)
18348  DO 30 k=1,3
18349  30 ppho(k,nn)=ppho(k,nn)-bet(k)*(ppho(4,nn)+pb/(gam+1.))
18350  ppho(4,nn)=gam*ppho(4,nn)+pb
18351  ENDDO
18352  ENDIF
18353  first=jdahep(1,ip)
18354  last =jdahep(2,ip)
18355 C LET'S TAKE IN ORIGINAL DAUGHTERS
18356  DO ll=0,last-first
18357  idhep(first+ll) = idpho(3+ll)
18358  DO i=1,5
18359  phep(i,first+ll) = ppho(i,3+ll)
18360  ENDDO
18361  ENDDO
18362 C LET'S TAKE NEWCOMERS TO THE END OF HEPEVT.
18363  na=3+last-first
18364  DO ll=1,npho-na
18365  idhep(nhep0+ll) = idpho(na+ll)
18366  isthep(nhep0+ll)=istpho(na+ll)
18367  jmohep(1,nhep0+ll)=ip
18368  jmohep(2,nhep0+ll)=jmohep(2,jdahep(1,ip))
18369  jdahep(1,nhep0+ll)=0
18370  jdahep(2,nhep0+ll)=0
18371  DO i=1,5
18372  phep(i,nhep0+ll) = ppho(i,na+ll)
18373  ENDDO
18374  ENDDO
18375  nhep=nhep+npho-nevpho
18376  CALL phlupa(20)
18377  END
18378 *CMZ : 1.01/14 14/05/95 11.26.28 BY PIERO ZUCCHELLI
18379 *CMZ : 1.01/08 05/03/95 11.39.27 BY PIERO ZUCCHELLI
18380 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
18381 *-- AUTHOR :
18382  SUBROUTINE phopre(IPARR,WT,NEUDAU,NCHARB)
18383 C.----------------------------------------------------------------------
18384 C.
18385 C. PHOTOS: PHOTON RADIATION IN DECAYS
18386 C.
18387 C. PURPOSE: ORDER (ALPHA) RADIATIVE CORRECTIONS ARE GENERATED IN
18388 C. THE DECAY OF THE IPPAR-TH PARTICLE IN THE HEP-LIKE
18389 C. COMMON /PHOEVT/. PHOTON RADIATION TAKES PLACE FROM ONE
18390 C. OF THE CHARGED DAUGHTERS OF THE DECAYING PARTICLE IPPAR
18391 C. WT IS CALCULATED, EVENTUAL REJECTION WILL BE PERFORMED
18392 C. LATER AFTER INCLUSION OF INTERFERENCE WEIGHT.
18393 C.
18394 C. INPUT PARAMETER: IPPAR: POINTER TO DECAYING PARTICLE IN
18395 C. /PHOEVT/ AND THE COMMON ITSELF,
18396 C.
18397 C. OUTPUT PARAMETERS: COMMON /PHOEVT/, EITHER WITH OR WITHOUT A
18398 C. PHOTON(S) ADDED.
18399 C. WT WEIGHT OF THE CONFIGURATION
18400 C.
18401 C. AUTHOR(S): Z. WAS, B. VAN EIJK CREATED AT: 26/11/89
18402 C. LAST UPDATE: 26/05/93
18403 C.
18404 C.----------------------------------------------------------------------
18405 C-- IMPLICIT NONE
18406  DOUBLE PRECISION minmas,mpasqr,mchren
18407  DOUBLE PRECISION beta,eps,del1,del2,data
18408  REAL phocha,phospi,phoran,phocor,massum
18409  INTEGER ip,iparr,ippar,i,j,me,ncharg,neupoi,nlast,thedum
18410  INTEGER idabs,idum
18411  INTEGER ncharb,neudau
18412  REAL wt
18413  INTEGER nmxpho
18414  parameter(nmxpho=2000)
18415  INTEGER idpho,istpho,jdapho,jmopho,nevpho,npho
18416  REAL ppho,vpho
18417  common/phoevt/nevpho,npho,istpho(nmxpho),idpho(nmxpho),
18418  +jmopho(2,nmxpho),jdapho(2,nmxpho),ppho(5,nmxpho),vpho(4,nmxpho)
18419  LOGICAL chkif
18420  common/phoif/chkif(nmxpho)
18421  INTEGER chapoi(nmxpho)
18422  DOUBLE PRECISION mchsqr,mnesqr
18423  REAL pneutr
18424  common/phomom/mchsqr,mnesqr,pneutr(5)
18425  DOUBLE PRECISION costhg,sinthg
18426  REAL xphmax,xphoto
18427  common/phophs/xphmax,xphoto,costhg,sinthg
18428  REAL alpha,xphcut
18429  common/phocop/alpha,xphcut
18430  INTEGER irep
18431  REAL probh,corwt,xf
18432  common/phopro/irep,probh,corwt,xf
18433 C--
18434  ippar=iparr
18435 C-- STORE POINTERS FOR CASCADE TREATEMENT...
18436  ip=ippar
18437  nlast=npho
18438  idum=1
18439 C--
18440 C-- CHECK DECAY MULTIPLICITY..
18441  IF (jdapho(1,ip).EQ.0) RETURN
18442 C--
18443 C-- LOOP OVER DAUGHTERS, DETERMINE CHARGE MULTIPLICITY
18444  10 ncharg=0
18445  irep=0
18446  minmas=0.
18447  massum=0.
18448  DO 20 i=jdapho(1,ip),jdapho(2,ip)
18449 C--
18450 C--
18451 C-- EXCLUDE MARKED PARTICLES, QUARKS AND GLUONS ETC...
18452  idabs=abs(idpho(i))
18453  IF (chkif(i-jdapho(1,ip)+3)) THEN
18454  IF (phocha(idpho(i)).NE.0) THEN
18455  ncharg=ncharg+1
18456  IF (ncharg.GT.nmxpho) THEN
18457  data=ncharg
18458  CALL phoerr(1,'PHOTOS',data)
18459  ENDIF
18460  chapoi(ncharg)=i
18461  ENDIF
18462  minmas=minmas+ppho(5,i)**2
18463  ENDIF
18464  massum=massum+ppho(5,i)
18465  20 CONTINUE
18466  IF (ncharg.NE.0) THEN
18467 C--
18468 C-- CHECK THAT SUM OF DAUGHTER MASSES DOES NOT EXCEED PARENT MASS
18469  IF ((ppho(5,ip)-massum)/ppho(5,ip).GT.2.*xphcut) THEN
18470 C--
18471 C-- ORDER CHARGED PARTICLES ACCORDING TO DECREASING MASS, THIS TO
18472 C-- INCREASE EFFICIENCY (SMALLEST MASS IS TREATED FIRST).
18473  IF (ncharg.GT.1) CALL phooma(1,ncharg,chapoi)
18474 C--
18475  30 CONTINUE
18476  DO 40 j=1,3
18477  40 pneutr(j)=-ppho(j,chapoi(ncharg))
18478  pneutr(4)=ppho(5,ip)-ppho(4,chapoi(ncharg))
18479 C--
18480 C-- CALCULATE INVARIANT MASS OF 'NEUTRAL' ETC. SYSTEMS
18481  mpasqr=ppho(5,ip)**2
18482  mchsqr=ppho(5,chapoi(ncharg))**2
18483  IF ((jdapho(2,ip)-jdapho(1,ip)).EQ.1) THEN
18484  neupoi=jdapho(1,ip)
18485  IF (neupoi.EQ.chapoi(ncharg)) neupoi=jdapho(2,ip)
18486  mnesqr=ppho(5,neupoi)**2
18487  pneutr(5)=ppho(5,neupoi)
18488  ELSE
18489  mnesqr=pneutr(4)**2-pneutr(1)**2-pneutr(2)**2-pneutr(3)**2
18490  mnesqr=max(mnesqr,minmas-mchsqr)
18491  pneutr(5)=sqrt(mnesqr)
18492  ENDIF
18493 C--
18494 C-- DETERMINE KINEMATICAL LIMIT...
18495  xphmax=(mpasqr-(pneutr(5)+ppho(5,chapoi(ncharg)))**2)/mpasqr
18496 C--
18497 C-- PHOTON ENERGY FRACTION...
18498  CALL phoene(mpasqr,mchren,beta,idpho(chapoi(ncharg)))
18499 C--
18500 C-- ENERGY FRACTION NOT TOO LARGE (VERY SELDOM) ? DEFINE ANGLE.
18501  IF ((xphoto.LT.xphcut).OR.(xphoto.GT.xphmax)) THEN
18502 C--
18503 C-- NO RADIATION WAS ACCEPTED, CHECK FOR MORE DAUGHTERS THAT MAY RA-
18504 C-- DIATE AND CORRECT RADIATION PROBABILITY...
18505  ncharg=ncharg-1
18506  IF (ncharg.GT.0) THEN
18507  irep=irep+1
18508  goto 30
18509  ENDIF
18510  ELSE
18511 C--
18512 C-- ANGLE IS GENERATED IN THE FRAME DEFINED BY CHARGED VECTOR AND
18513 C-- PNEUTR, DISTRIBUTION IS TAKEN IN THE INFRARED LIMIT...
18514  eps=mchren/(1.+beta)
18515 C--
18516 C-- CALCULATE SIN(THETA) AND COS(THETA) FROM INTERVAL VARIABLES
18517  del1=(2.-eps)*(eps/(2.-eps))**phoran(thedum)
18518  del2=2.-del1
18519  costhg=(1.-del1)/beta
18520  sinthg=sqrt(del1*del2-mchren)/beta
18521 C--
18522 C-- DETERMINE SPIN OF PARTICLE AND CONSTRUCT CODE FOR MATRIX ELEMENT
18523  me=2.*phospi(idpho(chapoi(ncharg)))+1.
18524 C--
18525 C-- WEIGHTING PROCEDURE WITH 'EXACT' MATRIX ELEMENT, RECONSTRUCT KINE-
18526 C-- MATICS FOR PHOTON, NEUTRAL AND CHARGED SYSTEM AND UPDATE /PHOEVT/.
18527 C-- FIND POINTER TO THE FIRST COMPONENT OF 'NEUTRAL' SYSTEM
18528  DO i=jdapho(1,ip),jdapho(2,ip)
18529  IF (i.NE.chapoi(ncharg)) THEN
18530  neudau=i
18531  goto 50
18532  ENDIF
18533  ENDDO
18534 C--
18535 C-- POINTER NOT FOUND...
18536  data=ncharg
18537  CALL phoerr(5,'PHOKIN',data)
18538  50 CONTINUE
18539  ncharb=chapoi(ncharg)
18540  ncharb=ncharb-jdapho(1,ip)+3
18541  neudau=neudau-jdapho(1,ip)+3
18542  wt=phocor(mpasqr,mchren,me)
18543 
18544  ENDIF
18545  ELSE
18546  data=ppho(5,ip)-massum
18547  CALL phoerr(10,'PHOTOS',data)
18548  ENDIF
18549  ENDIF
18550 C--
18551  RETURN
18552  END
18553 *CMZ : 1.01/50 23/05/96 12.34.50 by Piero Zucchelli
18554 *-- Author : Piero Zucchelli 20/03/96
18555 
18556  REAL*4 FUNCTION phoran(IDUMMY)
18557  CALL ranlux(rtim,1)
18558  phoran=rtim
18559  RETURN
18560  END
18561 *CMZ : 1.01/14 14/05/95 11.26.28 BY PIERO ZUCCHELLI
18562 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
18563 *-- AUTHOR :
18564  SUBROUTINE phorep
18565 C.----------------------------------------------------------------------
18566 C.
18567 C. PHOTOS: PHOTON RADIATION IN DECAYS RUN SUMMARY REPORT
18568 C.
18569 C. PURPOSE: INFORM USER ABOUT SUCCESS AND/OR RESTRICTIONS OF PHOTOS
18570 C. ENCOUNTERED DURING EXECUTION.
18571 C.
18572 C. INPUT PARAMETERS: COMMON /PHOSTA/
18573 C.
18574 C. OUTPUT PARAMETERS: NONE
18575 C.
18576 C. AUTHOR(S): B. VAN EIJK CREATED AT: 10/01/92
18577 C. LAST UPDATE: 10/01/92
18578 C.
18579 C.----------------------------------------------------------------------
18580 C-- IMPLICIT NONE
18581  INTEGER phlun
18582  common/pholun/phlun
18583  INTEGER phomes
18584  parameter(phomes=10)
18585  INTEGER status
18586  common/phosta/status(phomes)
18587  INTEGER i
18588  LOGICAL error
18589  error=.false.
18590  WRITE(phlun,10000)
18591  WRITE(phlun,10100)
18592  WRITE(phlun,10200)
18593  WRITE(phlun,10300)
18594  WRITE(phlun,10400)
18595  WRITE(phlun,10300)
18596  WRITE(phlun,10200)
18597  DO 10 i=1,phomes
18598  IF (status(i).EQ.0) goto 10
18599  IF ((i.EQ.6).OR.(i.EQ.10)) THEN
18600  WRITE(phlun,10500) i,status(i)
18601  ELSE
18602  error=.true.
18603  WRITE(phlun,10600) i,status(i)
18604  ENDIF
18605  10 CONTINUE
18606  IF (.NOT.error) WRITE(phlun,10700)
18607  WRITE(phlun,10200)
18608  WRITE(phlun,10100)
18609  RETURN
18610 10000 FORMAT(1h1)
18611 10100 FORMAT(1h ,80('*'))
18612 10200 FORMAT(1h ,'*',t81,'*')
18613 10300 FORMAT(1h ,'*',26x,25('='),t81,'*')
18614 10400 FORMAT(1h ,'*',30x,'PHOTOS RUN SUMMARY',t81,'*')
18615 10500 FORMAT(1h ,'*',22x,'WARNING #',i2,' OCCURED',i6,' TIMES',t81,'*')
18616 10600 FORMAT(1h ,'*',23x,'ERROR #',i2,' OCCURED',i6,' TIMES',t81,'*')
18617 10700 FORMAT(1h ,'*',16x,'PHOTOS EXECUTION HAS SUCCESSFULLY TERMINATED',
18618  &t81,'*')
18619  END
18620 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
18621 *-- AUTHOR :
18622  SUBROUTINE phorin
18623 C.----------------------------------------------------------------------
18624 C.
18625 C. PHOTOS: PHOTON RADIATION IN DECAYS RANDOM NUMBER GENERATOR INIT
18626 C.
18627 C. PURPOSE: INITIALSE PHORAN WITH THE USER SPECIFIED SEEDS IN THE
18628 C. ARRAY ISEED. FOR DETAILS SEE ALSO: F. JAMES CERN DD-
18629 C. REPORT NOVEMBER 1988.
18630 C.
18631 C. INPUT PARAMETERS: ISEED(*)
18632 C.
18633 C. OUTPUT PARAMETERS: URAN, CRAN, CDRAN, CMRAN, I97, J97
18634 C.
18635 C. AUTHOR(S): B. VAN EIJK AND F. JAMES CREATED AT: 27/09/89
18636 C. LAST UPDATE: 22/02/90
18637 C.
18638 C.----------------------------------------------------------------------
18639 C-- IMPLICIT NONE
18640  DOUBLE PRECISION data
18641  REAL s,t
18642  INTEGER i,is1,is2,is3,is4,is5,j
18643  INTEGER iseed,i97,j97
18644  REAL uran,cran,cdran,cmran
18645  common/phseed/iseed(2),i97,j97,uran(97),cran,cdran,cmran
18646 C--
18647 C-- CHECK VALUE RANGE OF SEEDS
18648  IF ((iseed(1).LT.0).OR.(iseed(1).GE.31328)) THEN
18649  data=iseed(1)
18650  CALL phoerr(8,'PHORIN',data)
18651  ENDIF
18652  IF ((iseed(2).LT.0).OR.(iseed(2).GE.30081)) THEN
18653  data=iseed(2)
18654  CALL phoerr(9,'PHORIN',data)
18655  ENDIF
18656 C--
18657 C-- CALCULATE MARSAGLIA AND ZAMAN SEEDS (BY F. JAMES)
18658  is1=mod(iseed(1)/177,177)+2
18659  is2=mod(iseed(1),177)+2
18660  is3=mod(iseed(2)/169,178)+1
18661  is4=mod(iseed(2),169)
18662  DO 20 i=1,97
18663  s=0.
18664  t=0.5
18665  DO 10 j=1,24
18666  is5=mod(mod(is1*is2,179)*is3,179)
18667  is1=is2
18668  is2=is3
18669  is3=is5
18670  is4=mod(53*is4+1,169)
18671  IF (mod(is4*is5,64).GE.32) s=s+t
18672  10 t=0.5*t
18673  20 uran(i)=s
18674  cran=362436./16777216.
18675  cdran=7654321./16777216.
18676  cmran=16777213./16777216.
18677  i97=97
18678  j97=33
18679  RETURN
18680  END
18681 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
18682 *-- AUTHOR :
18683  SUBROUTINE phoro2(ANGLE,PVEC)
18684 C.----------------------------------------------------------------------
18685 C.
18686 C. PHOTOS: PHOTON RADIATION IN DECAYS ROTATION ROUTINE '2'
18687 C.
18688 C. PURPOSE: ROTATE X AND Z COMPONENTS OF VECTOR PVEC AROUND ANGLE
18689 C. 'ANGLE'.
18690 C.
18691 C. INPUT PARAMETERS: ANGLE, PVEC
18692 C.
18693 C. OUTPUT PARAMETER: PVEC
18694 C.
18695 C. AUTHOR(S): S. JADACH CREATED AT: 01/01/89
18696 C. B. VAN EIJK LAST UPDATE: 02/01/90
18697 C.
18698 C.----------------------------------------------------------------------
18699 C-- IMPLICIT NONE
18700  DOUBLE PRECISION cs,sn,angle
18701  REAL pvec(4)
18702  cs=cos(angle)*pvec(1)+sin(angle)*pvec(3)
18703  sn=-sin(angle)*pvec(1)+cos(angle)*pvec(3)
18704  pvec(1)=cs
18705  pvec(3)=sn
18706  RETURN
18707  END
18708 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
18709 *-- AUTHOR :
18710  SUBROUTINE phoro3(ANGLE,PVEC)
18711 C.----------------------------------------------------------------------
18712 C.
18713 C. PHOTOS: PHOTON RADIATION IN DECAYS ROTATION ROUTINE '3'
18714 C.
18715 C. PURPOSE: ROTATE X AND Y COMPONENTS OF VECTOR PVEC AROUND ANGLE
18716 C. 'ANGLE'.
18717 C.
18718 C. INPUT PARAMETERS: ANGLE, PVEC
18719 C.
18720 C. OUTPUT PARAMETER: PVEC
18721 C.
18722 C. AUTHOR(S): S. JADACH CREATED AT: 01/01/89
18723 C. B. VAN EIJK LAST UPDATE: 02/01/90
18724 C.
18725 C.----------------------------------------------------------------------
18726 C-- IMPLICIT NONE
18727  DOUBLE PRECISION cs,sn,angle
18728  REAL pvec(4)
18729  cs=cos(angle)*pvec(1)-sin(angle)*pvec(2)
18730  sn=sin(angle)*pvec(1)+cos(angle)*pvec(2)
18731  pvec(1)=cs
18732  pvec(2)=sn
18733  RETURN
18734  END
18735 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
18736 *-- AUTHOR :
18737  FUNCTION phospi(IDHEP)
18738 C.----------------------------------------------------------------------
18739 C.
18740 C. PHOTOS: PHOTON RADIATION IN DECAYS FUNCTION FOR SPIN DETERMINA-
18741 C. TION
18742 C.
18743 C. PURPOSE: CALCULATE THE SPIN OF PARTICLE WITH CODE IDHEP. THE
18744 C. CODE OF THE PARTICLE IS DEFINED BY THE PARTICLE DATA
18745 C. GROUP IN PHYS. LETT. B204 (1988) 1.
18746 C.
18747 C. INPUT PARAMETER: IDHEP
18748 C.
18749 C. OUTPUT PARAMETER: FUNTION VALUE = SPIN OF PARTICLE WITH CODE
18750 C. IDHEP
18751 C.
18752 C. AUTHOR(S): E. BARBERIO AND B. VAN EIJK CREATED AT: 29/11/89
18753 C. LAST UPDATE: 02/01/90
18754 C.
18755 C.----------------------------------------------------------------------
18756 C-- IMPLICIT NONE
18757  REAL phospi
18758  INTEGER idhep,idabs
18759 C--
18760 C-- ARRAY 'SPIN' CONTAINS THE SPIN OF THE FIRST 100 PARTICLES ACCOR-
18761 C-- DING TO THE PDG PARTICLE CODE...
18762  REAL spin(100)
18763  DATA spin/ 8*.5, 1., 0., 8*.5, 2*0., 4*1., 76*0./
18764  idabs=abs(idhep)
18765 C--
18766 C-- SPIN OF QUARK, LEPTON, BOSON ETC....
18767  IF (idabs.LE.100) THEN
18768  phospi=spin(idabs)
18769  ELSE
18770 C--
18771 C-- ...OTHER PARTICLES, HOWEVER...
18772  phospi=(mod(idabs,10)-1.)/2.
18773 C--
18774 C-- ...K_SHORT AND K_LONG ARE SPECIAL !!
18775  phospi=max(phospi,0.)
18776  ENDIF
18777  RETURN
18778  END
18779 *CMZ : 1.01/50 23/05/96 10.22.20 by Piero Zucchelli
18780 *CMZ : 1.01/14 14/05/95 11.26.28 BY PIERO ZUCCHELLI
18781 *CMZ : 1.01/08 05/03/95 11.39.27 BY PIERO ZUCCHELLI
18782 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
18783 *-- AUTHOR :
18784  SUBROUTINE photos(IPARR)
18785 C.----------------------------------------------------------------------
18786 C.
18787 C. PHOTOS: GENERAL SEARCH ROUTINE
18788 C.
18789 C. PURPOSE: SEARCH THROUGH THE /HEPEVT/ STANDARD HEP COMMON, STAR-
18790 C. TING FROM THE IPPAR-TH PARTICLE. WHENEVR BRANCHING
18791 C . POINT IS FOUND ROUTINE PHTYPE(IP) IS CALLED.
18792 C. FINALLY IF CALLS ON PHTYPE(IP) MODIFIED ENTRIES, COMMON
18793 C /HEPEVT/ IS ORDERED.
18794 C.
18795 C. INPUT PARAMETER: IPPAR: POINTER TO DECAYING PARTICLE IN
18796 C. /HEPEVT/ AND THE COMMON ITSELF,
18797 C.
18798 C. OUTPUT PARAMETERS: COMMON /HEPEVT/, EITHER WITH OR WITHOUT NEW
18799 C. PARTICLES ADDED.
18800 C.
18801 C. AUTHOR(S): Z. WAS, B. VAN EIJK CREATED AT: 26/11/89
18802 C. LAST UPDATE: 30/08/93
18803 C.
18804 C.----------------------------------------------------------------------
18805 C-- IMPLICIT NONE
18806  REAL photon(5)
18807  INTEGER ip,iparr,ippar,i,j,k,l,nlast
18808  DOUBLE PRECISION data
18809  INTEGER mother,pospho
18810  LOGICAL cascad
18811  INTEGER nmxhep
18812  parameter(nmxhep=2000)
18813  INTEGER idhep,isthep,jdahep,jmohep,nevhep,nhep
18814  DOUBLE PRECISION phep,vhep
18815  common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),
18816  +jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)
18817  LOGICAL qedrad
18818  common/phoqed/qedrad(nmxhep)
18819  INTEGER nmxpho
18820  parameter(nmxpho=2000)
18821  INTEGER istack(0:nmxpho),numit,ntry,kk,ll,ii,na,first,last
18822  INTEGER firsta,lasta,ipp,ida1,ida2,mother2,idpho,ispho
18823  REAL porig(5,nmxpho)
18824 C--
18825  ippar=abs(iparr)
18826 C-- STORE POINTERS FOR CASCADE TREATEMENT...
18827  ip=ippar
18828  nlast=nhep
18829  cascad=.false.
18830 C--
18831 C-- CHECK DECAY MULTIPLICITY AND MINIMUM OF CORRECTNESS..
18832  IF ((jdahep(1,ip).EQ.0).OR.(jmohep(1,jdahep(1,ip)).NE.ip)) RETURN
18833 C--
18834 C-- SINGLE BRANCH MODE
18835 C-- WE START LOOKING FOR THE DECAY POINTS IN THE CASCADE
18836 C-- IPPAR IS ORIGINAL POSITION WHERE THE PROGRAM WAS CALLED
18837  istack(0)=ippar
18838 C-- NUMIT DENOTES NUMBER OF SECONDARY DECAY BRANCHES
18839  numit=0
18840 C-- NTRY DENOTES NUMBER OF SECONDARY BRANCHES ALREADY CHECKED FOR
18841 C-- FOR EXISTENCE OF FURTHER BRANCHES
18842  ntry=0
18843 C-- LET'S SEARCH IF IPARR DOES NOT PREVENT SEARCHING.
18844  IF (iparr.GT.0) THEN
18845  10 CONTINUE
18846  DO i=jdahep(1,ip),jdahep(2,ip)
18847  IF (jdahep(1,i).NE.0.AND.jmohep(1,jdahep(1,i)).EQ.i) THEN
18848  numit=numit+1
18849  IF (numit.GT.nmxpho) THEN
18850  data=numit
18851  CALL phoerr(7,'PHOTOS',data)
18852  ENDIF
18853  istack(numit)=i
18854  ENDIF
18855  ENDDO
18856  IF(numit.GT.ntry) THEN
18857  ntry=ntry+1
18858  ip=istack(ntry)
18859  goto 10
18860  ENDIF
18861  ENDIF
18862 C-- LET'S DO GENERATION
18863  DO 20 kk=0,numit
18864  na=nhep
18865  first=jdahep(1,istack(kk))
18866  last=jdahep(2,istack(kk))
18867  DO ii=1,last-first+1
18868  DO ll=1,5
18869  porig(ll,ii)=phep(ll,first+ii-1)
18870  ENDDO
18871  ENDDO
18872 C--
18873  CALL phtype(istack(kk))
18874 C--
18875 C-- CORRECT ENERGY/MOMENTUM OF CASCADE DAUGHTERS
18876  IF(nhep.GT.na) THEN
18877  DO ii=1,last-first+1
18878  ipp=first+ii-1
18879  firsta=jdahep(1,ipp)
18880  lasta=jdahep(2,ipp)
18881  IF(jmohep(1,ipp).EQ.istack(kk)) CALL phobos(ipp,porig(1,ii)
18882  + ,phep(1,ipp),firsta,lasta)
18883  ENDDO
18884  ENDIF
18885  20 CONTINUE
18886 C--
18887 C-- REARRANGE /HEPEVT/ TO GET CORRECT ORDER..
18888  IF (nhep.GT.nlast) THEN
18889  DO 100 i=nlast+1,nhep
18890 C--
18891 C-- PHOTON MOTHER AND POSITION...
18892  mother=jmohep(1,i)
18893  pospho=jdahep(2,mother)+1
18894 C-- INTERMEDIATE SAVE OF PHOTON ENERGY/MOMENTUM AND POINTERS
18895  DO 30 j=1,5
18896  30 photon(j)=phep(j,i)
18897  ispho =isthep(i)
18898  idpho =idhep(i)
18899  mother2 =jmohep(2,i)
18900  ida1 =jdahep(1,i)
18901  ida2 =jdahep(2,i)
18902 C--
18903 C-- EXCLUDE PHOTON IN SEQUENCE !
18904  IF (pospho.NE.nhep) THEN
18905 C--
18906 C--
18907 C-- ORDER /HEPEVT/
18908  DO 60 k=i,pospho+1,-1
18909  isthep(k)=isthep(k-1)
18910  qedrad(k)=qedrad(k-1)
18911  idhep(k)=idhep(k-1)
18912  DO 40 l=1,2
18913  jmohep(l,k)=jmohep(l,k-1)
18914  40 jdahep(l,k)=jdahep(l,k-1)
18915  DO 50 l=1,5
18916  50 phep(l,k)=phep(l,k-1)
18917  DO 60 l=1,4
18918  60 vhep(l,k)=vhep(l,k-1)
18919 C--
18920 C-- CORRECT POINTERS ASSUMING MOST DIRTY /HEPEVT/...
18921  DO 70 k=1,nhep
18922  DO 70 l=1,2
18923  IF ((jmohep(l,k).NE.0).AND.(jmohep(l,k).GE. pospho))
18924  + jmohep(l,k)=jmohep(l,k)+1
18925  IF ((jdahep(l,k).NE.0).AND.(jdahep(l,k).GE. pospho))
18926  + jdahep(l,k)=jdahep(l,k)+1
18927  70 CONTINUE
18928 C--
18929 C-- STORE PHOTON ENERGY/MOMENTUM
18930  DO 80 j=1,5
18931  80 phep(j,pospho)=photon(j)
18932  ENDIF
18933 C--
18934 C-- STORE POINTERS FOR THE PHOTON...
18935  jdahep(2,mother)=pospho
18936  isthep(pospho)=ispho
18937  idhep(pospho)=idpho
18938  jmohep(1,pospho)=mother
18939  jmohep(2,pospho)=mother2
18940  jdahep(1,pospho)=ida1
18941  jdahep(2,pospho)=ida2
18942 C--
18943 C-- GET PHOTON PRODUCTION VERTEX POSITION
18944  DO 90 j=1,4
18945  90 vhep(j,pospho)=vhep(j,pospho-1)
18946  100 CONTINUE
18947  ENDIF
18948  RETURN
18949  END
18950 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
18951 *-- AUTHOR :
18952  FUNCTION photri(A,B,C)
18953 C.----------------------------------------------------------------------
18954 C.
18955 C. PHOTOS: PHOTON RADIATION IN DECAYS CALCULATION OF TRIANGLE FIE
18956 C.
18957 C. PURPOSE: CALCULATION OF TRIANGLE FUNCTION FOR PHASE SPACE.
18958 C.
18959 C. INPUT PARAMETERS: A, B, C (VIRTUAL) PARTICLE MASSES.
18960 C.
18961 C. OUTPUT PARAMETER: FUNCTION VALUE =
18962 C. SQRT(LAMBDA(A**2,B**2,C**2))/(2*A)
18963 C.
18964 C. AUTHOR(S): B. VAN EIJK CREATED AT: 15/11/89
18965 C. LAST UPDATE: 02/01/90
18966 C.
18967 C.----------------------------------------------------------------------
18968 C-- IMPLICIT NONE
18969  DOUBLE PRECISION da,db,dc,dapb,damb,dtrian
18970  REAL a,b,c,photri
18971  da=a
18972  db=b
18973  dc=c
18974  dapb=da+db
18975  damb=da-db
18976  dtrian=sqrt((damb-dc)*(dapb+dc)*(damb+dc)*(dapb-dc))
18977  photri=dtrian/(da+da)
18978  RETURN
18979  END
18980 *CMZ : 1.01/08 05/03/95 11.39.27 BY PIERO ZUCCHELLI
18981 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
18982 *-- AUTHOR :
18983  SUBROUTINE photwo(MODE)
18984 C.----------------------------------------------------------------------
18985 C.
18986 C. PHOTWO: PHOTOS BUT TWO MOTHERS ALLOWED
18987 C.
18988 C. PURPOSE: COMBINES TWO MOTHERS INTO ONE IN /PHOEVT/
18989 C. NECESSARY EG IN CASE OF G G (Q QBAR) --> T TBAR
18990 C.
18991 C. INPUT PARAMETERS: COMMON /PHOEVT/ (/PHOCMS/)
18992 C.
18993 C. OUTPUT PARAMETERS: COMMON /PHOEVT/, (STORED MOTHERS)
18994 C.
18995 C. AUTHOR(S): Z. WAS CREATED AT: 5/08/93
18996 C. LAST UPDATE:10/08/93
18997 C.
18998 C.----------------------------------------------------------------------
18999 C-- IMPLICIT NONE
19000  INTEGER nmxpho
19001  parameter(nmxpho=2000)
19002  INTEGER idpho,istpho,jdapho,jmopho,nevpho,npho
19003  REAL ppho,vpho
19004  common/phoevt/nevpho,npho,istpho(nmxpho),idpho(nmxpho),
19005  +jmopho(2,nmxpho),jdapho(2,nmxpho),ppho(5,nmxpho),vpho(4,nmxpho)
19006  DOUBLE PRECISION bet(3),gam
19007  COMMON /phocms/ bet,gam
19008  INTEGER i,mode
19009  REAL mpasqr
19010  LOGICAL ifrad
19011 C LOGICAL IFRAD IS USED TO TAG CASES WHEN TWO MOTHERS MAY BE
19012 C MERGED TO THE SOLE ONE.
19013 C SO FAR USED IN CASE:
19014 C 1) OF T TBAR PRODUCTION
19015 C
19016 C T TBAR CASE
19017  IF(mode.EQ.0) THEN
19018  ifrad=(idpho(1).EQ.21).AND.(idpho(2).EQ.21)
19019  ifrad=ifrad.OR.(idpho(1).EQ.-idpho(2).AND.abs(idpho(1)).LE.6)
19020  ifrad=ifrad .AND.(abs(idpho(3)).EQ.6).AND.(abs(idpho(4)).EQ.6)
19021  mpasqr= (ppho(4,1)+ppho(4,2))**2-(ppho(3,1)+ppho(3,2))**2
19022  + -(ppho(2,1)+ppho(2,2))**2-(ppho(1,1)+ppho(1,2))**2
19023  ifrad=ifrad.AND.(mpasqr.GT.0.0)
19024  IF(ifrad) THEN
19025 C.....COMBINING FIRST AND SECOND MOTHER
19026  DO i=1,4
19027  ppho(i,1)=ppho(i,1)+ppho(i,2)
19028  ENDDO
19029  ppho(5,1)=sqrt(mpasqr)
19030 C.....REMOVING SECOND MOTHER,
19031  DO i=1,5
19032  ppho(i,2)=0.0
19033  ENDDO
19034  ENDIF
19035  ELSE
19036 C BOOSTING OF THE MOTHERS TO THE REACTION FRAME NOT IMPLEMENTED YET.
19037 C TO DO IT IN MODE 0 ORIGINAL MOTHERS HAVE TO BE STORED IN NEW COMMON (?)
19038 C AND IN MODE 1 BOOSTED TO CMS.
19039  ENDIF
19040  END
19041 *CMZ : 1.01/50 23/05/96 10.22.20 by Piero Zucchelli
19042 *CMZ : 1.00/00 10/08/94 16.28.56 BY PIERO ZUCCHELLI
19043 *-- AUTHOR :
19044  SUBROUTINE phtype(ID)
19045 C.----------------------------------------------------------------------
19046 C.
19047 C. PHTYPE: CENTRAL MANADGEMENT ROUTINE.
19048 C.
19049 C. PURPOSE: DEFINES WHAT KIND OF THE
19050 C. ACTIONS WILL BE PERFORMED AT POINT ID.
19051 C.
19052 C. INPUT PARAMETERS: ID: POINTER OF PARTICLE STARTING BRANCH
19053 C. IN /HEPEVT/ TO BE TREATED.
19054 C.
19055 C. OUTPUT PARAMETERS: COMMON /HEPEVT/.
19056 C.
19057 C. AUTHOR(S): Z. WAS CREATED AT: 24/05/93
19058 C. LAST UPDATE: 01/10/93
19059 C.
19060 C.----------------------------------------------------------------------
19061 C-- IMPLICIT NONE
19062  INTEGER nmxhep
19063  parameter(nmxhep=2000)
19064  INTEGER idhep,isthep,jdahep,jmohep,nevhep,nhep
19065  DOUBLE PRECISION phep,vhep
19066  common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),
19067  &jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)
19068  LOGICAL interf,isec,iftop
19069  REAL fint,fsec
19070  COMMON /phokey/ interf,fint,isec,fsec,iftop
19071  INTEGER id,nhep0
19072  LOGICAL ipair
19073  REAL rn,phoran
19074  INTEGER wtdum
19075 C--
19076  ipair=.true.
19077 C-- CHECK DECAY MULTIPLICITY..
19078  IF (jdahep(1,id).EQ.0) RETURN
19079 C IF (JDAHEP(1,ID).EQ.JDAHEP(2,ID)) RETURN
19080 C--
19081  nhep0=nhep
19082 C--
19083  IF(isec) THEN
19084 C-- DOUBLE PHOTON EMISSION
19085  fsec=1.0
19086  rn=phoran(wtdum)
19087  IF (rn.GE.0.5) THEN
19088  CALL phomak(id,nhep0)
19089  CALL phomak(id,nhep0)
19090  ENDIF
19091  ELSE
19092 C-- SINGLE PHOTON EMISSION
19093  fsec=1.0
19094  CALL phomak(id,nhep0)
19095  ENDIF
19096 C--
19097 C-- ELECTRON POSITRON PAIR (COOMENTED OUT FOR A WHILE
19098 C IF (IPAIR) CALL PHOPAR(ID,NHEP0)
19099  END
19100 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
19101 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
19102 *-- AUTHOR :
19103  SUBROUTINE prod5(P1,P2,P3,PIA)
19104 C ----------------------------------------------------------------------
19105 C EXTERNAL PRODUCT OF P1, P2, P3 4-MOMENTA.
19106 C SIGN IS CHOSEN +/- FOR DECAY OF TAU +/- RESPECTIVELY
19107 C CALLED BY : DAMPAA, CLNUT
19108 C ----------------------------------------------------------------------
19109  COMMON / jaki / jak1,jak2,jakp,jakm,ktom
19110  COMMON / idfc / idff
19111  REAL pia(4),p1(4),p2(4),p3(4)
19112  det2(i,j)=p1(i)*p2(j)-p2(i)*p1(j)
19113 * -----------------------------------
19114  IF (ktom.EQ.1.OR.ktom.EQ.-1) THEN
19115  sign= idff/abs(idff)
19116  ELSEIF (ktom.EQ.2) THEN
19117  sign=-idff/abs(idff)
19118  ELSE
19119  print *, 'STOP IN PROD5: KTOM=',ktom
19120  stop
19121  ENDIF
19122 C
19123 C EPSILON( P1(1), P2(2), P3(3), (4) ) = 1
19124 C
19125  pia(1)= -p3(3)*det2(2,4)+p3(4)*det2(2,3)+p3(2)*det2(3,4)
19126  pia(2)= -p3(4)*det2(1,3)+p3(3)*det2(1,4)-p3(1)*det2(3,4)
19127  pia(3)= p3(4)*det2(1,2)-p3(2)*det2(1,4)+p3(1)*det2(2,4)
19128  pia(4)= p3(3)*det2(1,2)-p3(2)*det2(1,3)+p3(1)*det2(2,3)
19129 C ALL FOUR INDICES ARE UP SO PIA(3) AND PIA(4) HAVE SAME SIGN
19130  DO 10 i=1,4
19131  10 pia(i)=pia(i)*sign
19132  END
19133 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
19134 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
19135 *CMZ : 1.00/00 25/07/94 19.08.36 BY PIERO ZUCCHELLI
19136 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
19137 *-- AUTHOR :
19138 C **********************************************************************
19139 
19140  SUBROUTINE pyremm(IPU1,IPU2)
19141 
19142 C...ADDS ON TARGET REMNANTS (ONE OR TWO FROM EACH SIDE) AND
19143 C...INCLUDES PRIMORDIAL KT.
19144  COMMON /leptou/ cut(14),lst(40),parl(30),xlp,ylp,w2lp,q2lp,ulp
19145  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
19146  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
19147  COMMON /pypara/ ipy(80),pypar(80),pyvar(80)
19148  COMMON /pyproc/ isub,kfl(3,2),x(2),sh,th,uh,q2,xsec(0:40)
19149  dimension kflch(2),kflsp(2),chi(2),pms(6),is(2),robo(5)
19150  DOUBLE PRECISION dbetax,dbetaz,drobo(5)
19151  DATA ipu,iq/0,0/,pei,pe,pzi,pz,shs,pzh,peh/7*0./
19152 
19153 C...FIND EVENT TYPE, SET POINTERS
19154  IF(ipu1.EQ.0.AND.ipu2.EQ.0) RETURN
19155  ilep=0
19156  IF(ipu1.EQ.0) ilep=1
19157  IF(ipu2.EQ.0) ilep=2
19158  IF(isub.EQ.7) ilep=-1
19159  IF(ilep.EQ.1) iq=21
19160  IF(ilep.EQ.2) iq=23
19161  ip=max(ipu1,ipu2)
19162  ns=n
19163 C...DEFINE INITIAL PARTONS, INCLUDING PRIMORDIAL KT
19164  10 DO 30 i=3,4
19165  IF(i.EQ.3) ipu=ipu1
19166  IF(i.EQ.4) ipu=ipu2
19167  k(i,1)=21
19168  k(i,3)=i-2
19169  DO 20 j=1,5
19170  20 p(i,j)=0.
19171  IF(isub.EQ.7) THEN
19172  k(i,2)=21
19173  shs=0.
19174  ELSEIF(ipu.NE.0) THEN
19175  k(i,2)=k(ipu,2)
19176  p(i,5)=p(ipu,5)
19177  CALL lprikt(parl(3),ptspl,phispl)
19178  p(i,1)=ptspl*cos(phispl)
19179  p(i,2)=ptspl*sin(phispl)
19180  pms(i-2)=p(i,5)**2+p(i,1)**2+p(i,2)**2
19181  ELSE
19182  k(i,2)=k(iq,2)
19183  p(i,5)=-sqrt(q2)
19184  pms(i-2)=-q2
19185  shs=(1.-x(5-i))*q2/x(5-i)+pyvar(7-i)**2
19186  ENDIF
19187  30 CONTINUE
19188 
19189 C...KINEMATICS CONSTRUCTION FOR INITIAL PARTONS
19190  IF(ilep.EQ.0) shs=pyvar(31)*pyvar(32)*pyvar(2)+
19191  +(p(3,1)+p(4,1))**2+(p(3,2)+p(4,2))**2
19192  shr=sqrt(max(0.,shs))
19193  IF(ilep.EQ.0) THEN
19194  IF((shs-pms(1)-pms(2))**2-4.*pms(1)*pms(2).LE.0.) goto 10
19195  p(3,4)=0.5*(shr+(pms(1)-pms(2))/shr)
19196  p(3,3)=sqrt(max(0.,p(3,4)**2-pms(1)))
19197  p(4,4)=shr-p(3,4)
19198  p(4,3)=-p(3,3)
19199  ELSEIF(ilep.EQ.1) THEN
19200  p(3,4)=p(iq,4)
19201  p(3,3)=p(iq,3)
19202  p(4,4)=p(ip,4)
19203  p(4,3)=p(ip,3)
19204  ELSEIF(ilep.EQ.2) THEN
19205  p(3,4)=p(ip,4)
19206  p(3,3)=p(ip,3)
19207  p(4,4)=p(iq,4)
19208  p(4,3)=p(iq,3)
19209  ENDIF
19210 
19211 C...TRANSFORM PARTONS TO OVERALL CM-FRAME (NOT FOR LEPTOPRODUCTION)
19212  IF(ilep.EQ.0) THEN
19213  mstu(1)=3
19214  mstu(2)=4
19215  drobo(3)=(p(3,1)+p(4,1))/shr
19216  drobo(4)=(p(3,2)+p(4,2))/shr
19217 * INNOCENT
19218  CALL ludbrb(mstu(1),mstu(2),0.,0.,-drobo(3),-drobo(4),0.d0)
19219  robo(2)=ulangl(p(3,1),p(3,2))
19220 * INNOCENT
19221  CALL ludbrb(mstu(1),mstu(2),0.,-robo(2),0.d0,0.d0,0.d0)
19222  robo(1)=ulangl(p(3,3),p(3,1))
19223 * INNOCENT
19224  CALL ludbrb(mstu(1),mstu(2),-robo(1),0.,0.d0,0.d0,0.d0)
19225  mstu(2)=max(ipy(47),ipu1,ipu2)
19226 * INNOCENT
19227  CALL ludbrb(mstu(1),mstu(2),
19228  + robo(1),robo(2),drobo(3),drobo(4),0.d0)
19229  drobo(5)=max(-0.999999,min(0.999999,(pyvar(31)-pyvar(32))/
19230  + (pyvar(31)+pyvar(32))))
19231 * INNOCENT
19232  CALL ludbrb(mstu(1),mstu(2),0.,0.,0.d0,0.d0,drobo(5))
19233  mstu(1)=0
19234  mstu(2)=0
19235  ENDIF
19236 
19237 C...CHECK INVARIANT MASS OF REMNANT SYSTEM:
19238 C...HADRONIC EVENTS OR LEPTOPRODUCTION
19239  IF(ilep.LE.0) THEN
19240  WRITE(*,*)'ILEP<0!!!!'
19241  IF(ipy(12).LE.0.OR.isub.EQ.7) pyvar(33)=0.
19242  IF(ipy(12).LE.0.OR.isub.EQ.7) pyvar(34)=0.
19243  peh=p(3,4)+p(4,4)+0.5*pyvar(1)*(pyvar(33)+pyvar(34))
19244  pzh=p(3,3)+p(4,3)+0.5*pyvar(1)*(pyvar(33)-pyvar(34))
19245  shh=(pyvar(1)-peh)**2-(p(3,1)+p(4,1))**2-(p(3,2)+p(4,2))**2-
19246  + pzh**2
19247  pmmin=p(1,5)+p(2,5)+ulmass(k(3,2))+ulmass(k(4,2))
19248  IF(shr.GE.pyvar(1).OR.shh.LE.(pmmin+pypar(12))**2) THEN
19249  WRITE(*,*)'ERROR 1 IPY(48)'
19250  ipy(48)=1
19251  RETURN
19252  ENDIF
19253  shr=sqrt(shh+(p(3,1)+p(4,1))**2+(p(3,2)+p(4,2))**2)
19254  ELSE
19255 * NSAVE=N
19256 * N=40
19257 * CALL LULIST(1)
19258 * N=NSAVE
19259  pei=p(iq,4)+p(ip,4)
19260  pzi=p(iq,3)+p(ip,3)
19261  pms(ilep)=max(0.,pei**2-pzi**2+p(5-ilep,1)**2+p(5-ilep,2)**2)
19262  pmmin=p(3-ilep,5)+ulmass(k(5-ilep,2))+sqrt(pms(ilep))
19263 * WRITE(*,*)'SHR,PMMIN,PYPAR(12),X=',SHR,PMMIN,PYPAR(12),X(1),X(2)
19264 * WRITE(*,*)'PEI,PZI,PMS,PX,PY',SHR,PMMIN,PYPAR(12),X(1),X(2)
19265 * WRITE(*,*)'PYVAR1, PYVAR33, PYVAR34',PYVAR(1),PYVAR(33),PYVAR(34)
19266 * WRITE(*,*)'IQ,IP,IPY(12),ISUB,ILEP=',IQ,IP,IPY(12),ISUB,ILEP
19267  IF(shr.LE.pmmin+pypar(12)) THEN
19268 * WRITE(*,*)'ERROR 2 IPY(48)'
19269  ipy(48)=1
19270  RETURN
19271  ENDIF
19272  ENDIF
19273 
19274 C...SUBDIVIDE REMNANT IF NECESSARY, STORE FIRST PARTON
19275  40 i=ns-1
19276  DO 70 jt=1,2
19277  IF(jt.EQ.ilep) goto 70
19278  IF(jt.EQ.1) ipu=ipu1
19279  IF(jt.EQ.2) ipu=ipu2
19280  CALL pyspla(ipy(40+jt),kfl(1,jt),kflch(jt),kflsp(jt))
19281  i=i+2
19282  is(jt)=i
19283  k(i,1)=3
19284  k(i,2)=kflsp(jt)
19285  k(i,3)=jt
19286  p(i,5)=ulmass(k(i,2))
19287 C...FIRST PARTON COLOUR CONNECTIONS AND TRANSVERSE MASS
19288  k(i+1,1)=-1
19289  k(i+1,3)=i
19290  k(i+1,2)=1000
19291  IF(ipy(34).GE.1) k(i+1,2)=1000+jt
19292  DO 50 j=1,5
19293  50 p(i+1,j)=0.
19294  IF(kflsp(jt).EQ.21) THEN
19295  p(i+1,3)=ipu
19296  p(i+1,4)=ipu
19297  p(ipu+1,1)=i
19298  p(ipu+1,2)=i
19299  k(i,4)=ipu+ipu*mstu(5)
19300  k(i,5)=ipu+ipu*mstu(5)
19301  k(ipu,4)=mod(k(ipu,4),mstu(5))+i*mstu(5)
19302  k(ipu,5)=mod(k(ipu,5),mstu(5))+i*mstu(5)
19303  ELSE
19304  ifls=(3-isign(1,kflsp(jt)*(1102-iabs(kflsp(jt)))))/2
19305  p(i+1,ifls+2)=ipu
19306  p(ipu+1,3-ifls)=i
19307  k(i,ifls+3)=ipu
19308  k(ipu,6-ifls)=mod(k(ipu,6-ifls),mstu(5))+i*mstu(5)
19309  ENDIF
19310  IF(kflch(jt).EQ.0) THEN
19311  p(i,1)=-p(jt+2,1)
19312  p(i,2)=-p(jt+2,2)
19313  pms(jt)=p(i,5)**2+p(i,1)**2+p(i,2)**2
19314  ELSE
19315 C...WHEN EXTRA REMNANT PARTON OR HADRON: FIND RELATIVE PT, STORE
19316 C...PRIMORDIAL KT SPLIT SHARED BETWEEN REMNANTS
19317  CALL lprikt(parl(14),ptspl,phispl)
19318 C...RELATIVE DISTRIBUTION OF ENERGY; EXTRA PARTON COLOUR CONNECTION
19319  CALL lremh(0,kflsp(jt),kflch(jt),chi(jt))
19320  p(i,1)=-p(jt+2,1)*(1.-chi(jt))+ptspl*cos(phispl)
19321  p(i,2)=-p(jt+2,2)*(1.-chi(jt))+ptspl*sin(phispl)
19322  pms(jt+2)=p(i,5)**2+p(i,1)**2+p(i,2)**2
19323  i=i+2
19324  DO 60 j=1,5
19325  k(i,j)=0
19326  k(i+1,j)=0
19327  p(i,j)=0.
19328  60 p(i+1,j)=0.
19329  k(i,1)=1
19330  k(i,2)=kflch(jt)
19331  k(i,3)=jt
19332  p(i,5)=ulmass(k(i,2))
19333  p(i,1)=-p(jt+2,1)*chi(jt)-ptspl*cos(phispl)
19334  p(i,2)=-p(jt+2,2)*chi(jt)-ptspl*sin(phispl)
19335  pms(jt+4)=p(i,5)**2+p(i,1)**2+p(i,2)**2
19336 C...END OF UPDATE
19337  pms(jt)=pms(jt+4)/chi(jt)+pms(jt+2)/(1.-chi(jt))
19338  k(i+1,1)=-1
19339  k(i+1,3)=i
19340  k(i+1,2)=1000
19341  IF(ipy(34).GE.1) k(i+1,2)=1000+jt
19342  IF((iabs(kflch(jt)).GE.1.AND.iabs(kflch(jt)).LE.8).OR.
19343  + iabs(kflch(jt)).EQ.21.OR.lucomp(iabs(kflch(jt))).EQ.90) THEN
19344  ifls=(3-isign(1,kflch(jt)*(1102-iabs(kflch(jt)))))/2
19345  p(i+1,ifls+2)=ipu
19346  p(ipu+1,3-ifls)=i
19347  k(i,1)=3
19348  k(i,ifls+3)=ipu
19349  k(ipu,6-ifls)=mod(k(ipu,6-ifls),mstu(5))+i*mstu(5)
19350  ELSE
19351  IF(ipy(34).GE.1) THEN
19352  k(i,1)=1
19353  k(i,3)=jt
19354  ENDIF
19355  ENDIF
19356  ENDIF
19357  70 CONTINUE
19358  IF(shr.LE.sqrt(pms(1))+sqrt(pms(2))) goto 40
19359  n=i+1
19360 
19361 C...RECONSTRUCT KINEMATICS OF REMNANTS
19362  DO 80 jt=1,2
19363  IF(jt.EQ.ilep) goto 80
19364  pe=0.5*(shr+(pms(jt)-pms(3-jt))/shr)
19365  pz=sqrt(pe**2-pms(jt))
19366  IF(kflch(jt).EQ.0) THEN
19367  p(is(jt),4)=pe
19368  p(is(jt),3)=pz*(-1)**(jt-1)
19369  ELSE
19370  pw1=chi(jt)*(pe+pz)
19371  p(is(jt)+2,4)=0.5*(pw1+pms(jt+4)/pw1)
19372  p(is(jt)+2,3)=0.5*(pw1-pms(jt+4)/pw1)*(-1)**(jt-1)
19373  p(is(jt),4)=pe-p(is(jt)+2,4)
19374  p(is(jt),3)=pz*(-1)**(jt-1)-p(is(jt)+2,3)
19375  ENDIF
19376  80 CONTINUE
19377 
19378 C CALL GULIST(31,2)
19379 C...HADRONIC EVENTS: BOOST REMNANTS TO CORRECT LONGITUDINAL FRAME
19380  IF(ilep.LE.0) THEN
19381  mstu(1)=ns+1
19382 * INNOCENT
19383  CALL ludbrb(mstu(1),mstu(2),
19384  + 0.,0.,0.d0,0.d0,-dble(pzh)/(dble(pyvar(1))-dble(peh)))
19385  mstu(1)=0
19386 C...LEPTOPRODUCTION EVENTS: BOOST COLLIDING SUBSYSTEM
19387  ELSE
19388  imin=21
19389  imax=max(ip,ipy(47))
19390  pef=shr-pe
19391  pzf=pz*(-1)**(ilep-1)
19392  pt2=p(5-ilep,1)**2+p(5-ilep,2)**2
19393  phipt=ulangl(p(5-ilep,1),p(5-ilep,2))
19394  CALL ludbrb(imin,imax,0.,-phipt,0.d0,0.d0,0.d0)
19395  rqp=p(iq,3)*(pt2+pei**2)-p(iq,4)*pei*pzi
19396  sinth=p(iq,4)*sqrt(pt2*(pt2+pei**2)/(rqp**2+pt2*
19397  + p(iq,4)**2*pzi**2))*sign(1.,-rqp)
19398  CALL ludbrb(imin,imax,asin(sinth),0.,0.d0,0.d0,0.d0)
19399  dbetax=(-dble(pei)*pzi*sinth+
19400  + sqrt(dble(pt2)*(pt2+pei**2-(pzi*sinth)**2)))/
19401  + (dble(pt2)+pei**2)
19402  CALL ludbrb(imin,imax,0.,0.,dbetax,0.d0,0.d0)
19403  CALL ludbrb(imin,imax,0.,phipt,0.d0,0.d0,0.d0)
19404  pem=p(iq,4)+p(ip,4)
19405  pzm=p(iq,3)+p(ip,3)
19406  dbetaz=(-dble(pem)*pzm+
19407  + pzf*sqrt(dble(pzf)**2+pem**2-pzm**2))/(dble(pzf)**2+pem**2)
19408  CALL ludbrb(imin,imax,0.,0.,0.d0,0.d0,dbetaz)
19409  CALL ludbrb(3,4,asin(sinth),0.,dbetax,0.d0,0.d0)
19410  CALL ludbrb(3,4,0.,phipt,0.d0,0.d0,dbetaz)
19411  ENDIF
19412 
19413  RETURN
19414  END
19415 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
19416 *CMZ : 1.00/00 04/07/94 15.02.28 BY PIERO ZUCCHELLI
19417 *-- AUTHOR :
19418 C **********************************************************************
19419 
19420  SUBROUTINE pyspla(KPART,KFLIN,KFLCH,KFLSP)
19421 
19422 C...IN CASE OF A HADRON REMNANT WHICH IS MORE COMPLICATED THAN JUST A
19423 C...QUARK OR A DIQUARK, SPLIT IT INTO TWO (PARTONS OR HADRON + PARTON).
19424  COMMON /leptou/ cut(14),lst(40),parl(30),xlp,ylp,w2lp,q2lp,ulp
19425 
19426  iflin=kflin
19427  ksign=isign(1,kpart)
19428  ifl=kflin*ksign
19429  kflch=0
19430  idum=0
19431 
19432  IF(lst(14).EQ.0) THEN
19433 C...IF BARYON PRODUCTION FROM REMNANT EXCLUDED, REMNANT IS ANTIFLAVOUR
19434  kflsp=-kflin
19435  IF(kflin.EQ.21) kflsp=21
19436  RETURN
19437  ENDIF
19438 
19439  IF(iabs(kpart).EQ.211) THEN
19440 C...DECOMPOSE PI+ (PI-).
19441  IF(ifl.EQ.2) THEN
19442 C...VALENCE U (UBAR) REMOVED.
19443  kflsp=-1*ksign
19444  ELSEIF(ifl.EQ.-1) THEN
19445 C...VALENCE D (DBAR) REMOVED.
19446  kflsp=2*ksign
19447  ELSEIF(kflin.EQ.21) THEN
19448 C...GLUON REMOVED.
19449  r=2.*rlu(0)
19450  IF(r.LT.1.) THEN
19451  kflch=2*ksign
19452  kflsp=-1*ksign
19453  ELSE
19454  kflch=-1*ksign
19455  kflsp=2*ksign
19456  ENDIF
19457  ELSEIF((ifl.GE.1.AND.ifl.LE.8).AND.ifl.NE.2) THEN
19458 C...SEA QUARK (ANTIQUARK) REMOVED.
19459  CALL lukfdi(-iflin,2*ksign,idum,kflch)
19460  kflsp=-1*ksign
19461  ELSEIF((ifl.GE.-8.AND.ifl.LE.-1).AND.ifl.NE.-1) THEN
19462 C...SEA ANTIQUARK (QUARK) REMOVED.
19463  CALL lukfdi(-iflin,-1*ksign,idum,kflch)
19464  kflsp=2*ksign
19465  ENDIF
19466 
19467  ELSEIF(iabs(kpart).EQ.2212) THEN
19468 C...DECOMPOSE PROTON (ANTIPROTON).
19469  IF(ifl.EQ.2) THEN
19470 C...VALENCE U (UBAR) REMOVED.
19471  r=4.*rlu(0)
19472  IF(r.LT.3.) THEN
19473  kflsp=2101*ksign
19474  ELSE
19475  kflsp=2103*ksign
19476  ENDIF
19477  ELSEIF(ifl.EQ.1) THEN
19478 C...VALENCE D (DBAR) REMOVED.
19479  kflsp=2203*ksign
19480  ELSEIF(kflin.EQ.21) THEN
19481 C...GLUON REMOVED.
19482  r=6.*rlu(0)
19483  IF(r.LT.3.) THEN
19484  kflch=2*ksign
19485  kflsp=2101*ksign
19486  ELSEIF(r.LT.4.) THEN
19487  kflch=2*ksign
19488  kflsp=2103*ksign
19489  ELSE
19490  kflch=1*ksign
19491  kflsp=2203*ksign
19492  ENDIF
19493  ELSEIF(ifl.GT.2) THEN
19494 C...SEA QUARK (ANTIQUARK) REMOVED.
19495  r=6*rlu(0)
19496  IF(r.LT.3.) THEN
19497  CALL lukfdi(-iflin,2*ksign,idum,kflch)
19498  kflsp=2101*ksign
19499  ELSEIF(r.LT.4.) THEN
19500  CALL lukfdi(-iflin,2*ksign,idum,kflch)
19501  kflsp=2103*ksign
19502  ELSE
19503  CALL lukfdi(-iflin,1*ksign,idum,kflch)
19504  kflsp=2203*ksign
19505  ENDIF
19506  ELSEIF(ifl.LT.0) THEN
19507 C...SEA ANTIQUARK (QUARK) REMOVED.
19508  10 r=6*rlu(0)
19509  IF(r.LT.3.) THEN
19510  CALL lukfdi(2101*ksign,-iflin,idum,kflch)
19511  kflsp=2*ksign
19512  ELSEIF(r.LT.4.) THEN
19513  CALL lukfdi(2103*ksign,-iflin,idum,kflch)
19514  kflsp=2*ksign
19515  ELSE
19516  CALL lukfdi(2203*ksign,-iflin,idum,kflch)
19517  kflsp=1*ksign
19518  ENDIF
19519  IF(kflch.EQ.0) goto 10
19520  ENDIF
19521 
19522  ELSEIF(iabs(kpart).EQ.2112) THEN
19523 C...DECOMPOSE NEUTRON (ANTINEUTRON).
19524  IF(ifl.EQ.2) THEN
19525 C...VALENCE U (UBAR) REMOVED.
19526  kflsp=1103*ksign
19527  ELSEIF(ifl.EQ.1) THEN
19528 C...VALENCE D (DBAR) REMOVED.
19529  r=4.*rlu(0)
19530  IF(r.LT.3.) THEN
19531  kflsp=2101*ksign
19532  ELSE
19533  kflsp=2103*ksign
19534  ENDIF
19535  ELSEIF(kflin.EQ.21) THEN
19536 C...GLUON REMOVED.
19537  r=6.*rlu(0)
19538  IF(r.LT.2.) THEN
19539  kflch=2*ksign
19540  kflsp=1103*ksign
19541  ELSEIF(r.LT.5.) THEN
19542  kflch=1*ksign
19543  kflsp=2101*ksign
19544  ELSE
19545  kflch=1*ksign
19546  kflsp=2103*ksign
19547  ENDIF
19548  ELSEIF(ifl.GT.2) THEN
19549 C...SEA QUARK (ANTIQUARK) REMOVED.
19550  r=6*rlu(0)
19551  IF(r.LT.2.) THEN
19552  CALL lukfdi(-iflin,2*ksign,idum,kflch)
19553  kflsp=1103*ksign
19554  ELSEIF(r.LT.5.) THEN
19555  CALL lukfdi(-iflin,1*ksign,idum,kflch)
19556  kflsp=2101*ksign
19557  ELSE
19558  CALL lukfdi(-iflin,1*ksign,idum,kflch)
19559  kflsp=2103*ksign
19560  ENDIF
19561  ELSEIF(ifl.LT.0) THEN
19562 C...SEA ANTIQUARK (QUARK) REMOVED.
19563  20 r=6*rlu(0)
19564  IF(r.LT.2.) THEN
19565  CALL lukfdi(1103*ksign,-iflin,idum,kflch)
19566  kflsp=2*ksign
19567  ELSEIF(r.LT.5.) THEN
19568  CALL lukfdi(2101*ksign,-iflin,idum,kflch)
19569  kflsp=1*ksign
19570  ELSE
19571  CALL lukfdi(2103*ksign,-iflin,idum,kflch)
19572  kflsp=1*ksign
19573  ENDIF
19574  IF(kflch.EQ.0) goto 20
19575  ENDIF
19576  ENDIF
19577 
19578  RETURN
19579  END
19580 *CMZ : 1.01/50 22/05/96 12.22.19 by Piero Zucchelli
19581 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
19582 *CMZ : 1.01/08 05/03/95 18.01.14 BY PIERO ZUCCHELLI
19583 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
19584 *-- AUTHOR :
19585 C ********************************************************************
19586 
19587  SUBROUTINE pysspb(IPU1,IPU2)
19588 *KEEP,FOREFI.
19589 C--
19590  INTEGER*4 ievt
19591  common/foreficass/ievt
19592 
19593 
19594 *KEND.
19595 C...NEW X REDEFINITION
19596 C...GENERATES SPACELIKE PARTON SHOWERS
19597  COMMON /leptou/ cut(14),lst(40),parl(30),xlp,ylp,w2lp,q2lp,ulp
19598  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
19599  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
19600  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
19601  COMMON /pypara/ ipy(80),pypar(80),pyvar(80)
19602  COMMON /pyproc/ isub,kfl(3,2),x(2),sh,th,uh,q2,xsec(0:40)
19603  COMMON /pyint1/ xq(2,-6:6)
19604  dimension ifls(4),is(2),xs(2),zs(2),q2s(2),tevs(2),robo(5),
19605  +xfs(2,-6:6),xfa(-6:6),xfb(-6:6),wtap(-6:6),wtsf(-6:6)
19606  DOUBLE PRECISION dq2(3),dsh,dshz,dshr,dplcm,dpc(3),dpd(4),dms,
19607  +dmsma,dpt2,dpb(4),dbe1(4),dbe2(4),dbep,dgabep,dpq(4),dpqs(2),
19608  +dm2,dq2b,drobo(5),dbez
19609 C-GI &DQ23,DPH(4),DM2,DQ2B,DQM2
19610  DATA ifla,nq/0,0/,z,xe0,xa/3*0./,dshz,dmsma,dpt2,dshr/4*0.d0/
19611 
19612 C...COMMON CONSTANTS, SET UP INITIAL VALUES
19613  ilep=0
19614  IF(ipu1.EQ.0) ilep=1
19615  IF(ipu2.EQ.0) ilep=2
19616  q2e=q2
19617 C-GI IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.3) Q2E=Q2E/PYPAR(26)
19618  IF(isub.EQ.27) q2e=pmas(23,1)**2
19619  IF(isub.EQ.28) q2e=pmas(24,1)**2
19620  tmax=alog(pypar(26)*pypar(27)*q2e/pypar(21)**2)
19621  IF(ilep.GE.1) THEN
19622  sh=p(25,5)**2
19623  IF(n.GE.27) sh=p(27,5)**2
19624  CALL lscale(-1,qmax)
19625  q2e=qmax**2
19626  q2e=max(pypar(21)**2,min(q2e,(0.95/x(3-ilep)-1.)*q2-sh,
19627  + q2/2.+sh))
19628  tmax=alog(q2e/pypar(21)**2)
19629  ENDIF
19630  IF(pypar(26)*q2e.LT.max(pypar(22),2.*pypar(21)**2).OR.
19631  +tmax.LT.0.2) RETURN
19632  IF(ilep.EQ.0) xe0=2.*pypar(23)/pyvar(1)
19633  b0=(33.-2.*ipy(8))/6.
19634  ns=n
19635  mstu(2)=0
19636  10 n=ns
19637  IF(ilep.GE.1) THEN
19638  nq=ipu2-2
19639  IF(ilep.EQ.2) nq=ipu1+2
19640  dpqs(1)=dble(p(nq,3))
19641  dpqs(2)=dble(p(nq,4))
19642  xbmin=x(3-ilep)*max(0.5,sh/q2)
19643  CALL pystfu(ipy(43-ilep),xbmin,q2,xfb)
19644  DO 20 ifl=-6,6
19645  20 xq(3-ilep,ifl)=xfb(ifl)
19646  ENDIF
19647  DO 30 jt=1,2
19648  ifls(jt)=kfl(2,jt)
19649  IF(kfl(2,jt).EQ.21) ifls(jt)=0
19650  ifls(jt+2)=ifls(jt)
19651  xs(jt)=x(jt)
19652  zs(jt)=1.
19653  IF(ilep.EQ.0) q2s(jt)=pypar(26)*q2e
19654  tevs(jt)=tmax
19655  DO 30 ifl=-6,6
19656  30 xfs(jt,ifl)=xq(jt,ifl)
19657  IF(ilep.GE.1) THEN
19658  q2s(ilep)=p(nq,5)**2
19659  dq2(ilep)=q2s(ilep)
19660  q2s(3-ilep)=q2e
19661  ENDIF
19662  dsh=sh
19663  ihfc=0
19664  ihfx=0
19665 
19666 C...PICK UP LEG WITH HIGHEST VIRTUALITY
19667  40 CONTINUE
19668  IF(n.GT.mstu(4)-10) THEN
19669  WRITE(6,*) ' PYSSPB: NO MORE MEMORY IN LUJETS'
19670  lst(21)=51
19671  RETURN
19672  ENDIF
19673  DO 50 i=n+1,n+8
19674  DO 50 j=1,5
19675  k(i,j)=0
19676  50 p(i,j)=0.
19677 C CALL GULIST(21,2)
19678  n=n+2
19679  jt=1
19680  IF((n.GT.ns+2.AND.q2s(2).GT.q2s(1).AND.ilep.EQ.0).OR.ilep.EQ.1)
19681  +jt=2
19682  jr=3-jt
19683  iflb=ifls(jt)
19684  xb=xs(jt)
19685  IF(ilep.GE.1.AND.n.EQ.ns+2) xb=xs(jt)*max(sh/q2,0.5)
19686  DO 60 ifl=-6,6
19687  60 xfb(ifl)=xfs(jt,ifl)
19688  q2b=q2s(jt)
19689  tevb=tevs(jt)
19690  IF(ipy(14).GE.9.AND.n.GT.ns+4) THEN
19691  q2b=0.5*(1./zs(jt)+1.)*q2s(jt)+0.5*(1./zs(jt)-1.)*(q2s(3-jt)-
19692  + sngl(dsh)+sqrt((sngl(dsh)+q2s(1)+q2s(2))**2+8.*q2s(1)*q2s(2)*
19693  + zs(jt)/(1.-zs(jt))))
19694  tevb=alog(pypar(27)*q2b/pypar(21)**2)
19695  ENDIF
19696  IF(ilep.EQ.0) THEN
19697  dshr=2.*dsqrt(dsh)
19698  dshz=dsh/dble(zs(jt))
19699  ELSEIF(ilep.GE.1) THEN
19700  dshz=dsh
19701  IF(n.GT.ns+4) dshz=(dsh+dq2(jr)-dq2(jt))/zs(jt)-dq2(jr)+
19702  + pypar(22)
19703  dpd(2)=dshz+dq2(jr)+dble(pypar(22))
19704 
19705  qmass=ulmass(iabs(iflb))
19706  IF(iabs(iflb).EQ.0) qmass=ulmass(21)
19707 C...CHECK IF QUARK PAIR CREATION ONLY POSSIBILITY
19708  IF(dq2(jr).LT.4.*qmass**2) THEN
19709  dm2=qmass**2
19710  dpc(1)=dq2(jr)*(dble(pypar(22))+dm2)**2
19711  dpc(2)=dpd(2)*(dpd(2)-2d0*pypar(22))*(pypar(22)+dm2)
19712  dpc(3)=pypar(22)*(dpd(2)-2d0*pypar(22))**2
19713  xe0=1d0-(dpc(2)-dsqrt(dpc(2)**2-4d0*dpc(1)*dpc(3)))/
19714  + (2d0*dpc(1))
19715  ELSE
19716  xe0=1d0-(dpd(2)-2d0*dble(pypar(22)))*(dpd(2)-dsqrt(dpd(2)**2-
19717  + 4d0*dq2(jr)*dble(pypar(22))))/(2d0*dq2(jr)*dble(pypar(22)))
19718  ENDIF
19719  ENDIF
19720  70 xe=max(xe0,xb*(1./(1.-pypar(24))-1.))
19721  IF(xb+xe.GE.0.999) THEN
19722  q2b=0.
19723  goto 150
19724  ENDIF
19725 
19726 C...CALCULATE ALTARELLI-PARISI AND STRUCTURE FUNCTION WEIGHTS
19727  DO 80 ifl=-6,6
19728  wtap(ifl)=0.
19729  80 wtsf(ifl)=0.
19730  IF(iflb.EQ.0) THEN
19731  wtapq=16.*(1.-sqrt(xb+xe))/(3.*sqrt(xb))
19732  DO 90 ifl=-ipy(8),ipy(8)
19733  IF(ifl.EQ.0) wtap(ifl)=6.*alog((1.-xb)/xe)
19734  90 IF(ifl.NE.0) wtap(ifl)=wtapq
19735  ELSE
19736  wtap(0)=0.5*xb*(1./(xb+xe)-1.)
19737  wtap(iflb)=8.*alog((1.-xb)*(xb+xe)/xe)/3.
19738  ENDIF
19739  100 wtsum=0.
19740  IF(ihfc.EQ.0) THEN
19741  DO 110 ifl=-ipy(8),ipy(8)
19742  wtsf(ifl)=xfb(ifl)/max(1e-10,xfb(iflb))
19743  110 wtsum=wtsum+wtap(ifl)*wtsf(ifl)
19744  IF(iabs(iflb).GE.4.AND.wtsum.GT.1e3) THEN
19745  ihfx=1
19746  DO 120 ifl=-ipy(8),ipy(8)
19747  120 wtsf(ifl)=wtsf(ifl)*1e3/wtsum
19748  wtsum=1e3
19749  ENDIF
19750  ENDIF
19751 
19752 C...CHOOSE NEW T AND FLAVOUR
19753  130 IF(ipy(14).LE.6.OR.ipy(14).GE.9) THEN
19754  tevxp=b0/max(0.0001,wtsum)
19755  ELSE
19756  tevxp=b0/max(0.0001,5.*wtsum)
19757  ENDIF
19758  tevb=tevb*exp(max(-100.,alog(rlu(0))*tevxp))
19759  q2ref=pypar(21)**2*exp(tevb)/pypar(27)
19760  q2b=q2ref/pypar(27)
19761  dq2b=q2b
19762  IF(ilep.GE.1) THEN
19763  dshz=dsh
19764  IF(n.GT.ns+4) dshz=(dsh+dq2(jr)-dq2(jt))/dble(zs(jt))-dq2(jr)+
19765  + dq2b
19766  ENDIF
19767  IF(q2b.LT.pypar(22)) THEN
19768  q2b=0.
19769  ELSE
19770  wtran=rlu(0)*wtsum
19771  ifla=-ipy(8)-1
19772  140 ifla=ifla+1
19773  wtran=wtran-wtap(ifla)*wtsf(ifla)
19774  IF(ifla.LT.ipy(8).AND.wtran.GT.0.) goto 140
19775 
19776 C...CHOOSE Z VALUE AND CORRECTIVE WEIGHT
19777  IF(iflb.EQ.0.AND.ifla.EQ.0) THEN
19778  z=1./(1.+((1.-xb)/xb)*(xe/(1.-xb))**rlu(0))
19779  wtz=(1.-z*(1.-z))**2
19780  ELSEIF(iflb.EQ.0) THEN
19781  z=xb/(1.-rlu(0)*(1.-sqrt(xb+xe)))**2
19782  wtz=0.5*(1.+(1.-z)**2)*sqrt(z)
19783  ELSEIF(ifla.EQ.0) THEN
19784  z=xb*(1.+rlu(0)*(1./(xb+xe)-1.))
19785  wtz=1.-2.*z*(1.-z)
19786  ELSE
19787  z=1.-(1.-xb)*(xe/((xb+xe)*(1.-xb)))**rlu(0)
19788  wtz=0.5*(1.+z**2)
19789  ENDIF
19790 
19791 C...REWEIGHT FIRST LEG BECAUSE OF MODIFIED XB OR CHECK PHASE SPACE
19792  IF(ilep.GE.1.AND.n.EQ.ns+2) THEN
19793  xbnew=x(jt)*(1.+(dsh-q2b)/dq2(jr))
19794  IF(xbnew.GT.min(z,0.999)) goto 130
19795  xb=xbnew
19796  ENDIF
19797 
19798 C...SUM UP SOFT GLUON EMISSION AS EFFECTIVE Z SHIFT
19799  IF(ipy(15).GE.1) THEN
19800  rsoft=6.
19801  IF(iflb.NE.0) rsoft=8./3.
19802  z=z*(tevb/tevs(jt))**(rsoft*xe/((xb+xe)*b0))
19803  IF(z.LE.xb) goto 130
19804  ENDIF
19805 
19806 C...CHECK IF HEAVY FLAVOUR BELOW THRESHOLD
19807  ihft=0
19808  IF(ilep.GE.1.AND.iabs(iflb).GE.4.AND.(xfb(iflb).LT.1e-10.OR.
19809  + q2b.LT.5.*ulmass(iabs(iflb))**2)) THEN
19810  ihft=1
19811  ifla=0
19812  ENDIF
19813 
19814 C...FOR LEPTOPRODUCTION, CHECK Z AGAINST NEW LIMIT
19815  IF(ilep.GE.1) THEN
19816  dpd(2)=dshz+dq2(jr)+dq2b
19817  dm2=ulmass(iabs(ifla-iflb))**2
19818  IF(iabs(ifla-iflb).EQ.0) dm2=ulmass(21)**2
19819  dpc(1)=dq2(jr)*(dq2b+dm2)**2
19820  dpc(2)=dpd(2)*(dpd(2)-2d0*dq2b)*(dq2b+dm2)
19821  dpc(3)=dq2b*(dpd(2)-2d0*dq2b)**2
19822  zu=(dpc(2)-dsqrt(dpc(2)**2-4d0*dpc(1)*dpc(3)))/(2d0*dpc(1))
19823  IF(z.GE.zu) goto 130
19824  ENDIF
19825 
19826 C...OPTION WITH EVOLUTION IN KT2=(1-Z)Q2:
19827  IF(ipy(14).GE.5.AND.ipy(14).LE.6.AND.n.LE.ns+4) THEN
19828 C...CHECK THAT (Q2)LAST BRANCHING < (Q2)HARD
19829  IF(q2b/(1.-z).GT.pypar(26)*q2) goto 130
19830  ELSEIF(ipy(14).GE.3.AND.ipy(14).LE.6.AND.n.GE.ns+6) THEN
19831 C...CHECK THAT Z,Q2 COMBINATION IS KINEMATICALLY ALLOWED
19832  q2max=0.5*(1./zs(jt)+1.)*dq2(jt)+0.5*(1./zs(jt)-1.)*
19833  + (dq2(3-jt)-dsh+sqrt((dsh+dq2(1)+dq2(2))**2+8.*dq2(1)*dq2(2)*
19834  + zs(jt)/(1.-zs(jt))))
19835  IF(q2b/(1.-z).GE.q2max) goto 130
19836 
19837  ELSEIF(ipy(14).EQ.7.OR.ipy(14).EQ.8) THEN
19838 C...OPTION WITH ALPHAS((1-Z)Q2): DEMAND KT2 > CUTOFF, REWEIGHT
19839  IF((1.-z)*q2b.LT.pypar(22)) goto 130
19840  alprat=tevb/(tevb+alog(1.-z))
19841  IF(alprat.LT.5.*rlu(0)) goto 130
19842  IF(alprat.GT.5.) wtz=wtz*alprat/5.
19843  ENDIF
19844 
19845 C...WEIGHTING WITH NEW STRUCTURE FUNCTIONS
19846  CALL pystfu(ipy(40+jt),xb,q2ref,xfb)
19847  xa=xb/z
19848  CALL pystfu(ipy(40+jt),xa,q2ref,xfa)
19849  IF(ihft.EQ.1.OR.ihfx.EQ.1) THEN
19850  IF(xfa(ifla).LT.1e-10) ihfc=1
19851  goto 150
19852  ELSEIF(xfb(iflb).LT.1e-20) THEN
19853  goto 10
19854  ENDIF
19855  IF(wtz*xfa(ifla)/xfb(iflb).LT.rlu(0)*wtsf(ifla)) THEN
19856  IF(ilep.GE.1.AND.n.EQ.ns+2) goto 70
19857  goto 100
19858  ENDIF
19859  ENDIF
19860 
19861  150 IF(n.EQ.ns+4-2*min(1,ilep)) THEN
19862 C...DEFINE TWO HARD SCATTERERS IN THEIR CM-FRAME
19863  dq2(jt)=q2b
19864  IF(ipy(14).GE.3.AND.ipy(14).LE.6) dq2(jt)=q2b/(1.-z)
19865  IF(ilep.EQ.0) THEN
19866  dplcm=dsqrt((dsh+dq2(1)+dq2(2))**2-4.*dq2(1)*dq2(2))/dshr
19867  DO 160 jr=1,2
19868  i=ns+2*jr-1
19869  ipo=19+2*jr
19870  k(i,1)=14
19871  k(i,2)=ifls(jr+2)
19872  IF(ifls(jr+2).EQ.0) k(i,2)=21
19873  k(i,3)=0
19874  k(i,4)=ipo
19875  k(i,5)=ipo
19876  p(i,1)=0.
19877  p(i,2)=0.
19878  p(i,3)=dplcm*(-1)**(jr+1)
19879  p(i,4)=(dsh+dq2(3-jr)-dq2(jr))/dshr
19880  p(i,5)=-sqrt(sngl(dq2(jr)))
19881  k(i+1,1)=-1
19882  k(i+1,2)=k(ipo+1,2)
19883  k(i+1,3)=i
19884  k(i+1,4)=0
19885  k(i+1,5)=0
19886  p(i+1,1)=0.
19887  p(i+1,2)=0.
19888  p(i+1,3)=ipo
19889  p(i+1,4)=ipo
19890  p(i+1,5)=0.
19891  p(ipo+1,1)=i
19892  p(ipo+1,2)=i
19893  k(ipo,4)=mod(k(ipo,4),mstu(5))+i*mstu(5)
19894  k(ipo,5)=mod(k(ipo,5),mstu(5))+i*mstu(5)
19895  160 CONTINUE
19896  ELSE
19897 C..LEPTOPRODUCTION EVENTS: BOSON AND HADRON REST FRAME
19898  i1=ns+2*ilep-1
19899  i2=ns-2*ilep+5
19900  DO 170 itemp=ns+1,ns+4
19901  DO 170 j=1,5
19902  k(itemp,j)=0
19903  170 p(itemp,j)=0.
19904  DO 180 j=1,5
19905  180 p(i1,j)=p(nq,j)
19906  k(ns+1,1)=11
19907  k(ns+3,1)=14
19908  IF(ilep.EQ.2) THEN
19909  k(ns+1,1)=14
19910  k(ns+3,1)=11
19911  ENDIF
19912  k(ns+2,1)=-1
19913  k(ns+4,1)=-1
19914  k(ns+1,3)=0
19915  k(ns+2,3)=ns+1
19916  k(ns+3,3)=0
19917  k(ns+4,3)=ns+3
19918  k(i1,2)=kfl(2,ilep)
19919  k(i2,2)=kfl(2,3-ilep)
19920  dpd(1)=dsh+dq2(1)+dq2(2)
19921  dpd(3)=(3-2*ilep)*dsqrt(dpd(1)**2-4d0*dq2(1)*dq2(2))
19922  p(i2,3)=(dpqs(2)*dpd(3)-dpqs(1)*dpd(1))/
19923  + (2d0*dq2(jr))
19924  p(i2,4)=(dpqs(1)*dpd(3)-dpqs(2)*dpd(1))/
19925  + (2d0*dq2(jr))
19926  p(i2,5)=-sqrt(sngl(dq2(3-ilep)))
19927  p(i2+1,3)=max(ipu1,ipu2)
19928  p(i2+1,4)=max(ipu1,ipu2)
19929  k(i2,4)=k(i2,4)-mod(k(i2,4),mstu(5))+max(ipu1,ipu2)
19930  k(i2,5)=k(i2,5)-mod(k(i2,5),mstu(5))+max(ipu1,ipu2)
19931  p(26-2*ilep,1)=i2
19932  p(26-2*ilep,2)=i2
19933  k(25-2*ilep,4)=mod(k(25-2*ilep,4),mstu(5))+i2*mstu(5)
19934  k(25-2*ilep,5)=mod(k(25-2*ilep,5),mstu(5))+i2*mstu(5)
19935  n=n+2
19936  ENDIF
19937 
19938  ELSEIF(n.GT.ns+4) THEN
19939 C...FIND MAXIMUM ALLOWED MASS OF TIMELIKE PARTON
19940  dq2(3)=q2b
19941  IF(ipy(14).GE.3.AND.ipy(14).LE.6) dq2(3)=q2b/(1.-z)
19942  IF(is(1).GE.1.AND.is(1).LE.mstu(4)) THEN
19943  dpc(1)=p(is(1),4)
19944  dpc(3)=0.5*(abs(p(is(1),3))+abs(p(is(2),3)))
19945  ELSE
19946 C...IS(1) NOT INITIALIZED
19947  dpc(1)=0.
19948  dpc(3)=0.5*( 0. +abs(p(is(2),3)))
19949  ENDIF
19950  dpc(2)=p(is(2),4)
19951  dpd(1)=dsh+dq2(jr)+dq2(jt)
19952  dpd(2)=dshz+dq2(jr)+dq2(3)
19953  dpd(3)=dsqrt(dpd(1)**2-4.*dq2(jr)*dq2(jt))
19954  dpd(4)=dsqrt(dpd(2)**2-4.*dq2(jr)*dq2(3))
19955  ikin=0
19956  IF((q2s(jr).GE.0.5*pypar(22).AND.dpd(1)-dpd(3).GE.1d-10*dpd(1))
19957  + .OR.ilep.GE.1) ikin=1
19958  IF(ikin.EQ.0) dmsma=(dq2(jt)/dble(zs(jt))-dq2(3))*(dsh/
19959  + (dsh+dq2(jt))-dsh/(dshz+dq2(3)))
19960  IF(ikin.EQ.1) dmsma=(dpd(1)*dpd(2)-dpd(3)*dpd(4))/(2.*
19961  + dq2(jr))-dq2(jt)-dq2(3)
19962 
19963 C...GENERATE TIMELIKE PARTON SHOWER (IF REQUIRED)
19964  it=n-1
19965  k(it,1)=3
19966  k(it,2)=iflb-ifls(jt+2)
19967  IF(iflb-ifls(jt+2).EQ.0) k(it,2)=21
19968  p(it,5)=ulmass(k(it,2))
19969  IF(sngl(dmsma).LE.p(it,5)**2) goto 10
19970  p(it,2)=0.
19971  DO 190 j=1,5
19972  k(it+1,j)=0
19973  190 p(it+1,j)=0.
19974  k(it+1,1)=-1
19975  k(it+1,2)=k(is(jt)+1,2)
19976  k(it+1,3)=it
19977  IF(mod(ipy(14),2).EQ.0) THEN
19978  p(it,1)=0.
19979  IF(ilep.EQ.0) p(it,4)=(dshz-dsh-p(it,5)**2)/dshr
19980  IF(ilep.GE.1) p(it,4)=0.5*(p(is(jt),3)*dpd(2)+
19981  + dpqs(1)*(dq2(jt)+dq2(3)+p(it,5)**2))/(p(is(jt),3)*dpqs(2)-
19982  + p(is(jt),4)*dpqs(1))-dpc(jt)
19983  p(it,3)=sqrt(max(0.,p(it,4)**2-p(it,5)**2))
19984  CALL lushow(it,0,sqrt(min(sngl(dmsma),pypar(25)*q2)))
19985  IF(n.GE.it+2) p(it,5)=p(it+2,5)
19986  IF(n.GT.mstu(4)-10) THEN
19987  WRITE(6,*) ' PYSSPB: NO MORE MEMORY IN LUJETS'
19988  lst(21)=52
19989  RETURN
19990  ENDIF
19991  DO 200 i=n+1,n+8
19992  DO 200 j=1,5
19993  k(i,j)=0
19994  200 p(i,j)=0.
19995  ENDIF
19996 
19997 C...RECONSTRUCT KINEMATICS OF BRANCHING: TIMELIKE PARTON SHOWER
19998  dms=p(it,5)**2
19999  IF(ikin.EQ.0.AND.ilep.EQ.0) dpt2=(dmsma-dms)*(dshz+dq2(3))/
20000  + (dsh+dq2(jt))
20001  IF(ikin.EQ.1.AND.ilep.EQ.0) dpt2=(dmsma-dms)*(0.5*dpd(1)*
20002  + dpd(2)+0.5*dpd(3)*dpd(4)-dq2(jr)*(dq2(jt)+dq2(3)+dms))/
20003  + (4.*dsh*dpc(3)**2)
20004  IF(ikin.EQ.1.AND.ilep.GE.1) dpt2=(dmsma-dms)*(0.5*dpd(1)*
20005  + dpd(2)+0.5*dpd(3)*dpd(4)-dq2(jr)*(dq2(jt)+dq2(3)+dms))/
20006  + dpd(3)**2
20007  IF(dpt2.LT.0.) goto 10
20008  k(it,3)=n+1
20009  p(it,1)=sqrt(sngl(dpt2))
20010  IF(ilep.EQ.0) THEN
20011  dpb(1)=(0.5*dpd(2)-dpc(jr)*(dshz+dq2(jr)-dq2(jt)-dms)/
20012  + dshr)/dpc(3)-dpc(3)
20013  p(it,3)=dpb(1)*(-1)**(jt+1)
20014  p(it,4)=(dshz-dsh-dms)/dshr
20015  ELSE
20016  dpc(3)=dq2(jt)+dq2(3)+dms
20017  dpb(2)=dpqs(2)*dble(p(is(jt),3))-dpqs(1)*dpc(jt)
20018  dpb(1)=0.5d0*(dpc(jt)*dpd(2)+dpqs(2)*dpc(3))/dpb(2)-
20019  + dble(p(is(jt),3))
20020  p(it,3)=dpb(1)
20021  p(it,4)=0.5d0*(dble(p(is(jt),3))*dpd(2)+
20022  + dpqs(1)*dpc(3))/dpb(2)-dpc(jt)
20023  ENDIF
20024  IF(n.GE.it+2) THEN
20025  mstu(1)=it+2
20026  dpb(1)=dsqrt(dpb(1)**2+dpt2)
20027  dpb(2)=dsqrt(dpb(1)**2+dms)
20028  dpb(3)=p(it+2,3)
20029  dpb(4)=dsqrt(dpb(3)**2+dms)
20030  dbez=(dpb(4)*dpb(1)-dpb(3)*dpb(2))/(dpb(4)*dpb(2)-dpb(3)*
20031  + dpb(1))
20032  CALL ludbrb(mstu(1),mstu(2),0.,0.,0.d0,0.d0,dbez)
20033  the=ulangl(p(it,3),p(it,1))
20034  CALL ludbrb(mstu(1),mstu(2),the,0.,0.d0,0.d0,0.d0)
20035  ENDIF
20036 
20037 C...RECONSTRUCT KINEMATICS OF BRANCHING: SPACELIKE PARTON
20038  k(n+1,1)=14
20039  k(n+1,2)=iflb
20040  IF(iflb.EQ.0) k(n+1,2)=21
20041  k(n+1,3)=0
20042  p(n+1,1)=p(it,1)
20043  p(n+1,2)=0.
20044  p(n+1,3)=p(it,3)+p(is(jt),3)
20045  p(n+1,4)=p(it,4)+p(is(jt),4)
20046  p(n+1,5)=-sqrt(sngl(dq2(3)))
20047  DO 210 j=1,5
20048  k(n+2,j)=0
20049  210 p(n+2,j)=0.
20050  k(n+2,1)=-1
20051  k(n+2,2)=k(is(jt)+1,2)
20052  k(n+2,3)=n+1
20053 
20054 C...DEFINE COLOUR FLOW OF BRANCHING
20055  k(is(jt),1)=14
20056  k(is(jt),3)=n+1
20057  id1=it
20058  kn1=isign(500+iabs(k(n+1,2)),2*k(n+1,2)+1)
20059  kd1=isign(500+iabs(k(id1,2)),2*k(id1,2)+1)
20060  IF(k(n+1,2).EQ.21) kn1=500
20061  IF(k(id1,2).EQ.21) kd1=500
20062  IF((kn1.GE.501.AND.kd1.GE.501).OR.(kn1.LT.0.AND.
20063  + kd1.EQ.500).OR.(kn1.EQ.500.AND.kd1.EQ.500.AND.
20064  + rlu(0).GT.0.5).OR.(kn1.EQ.500.AND.kd1.LT.0))
20065  + id1=is(jt)
20066  id2=it+is(jt)-id1
20067  p(n+2,3)=id1
20068  p(n+2,4)=id2
20069  p(id1+1,1)=n+1
20070  p(id1+1,2)=id2
20071  p(id2+1,1)=id1
20072  p(id2+1,2)=n+1
20073  k(n+1,4)=k(n+1,4)-mod(k(n+1,4),mstu(5))+id1
20074  k(n+1,5)=k(n+1,5)-mod(k(n+1,5),mstu(5))+id2
20075  k(id1,4)=mod(k(id1,4),mstu(5))+(n+1)*mstu(5)
20076  k(id1,5)=mod(k(id1,5),mstu(5))+id2*mstu(5)
20077  k(id2,4)=mod(k(id2,4),mstu(5))+id1*mstu(5)
20078  k(id2,5)=mod(k(id2,5),mstu(5))+(n+1)*mstu(5)
20079  n=n+2
20080 C CALL GULIST(22,2)
20081 
20082 C...BOOST TO NEW CM-FRAME
20083  mstu(1)=ns+1
20084  IF(ilep.EQ.0) THEN
20085  CALL ludbrb(mstu(1),mstu(2),0.,0.,
20086  + -dble(p(n-1,1)+p(is(jr),1))/dble(p(n-1,4)+p(is(jr),4)),
20087  + 0.d0,-dble(p(n-1,3)+p(is(jr),3))/dble(p(n-1,4)+p(is(jr),4)))
20088  ir=n-1+(jt-1)*(is(1)-n+1)
20089  CALL ludbrb(mstu(1),mstu(2),
20090  + -ulangl(p(ir,3),p(ir,1)),paru(2)*rlu(0),0.d0,0.d0,0.d0)
20091  ELSE
20092 C...REORIENTATE EVENT WITHOUT CHANGING THE BOSON FOUR MOMENTUM
20093  DO 220 j=1,4
20094  220 dpq(j)=p(nq,j)
20095  dbe1(4)=dpq(4)+dble(p(n-1,4))
20096  DO 230 j=1,3,2
20097  230 dbe1(j)=-(dpq(j)+dble(p(n-1,j)))/dbe1(4)
20098  dbe1(4)=1d0/dsqrt(1d0-dbe1(1)**2-dbe1(3)**2)
20099  dbep=dbe1(1)*dpq(1)+dbe1(3)*dpq(3)
20100  dgabep=dbe1(4)*(dbe1(4)*dbep/(1d0+dbe1(4))+dpq(4))
20101  DO 240 j=1,3,2
20102  240 dpq(j)=dpq(j)+dgabep*dbe1(j)
20103  dpq(4)=dbe1(4)*(dpq(4)+dbep)
20104  dpc(1)=dsqrt(dpq(1)**2+dpq(3)**2)
20105  dbe2(4)=-(dpq(4)*dpc(1)-dpqs(2)*dsqrt(dpqs(2)**2+dpc(1)**2-
20106  + dpq(4)**2))/(dpc(1)**2+dpqs(2)**2)
20107  the=ulangl(sngl(dpq(3)),sngl(dpq(1)))
20108  dbe2(1)=dbe2(4)*dsin(dble(the))
20109  dbe2(3)=dbe2(4)*dcos(dble(the))
20110  dbe2(4)=1d0/(1d0-dbe2(1)**2-dbe2(3)*2)
20111 
20112 C...CONSTRUCT THE COMBINED BOOST
20113  dpb(1)=dbe1(4)**2*dbe2(4)/(1d0+dbe1(4))
20114  dpb(2)=dbe1(1)*dbe2(1)+dbe1(3)*dbe2(3)
20115  dpb(3)=dbe1(4)*dbe2(4)*(1d0+dpb(2))
20116  DO 250 jb=1,3,2
20117  250 drobo(jb+2)=(dbe1(4)*dbe2(4)*dbe1(jb)+dbe2(4)*dbe2(jb)+
20118  + dpb(1)*dbe1(jb)*dpb(2))/dpb(3)
20119  CALL ludbrb(mstu(1),mstu(2),0.,0.,drobo(3),0.d0,drobo(5))
20120  IF(ilep.EQ.1) the=ulangl(p(ns+1,3),p(ns+1,1))
20121  IF(ilep.EQ.2) the=paru(1)+ulangl(p(ns+3,3),p(ns+3,1))
20122  CALL ludbrb(mstu(1),mstu(2),-the,paru(2)*rlu(0),0d0,0d0,0d0)
20123  ENDIF
20124  mstu(1)=0
20125  ENDIF
20126 
20127 C...SAVE QUANTITIES, LOOP BACK
20128  is(jt)=n-1
20129  IF(ilep.EQ.2.AND.n.EQ.ns+4) is(jt)=n-3
20130  q2s(jt)=q2b
20131  dq2(jt)=q2b
20132  IF(ipy(14).GE.3.AND.ipy(14).LE.6) dq2(jt)=q2b/(1.-z)
20133  dsh=dshz
20134  IF(q2b.GE.0.5*pypar(22)) THEN
20135  ifls(jt+2)=ifls(jt)
20136  ifls(jt)=ifla
20137  xs(jt)=xa
20138  zs(jt)=z
20139  DO 260 ifl=-6,6
20140  260 xfs(jt,ifl)=xfa(ifl)
20141  tevs(jt)=tevb
20142  ELSE
20143  IF(jt.EQ.1) ipu1=n-1
20144  IF(jt.EQ.2) ipu2=n-1
20145  ENDIF
20146  IF(max(iabs(1-ilep)*q2s(1),min(1,2-ilep)*q2s(2)).GE.0.5*pypar(22)
20147  +.OR.n.LE.ns+2) goto 40
20148  IF(ilep.EQ.0) THEN
20149 C...BOOST HARD SCATTERING PARTONS TO FRAME OF SHOWER INITIATORS
20150  DO 270 j=1,3
20151  270 drobo(j+2)=(p(ns+1,j)+p(ns+3,j))/(p(ns+1,4)+p(ns+3,4))
20152  DO 280 j=1,5
20153  280 p(n+2,j)=p(ns+1,j)
20154  mstu(1)=n+2
20155  mstu(2)=n+2
20156  CALL ludbrb(n+2,n+2,0.,0.,-drobo(3),-drobo(4),-drobo(5))
20157  robo(2)=ulangl(p(n+2,1),p(n+2,2))
20158  robo(1)=ulangl(p(n+2,3),sqrt(p(n+2,1)**2+p(n+2,2)**2))
20159  mstu(1)=4
20160  mstu(2)=ns
20161  CALL ludbrb(4,ns,robo(1),robo(2),drobo(3),drobo(4),drobo(5))
20162  mstu(1)=0
20163  mstu(2)=0
20164  ENDIF
20165 
20166 C...STORE USER INFORMATION
20167  k(21,1)=14
20168  IF(ilep.NE.0) k(21,1)=11
20169  k(23,1)=14
20170  k(21,3)=ns+1
20171  k(23,3)=ns+3
20172  DO 290 jt=1,2
20173  kfl(1,jt)=ifls(jt)
20174  IF(ifls(jt).EQ.0) kfl(1,jt)=21
20175  290 pyvar(30+jt)=xs(jt)
20176 
20177  DO 300 i=ns+1,n
20178  DO 300 j=1,5
20179  300 v(i,j)=0.
20180 
20181  RETURN
20182  END
20183 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
20184 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
20185 *CMZ : 1.00/00 04/07/94 15.02.28 BY PIERO ZUCCHELLI
20186 *-- AUTHOR :
20187 C **********************************************************************
20188 
20189  SUBROUTINE pystfu(KF,X,Q2,XPQ)
20190 
20191 C...MODIFIED VERSION OF ROUTINE IN PYTHIA 5.6, COURTESY OF T. SJOSTRAND.
20192 C...GIVES PROTON AND NEUTRON STRUCTURE FUNCTIONS ACCORDING TO A FEW
20193 C...DIFFERENT PARAMETRIZATIONS.
20194 C...NOTE THAT WHAT IS CODED IS X TIMES THE PROBABILITY DISTRIBUTION,
20195 C...I.E. XQ(X,Q2) ETC.
20196  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
20197  COMMON /leptou/ cut(14),lst(40),parl(30),xlp,ylp,w2lp,q2lp,ulp
20198  SAVE /ludat1/
20199  dimension xpq(-6:6),xppr(-6:6)
20200  DOUBLE PRECISION xx,qq,upv,dnv,sea,str,chm,bot,top,glu,
20201  +xpdf(-6:6),xpdg(0:5),val(20)
20202  CHARACTER*20 parm(20)
20203  DATA npdf/0/,upv,dnv,sea,str,chm,bot,top,glu/8*0.d0/
20204 
20205 C...RESET STRUCTURE FUNCTIONS.
20206  DO 10 kfl=-6,6
20207  10 xpq(kfl)=0.
20208 
20209 C...CHECK X AND PARTICLE SPECIES.
20210  IF(x.LE.0..OR.x.GE.1.) THEN
20211  WRITE(mstu(11),10000) x
20212  RETURN
20213  ENDIF
20214  kfa=iabs(kf)
20215  IF(kfa.NE.2112.AND.kfa.NE.2212) THEN
20216  WRITE(mstu(11),10100) kf
20217  RETURN
20218  ENDIF
20219 
20220 C...CONVERT LST SWITCHES TO MSPT, AND PARL PARAMETERS TO PARP
20221  mstp57=1
20222  IF(lst(15).LT.0) mstp57=0
20223  mstp51=iabs(lst(15))
20224  mstp52=lst(16)
20225  mstp58=lst(12)
20226  parp51=parl(20)
20227  parl(26)=0.
20228 
20229 C...PROTON STRUCTURE FUNCTION CALL.
20230  IF(mstp52.EQ.1.AND.mstp51.GE.1.AND.mstp51.LE.10) THEN
20231  CALL pystpr(x,q2,xppr)
20232  DO 20 kfl=-6,6
20233  20 xpq(kfl)=xppr(kfl)
20234  ELSEIF(mstp52.EQ.2) THEN
20235 C...CALL PDFLIB STRUCTURE FUNCTIONS.
20236  xx=x
20237  qq=sqrt(max(0.,q2))
20238  parm(1)='MODE'
20239  val(1)=mstp51
20240  npdf=npdf+1
20241 C!..ENABLE THE NEXT TWO LINES TO USE PDFLIB.
20242 C! IF(NPDF.EQ.1) CALL PDFSET(PARM,VAL)
20243 C! CALL STRUCTF(XX,QQ,UPV,DNV,SEA,STR,CHM,BOT,TOP,GLU)
20244  xpq(0)=glu
20245  xpq(1)=dnv+sea
20246  xpq(-1)=sea
20247  xpq(2)=upv+sea
20248  xpq(-2)=sea
20249  xpq(3)=str
20250  xpq(-3)=str
20251  xpq(4)=chm
20252  xpq(-4)=chm
20253  xpq(5)=bot
20254  xpq(-5)=bot
20255  xpq(6)=top
20256  xpq(-6)=top
20257  ELSEIF(mstp52.EQ.3) THEN
20258 C...CALL PAKPDF STRUCTURE FUNCTIONS.
20259  iparc=(mstp51+50)/100
20260  isetc=mstp51-100*iparc
20261  xx=x
20262  qq=q2
20263 C!..ENABLE THE NEXT LINE TO USE PAKPDF.
20264 C! CALL PDVAL(IPARC,ISETC,XX,QQ,XPDF,IRETC)
20265  DO 30 kfl=-6,6
20266  30 xpq(kfl)=xpdf(kfl)
20267  ELSE
20268  WRITE(mstu(11),10200) kf,mstp52,mstp51
20269  ENDIF
20270 
20271 C...ISOSPIN CONJUGATION FOR NEUTRON.
20272  IF(kfa.EQ.2112) THEN
20273  xps=xpq(1)
20274  xpq(1)=xpq(2)
20275  xpq(2)=xps
20276  xps=xpq(-1)
20277  xpq(-1)=xpq(-2)
20278  xpq(-2)=xps
20279  ENDIF
20280 
20281 C...CHARGE CONJUGATION FOR ANTIPARTICLE.
20282  IF(kf.LT.0) THEN
20283  DO 40 kfl=1,6
20284  xps=xpq(kfl)
20285  xpq(kfl)=xpq(-kfl)
20286  xpq(-kfl)=xps
20287  40 CONTINUE
20288  ENDIF
20289 
20290 C...CHECK POSITIVITY AND RESET ABOVE MAXIMUM ALLOWED FLAVOUR.
20291  DO 50 kfl=-6,6
20292  xpq(kfl)=max(0.,xpq(kfl))
20293  50 IF(iabs(kfl).GT.mstp58) xpq(kfl)=0.
20294 
20295 C...FORMATS FOR ERROR PRINTOUTS.
20296 10000 FORMAT(' ERROR: X VALUE OUTSIDE PHYSICAL RANGE; X =',1p,e12.3)
20297 10100 FORMAT(' ERROR: ILLEGAL PARTICLE CODE FOR STRUCTURE FUNCTION;',
20298  +' KF =',i5)
20299 10200 FORMAT(' ERROR: UNKNOWN STRUCTURE FUNCTION; KF, LIBRARY, SET =',
20300  +3i5)
20301 
20302  RETURN
20303  END
20304 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
20305 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
20306 *CMZ : 1.00/00 04/07/94 15.02.28 BY PIERO ZUCCHELLI
20307 *-- AUTHOR :
20308 C*********************************************************************
20309 
20310  SUBROUTINE pystpr(X,Q2,XPPR)
20311 
20312 C...MODIFIED VERSION OF ROUTINE IN PYTHIA 5.6, COURTESY OF T. SJOSTRAND.
20313 C...GIVES PROTON STRUCTURE FUNCTIONS ACCORDING TO A FEW DIFFERENT
20314 C...PARAMETRIZATIONS.
20315  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
20316  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
20317  COMMON /leptou/ cut(14),lst(40),parl(30),xlp,ylp,w2lp,q2lp,ulp
20318  SAVE /ludat1/,/ludat2/
20319  dimension xppr(-6:6),xq(9),tx(6),tt(6),ts(6),nehlq(8,2),
20320  +cehlq(6,6,2,8,2),cdo(3,6,5,2),cmt(0:3,0:2,9,4),exmt(0:3)
20321  DATA alam,vx/2*0./
20322 
20323 C...THE FOLLOWING DATA LINES ARE COEFFICIENTS NEEDED IN THE
20324 C...EICHTEN, HINCHLIFFE, LANE, QUIGG PROTON STRUCTURE FUNCTION
20325 C...PARAMETRIZATIONS, SEE BELOW.
20326 C...POWERS OF 1-X IN DIFFERENT CASES.
20327  DATA nehlq/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
20328 C...EXPANSION COEFFICIENTS FOR UP VALENCE QUARK DISTRIBUTION.
20329  DATA (((cehlq(ix,it,nx,1,1),ix=1,6),it=1,6),nx=1,2)/
20330  + 7.677e-01,-2.087e-01,-3.303e-01,-2.517e-02,-1.570e-02,-1.000e-04,
20331  +-5.326e-01,-2.661e-01, 3.201e-01, 1.192e-01, 2.434e-02, 7.620e-03,
20332  + 2.162e-01, 1.881e-01,-8.375e-02,-6.515e-02,-1.743e-02,-5.040e-03,
20333  +-9.211e-02,-9.952e-02, 1.373e-02, 2.506e-02, 8.770e-03, 2.550e-03,
20334  + 3.670e-02, 4.409e-02, 9.600e-04,-7.960e-03,-3.420e-03,-1.050e-03,
20335  +-1.549e-02,-2.026e-02,-3.060e-03, 2.220e-03, 1.240e-03, 4.100e-04,
20336  + 2.395e-01, 2.905e-01, 9.778e-02, 2.149e-02, 3.440e-03, 5.000e-04,
20337  + 1.751e-02,-6.090e-03,-2.687e-02,-1.916e-02,-7.970e-03,-2.750e-03,
20338  +-5.760e-03,-5.040e-03, 1.080e-03, 2.490e-03, 1.530e-03, 7.500e-04,
20339  + 1.740e-03, 1.960e-03, 3.000e-04,-3.400e-04,-2.900e-04,-1.800e-04,
20340  +-5.300e-04,-6.400e-04,-1.700e-04, 4.000e-05, 6.000e-05, 4.000e-05,
20341  + 1.700e-04, 2.200e-04, 8.000e-05, 1.000e-05,-1.000e-05,-1.000e-05/
20342  DATA (((cehlq(ix,it,nx,1,2),ix=1,6),it=1,6),nx=1,2)/
20343  + 7.237e-01,-2.189e-01,-2.995e-01,-1.909e-02,-1.477e-02, 2.500e-04,
20344  +-5.314e-01,-2.425e-01, 3.283e-01, 1.119e-01, 2.223e-02, 7.070e-03,
20345  + 2.289e-01, 1.890e-01,-9.859e-02,-6.900e-02,-1.747e-02,-5.080e-03,
20346  +-1.041e-01,-1.084e-01, 2.108e-02, 2.975e-02, 9.830e-03, 2.830e-03,
20347  + 4.394e-02, 5.116e-02,-1.410e-03,-1.055e-02,-4.230e-03,-1.270e-03,
20348  +-1.991e-02,-2.539e-02,-2.780e-03, 3.430e-03, 1.720e-03, 5.500e-04,
20349  + 2.410e-01, 2.884e-01, 9.369e-02, 1.900e-02, 2.530e-03, 2.400e-04,
20350  + 1.765e-02,-9.220e-03,-3.037e-02,-2.085e-02,-8.440e-03,-2.810e-03,
20351  +-6.450e-03,-5.260e-03, 1.720e-03, 3.110e-03, 1.830e-03, 8.700e-04,
20352  + 2.120e-03, 2.320e-03, 2.600e-04,-4.900e-04,-3.900e-04,-2.300e-04,
20353  +-6.900e-04,-8.200e-04,-2.000e-04, 7.000e-05, 9.000e-05, 6.000e-05,
20354  + 2.400e-04, 3.100e-04, 1.100e-04, 0.000e+00,-2.000e-05,-2.000e-05/
20355 C...EXPANSION COEFFICIENTS FOR DOWN VALENCE QUARK DISTRIBUTION.
20356  DATA (((cehlq(ix,it,nx,2,1),ix=1,6),it=1,6),nx=1,2)/
20357  + 3.813e-01,-8.090e-02,-1.634e-01,-2.185e-02,-8.430e-03,-6.200e-04,
20358  +-2.948e-01,-1.435e-01, 1.665e-01, 6.638e-02, 1.473e-02, 4.080e-03,
20359  + 1.252e-01, 1.042e-01,-4.722e-02,-3.683e-02,-1.038e-02,-2.860e-03,
20360  +-5.478e-02,-5.678e-02, 8.900e-03, 1.484e-02, 5.340e-03, 1.520e-03,
20361  + 2.220e-02, 2.567e-02,-3.000e-05,-4.970e-03,-2.160e-03,-6.500e-04,
20362  +-9.530e-03,-1.204e-02,-1.510e-03, 1.510e-03, 8.300e-04, 2.700e-04,
20363  + 1.261e-01, 1.354e-01, 3.958e-02, 8.240e-03, 1.660e-03, 4.500e-04,
20364  + 3.890e-03,-1.159e-02,-1.625e-02,-9.610e-03,-3.710e-03,-1.260e-03,
20365  +-1.910e-03,-5.600e-04, 1.590e-03, 1.590e-03, 8.400e-04, 3.900e-04,
20366  + 6.400e-04, 4.900e-04,-1.500e-04,-2.900e-04,-1.800e-04,-1.000e-04,
20367  +-2.000e-04,-1.900e-04, 0.000e+00, 6.000e-05, 4.000e-05, 3.000e-05,
20368  + 7.000e-05, 8.000e-05, 2.000e-05,-1.000e-05,-1.000e-05,-1.000e-05/
20369  DATA (((cehlq(ix,it,nx,2,2),ix=1,6),it=1,6),nx=1,2)/
20370  + 3.578e-01,-8.622e-02,-1.480e-01,-1.840e-02,-7.820e-03,-4.500e-04,
20371  +-2.925e-01,-1.304e-01, 1.696e-01, 6.243e-02, 1.353e-02, 3.750e-03,
20372  + 1.318e-01, 1.041e-01,-5.486e-02,-3.872e-02,-1.038e-02,-2.850e-03,
20373  +-6.162e-02,-6.143e-02, 1.303e-02, 1.740e-02, 5.940e-03, 1.670e-03,
20374  + 2.643e-02, 2.957e-02,-1.490e-03,-6.450e-03,-2.630e-03,-7.700e-04,
20375  +-1.218e-02,-1.497e-02,-1.260e-03, 2.240e-03, 1.120e-03, 3.500e-04,
20376  + 1.263e-01, 1.334e-01, 3.732e-02, 7.070e-03, 1.260e-03, 3.400e-04,
20377  + 3.660e-03,-1.357e-02,-1.795e-02,-1.031e-02,-3.880e-03,-1.280e-03,
20378  +-2.100e-03,-3.600e-04, 2.050e-03, 1.920e-03, 9.800e-04, 4.400e-04,
20379  + 7.700e-04, 5.400e-04,-2.400e-04,-3.900e-04,-2.400e-04,-1.300e-04,
20380  +-2.600e-04,-2.300e-04, 2.000e-05, 9.000e-05, 6.000e-05, 4.000e-05,
20381  + 9.000e-05, 1.000e-04, 2.000e-05,-2.000e-05,-2.000e-05,-1.000e-05/
20382 C...EXPANSION COEFFICIENTS FOR UP AND DOWN SEA QUARK DISTRIBUTIONS.
20383  DATA (((cehlq(ix,it,nx,3,1),ix=1,6),it=1,6),nx=1,2)/
20384  + 6.870e-02,-6.861e-02, 2.973e-02,-5.400e-03, 3.780e-03,-9.700e-04,
20385  +-1.802e-02, 1.400e-04, 6.490e-03,-8.540e-03, 1.220e-03,-1.750e-03,
20386  +-4.650e-03, 1.480e-03,-5.930e-03, 6.000e-04,-1.030e-03,-8.000e-05,
20387  + 6.440e-03, 2.570e-03, 2.830e-03, 1.150e-03, 7.100e-04, 3.300e-04,
20388  +-3.930e-03,-2.540e-03,-1.160e-03,-7.700e-04,-3.600e-04,-1.900e-04,
20389  + 2.340e-03, 1.930e-03, 5.300e-04, 3.700e-04, 1.600e-04, 9.000e-05,
20390  + 1.014e+00,-1.106e+00, 3.374e-01,-7.444e-02, 8.850e-03,-8.700e-04,
20391  + 9.233e-01,-1.285e+00, 4.475e-01,-9.786e-02, 1.419e-02,-1.120e-03,
20392  + 4.888e-02,-1.271e-01, 8.606e-02,-2.608e-02, 4.780e-03,-6.000e-04,
20393  +-2.691e-02, 4.887e-02,-1.771e-02, 1.620e-03, 2.500e-04,-6.000e-05,
20394  + 7.040e-03,-1.113e-02, 1.590e-03, 7.000e-04,-2.000e-04, 0.000e+00,
20395  +-1.710e-03, 2.290e-03, 3.800e-04,-3.500e-04, 4.000e-05, 1.000e-05/
20396  DATA (((cehlq(ix,it,nx,3,2),ix=1,6),it=1,6),nx=1,2)/
20397  + 1.008e-01,-7.100e-02, 1.973e-02,-5.710e-03, 2.930e-03,-9.900e-04,
20398  +-5.271e-02,-1.823e-02, 1.792e-02,-6.580e-03, 1.750e-03,-1.550e-03,
20399  + 1.220e-02, 1.763e-02,-8.690e-03,-8.800e-04,-1.160e-03,-2.100e-04,
20400  +-1.190e-03,-7.180e-03, 2.360e-03, 1.890e-03, 7.700e-04, 4.100e-04,
20401  +-9.100e-04, 2.040e-03,-3.100e-04,-1.050e-03,-4.000e-04,-2.400e-04,
20402  + 1.190e-03,-1.700e-04,-2.000e-04, 4.200e-04, 1.700e-04, 1.000e-04,
20403  + 1.081e+00,-1.189e+00, 3.868e-01,-8.617e-02, 1.115e-02,-1.180e-03,
20404  + 9.917e-01,-1.396e+00, 4.998e-01,-1.159e-01, 1.674e-02,-1.720e-03,
20405  + 5.099e-02,-1.338e-01, 9.173e-02,-2.885e-02, 5.890e-03,-6.500e-04,
20406  +-3.178e-02, 5.703e-02,-2.070e-02, 2.440e-03, 1.100e-04,-9.000e-05,
20407  + 8.970e-03,-1.392e-02, 2.050e-03, 6.500e-04,-2.300e-04, 2.000e-05,
20408  +-2.340e-03, 3.010e-03, 5.000e-04,-3.900e-04, 6.000e-05, 1.000e-05/
20409 C...EXPANSION COEFFICIENTS FOR GLUON DISTRIBUTION.
20410  DATA (((cehlq(ix,it,nx,4,1),ix=1,6),it=1,6),nx=1,2)/
20411  + 9.482e-01,-9.578e-01, 1.009e-01,-1.051e-01, 3.456e-02,-3.054e-02,
20412  +-9.627e-01, 5.379e-01, 3.368e-01,-9.525e-02, 1.488e-02,-2.051e-02,
20413  + 4.300e-01,-8.306e-02,-3.372e-01, 4.902e-02,-9.160e-03, 1.041e-02,
20414  +-1.925e-01,-1.790e-02, 2.183e-01, 7.490e-03, 4.140e-03,-1.860e-03,
20415  + 8.183e-02, 1.926e-02,-1.072e-01,-1.944e-02,-2.770e-03,-5.200e-04,
20416  +-3.884e-02,-1.234e-02, 5.410e-02, 1.879e-02, 3.350e-03, 1.040e-03,
20417  + 2.948e+01,-3.902e+01, 1.464e+01,-3.335e+00, 5.054e-01,-5.915e-02,
20418  + 2.559e+01,-3.955e+01, 1.661e+01,-4.299e+00, 6.904e-01,-8.243e-02,
20419  +-1.663e+00, 1.176e+00, 1.118e+00,-7.099e-01, 1.948e-01,-2.404e-02,
20420  +-2.168e-01, 8.170e-01,-7.169e-01, 1.851e-01,-1.924e-02,-3.250e-03,
20421  + 2.088e-01,-4.355e-01, 2.239e-01,-2.446e-02,-3.620e-03, 1.910e-03,
20422  +-9.097e-02, 1.601e-01,-5.681e-02,-2.500e-03, 2.580e-03,-4.700e-04/
20423  DATA (((cehlq(ix,it,nx,4,2),ix=1,6),it=1,6),nx=1,2)/
20424  + 2.367e+00, 4.453e-01, 3.660e-01, 9.467e-02, 1.341e-01, 1.661e-02,
20425  +-3.170e+00,-1.795e+00, 3.313e-02,-2.874e-01,-9.827e-02,-7.119e-02,
20426  + 1.823e+00, 1.457e+00,-2.465e-01, 3.739e-02, 6.090e-03, 1.814e-02,
20427  +-1.033e+00,-9.827e-01, 2.136e-01, 1.169e-01, 5.001e-02, 1.684e-02,
20428  + 5.133e-01, 5.259e-01,-1.173e-01,-1.139e-01,-4.988e-02,-2.021e-02,
20429  +-2.881e-01,-3.145e-01, 5.667e-02, 9.161e-02, 4.568e-02, 1.951e-02,
20430  + 3.036e+01,-4.062e+01, 1.578e+01,-3.699e+00, 6.020e-01,-7.031e-02,
20431  + 2.700e+01,-4.167e+01, 1.770e+01,-4.804e+00, 7.862e-01,-1.060e-01,
20432  +-1.909e+00, 1.357e+00, 1.127e+00,-7.181e-01, 2.232e-01,-2.481e-02,
20433  +-2.488e-01, 9.781e-01,-8.127e-01, 2.094e-01,-2.997e-02,-4.710e-03,
20434  + 2.506e-01,-5.427e-01, 2.672e-01,-3.103e-02,-1.800e-03, 2.870e-03,
20435  +-1.128e-01, 2.087e-01,-6.972e-02,-2.480e-03, 2.630e-03,-8.400e-04/
20436 C...EXPANSION COEFFICIENTS FOR STRANGE SEA QUARK DISTRIBUTION.
20437  DATA (((cehlq(ix,it,nx,5,1),ix=1,6),it=1,6),nx=1,2)/
20438  + 4.968e-02,-4.173e-02, 2.102e-02,-3.270e-03, 3.240e-03,-6.700e-04,
20439  +-6.150e-03,-1.294e-02, 6.740e-03,-6.890e-03, 9.000e-04,-1.510e-03,
20440  +-8.580e-03, 5.050e-03,-4.900e-03,-1.600e-04,-9.400e-04,-1.500e-04,
20441  + 7.840e-03, 1.510e-03, 2.220e-03, 1.400e-03, 7.000e-04, 3.500e-04,
20442  +-4.410e-03,-2.220e-03,-8.900e-04,-8.500e-04,-3.600e-04,-2.000e-04,
20443  + 2.520e-03, 1.840e-03, 4.100e-04, 3.900e-04, 1.600e-04, 9.000e-05,
20444  + 9.235e-01,-1.085e+00, 3.464e-01,-7.210e-02, 9.140e-03,-9.100e-04,
20445  + 9.315e-01,-1.274e+00, 4.512e-01,-9.775e-02, 1.380e-02,-1.310e-03,
20446  + 4.739e-02,-1.296e-01, 8.482e-02,-2.642e-02, 4.760e-03,-5.700e-04,
20447  +-2.653e-02, 4.953e-02,-1.735e-02, 1.750e-03, 2.800e-04,-6.000e-05,
20448  + 6.940e-03,-1.132e-02, 1.480e-03, 6.500e-04,-2.100e-04, 0.000e+00,
20449  +-1.680e-03, 2.340e-03, 4.200e-04,-3.400e-04, 5.000e-05, 1.000e-05/
20450  DATA (((cehlq(ix,it,nx,5,2),ix=1,6),it=1,6),nx=1,2)/
20451  + 6.478e-02,-4.537e-02, 1.643e-02,-3.490e-03, 2.710e-03,-6.700e-04,
20452  +-2.223e-02,-2.126e-02, 1.247e-02,-6.290e-03, 1.120e-03,-1.440e-03,
20453  +-1.340e-03, 1.362e-02,-6.130e-03,-7.900e-04,-9.000e-04,-2.000e-04,
20454  + 5.080e-03,-3.610e-03, 1.700e-03, 1.830e-03, 6.800e-04, 4.000e-04,
20455  +-3.580e-03, 6.000e-05,-2.600e-04,-1.050e-03,-3.800e-04,-2.300e-04,
20456  + 2.420e-03, 9.300e-04,-1.000e-04, 4.500e-04, 1.700e-04, 1.100e-04,
20457  + 9.868e-01,-1.171e+00, 3.940e-01,-8.459e-02, 1.124e-02,-1.250e-03,
20458  + 1.001e+00,-1.383e+00, 5.044e-01,-1.152e-01, 1.658e-02,-1.830e-03,
20459  + 4.928e-02,-1.368e-01, 9.021e-02,-2.935e-02, 5.800e-03,-6.600e-04,
20460  +-3.133e-02, 5.785e-02,-2.023e-02, 2.630e-03, 1.600e-04,-8.000e-05,
20461  + 8.840e-03,-1.416e-02, 1.900e-03, 5.800e-04,-2.500e-04, 1.000e-05,
20462  +-2.300e-03, 3.080e-03, 5.500e-04,-3.700e-04, 7.000e-05, 1.000e-05/
20463 C...EXPANSION COEFFICIENTS FOR CHARM SEA QUARK DISTRIBUTION.
20464  DATA (((cehlq(ix,it,nx,6,1),ix=1,6),it=1,6),nx=1,2)/
20465  + 9.270e-03,-1.817e-02, 9.590e-03,-6.390e-03, 1.690e-03,-1.540e-03,
20466  + 5.710e-03,-1.188e-02, 6.090e-03,-4.650e-03, 1.240e-03,-1.310e-03,
20467  +-3.960e-03, 7.100e-03,-3.590e-03, 1.840e-03,-3.900e-04, 3.400e-04,
20468  + 1.120e-03,-1.960e-03, 1.120e-03,-4.800e-04, 1.000e-04,-4.000e-05,
20469  + 4.000e-05,-3.000e-05,-1.800e-04, 9.000e-05,-5.000e-05,-2.000e-05,
20470  +-4.200e-04, 7.300e-04,-1.600e-04, 5.000e-05, 5.000e-05, 5.000e-05,
20471  + 8.098e-01,-1.042e+00, 3.398e-01,-6.824e-02, 8.760e-03,-9.000e-04,
20472  + 8.961e-01,-1.217e+00, 4.339e-01,-9.287e-02, 1.304e-02,-1.290e-03,
20473  + 3.058e-02,-1.040e-01, 7.604e-02,-2.415e-02, 4.600e-03,-5.000e-04,
20474  +-2.451e-02, 4.432e-02,-1.651e-02, 1.430e-03, 1.200e-04,-1.000e-04,
20475  + 1.122e-02,-1.457e-02, 2.680e-03, 5.800e-04,-1.200e-04, 3.000e-05,
20476  +-7.730e-03, 7.330e-03,-7.600e-04,-2.400e-04, 1.000e-05, 0.000e+00/
20477  DATA (((cehlq(ix,it,nx,6,2),ix=1,6),it=1,6),nx=1,2)/
20478  + 9.980e-03,-1.945e-02, 1.055e-02,-6.870e-03, 1.860e-03,-1.560e-03,
20479  + 5.700e-03,-1.203e-02, 6.250e-03,-4.860e-03, 1.310e-03,-1.370e-03,
20480  +-4.490e-03, 7.990e-03,-4.170e-03, 2.050e-03,-4.400e-04, 3.300e-04,
20481  + 1.470e-03,-2.480e-03, 1.460e-03,-5.700e-04, 1.200e-04,-1.000e-05,
20482  +-9.000e-05, 1.500e-04,-3.200e-04, 1.200e-04,-6.000e-05,-4.000e-05,
20483  +-4.200e-04, 7.600e-04,-1.400e-04, 4.000e-05, 7.000e-05, 5.000e-05,
20484  + 8.698e-01,-1.131e+00, 3.836e-01,-8.111e-02, 1.048e-02,-1.300e-03,
20485  + 9.626e-01,-1.321e+00, 4.854e-01,-1.091e-01, 1.583e-02,-1.700e-03,
20486  + 3.057e-02,-1.088e-01, 8.022e-02,-2.676e-02, 5.590e-03,-5.600e-04,
20487  +-2.845e-02, 5.164e-02,-1.918e-02, 2.210e-03,-4.000e-05,-1.500e-04,
20488  + 1.311e-02,-1.751e-02, 3.310e-03, 5.100e-04,-1.200e-04, 5.000e-05,
20489  +-8.590e-03, 8.380e-03,-9.200e-04,-2.600e-04, 1.000e-05,-1.000e-05/
20490 C...EXPANSION COEFFICIENTS FOR BOTTOM SEA QUARK DISTRIBUTION.
20491  DATA (((cehlq(ix,it,nx,7,1),ix=1,6),it=1,6),nx=1,2)/
20492  + 9.010e-03,-1.401e-02, 7.150e-03,-4.130e-03, 1.260e-03,-1.040e-03,
20493  + 6.280e-03,-9.320e-03, 4.780e-03,-2.890e-03, 9.100e-04,-8.200e-04,
20494  +-2.930e-03, 4.090e-03,-1.890e-03, 7.600e-04,-2.300e-04, 1.400e-04,
20495  + 3.900e-04,-1.200e-03, 4.400e-04,-2.500e-04, 2.000e-05,-2.000e-05,
20496  + 2.600e-04, 1.400e-04,-8.000e-05, 1.000e-04, 1.000e-05, 1.000e-05,
20497  +-2.600e-04, 3.200e-04, 1.000e-05,-1.000e-05, 1.000e-05,-1.000e-05,
20498  + 8.029e-01,-1.075e+00, 3.792e-01,-7.843e-02, 1.007e-02,-1.090e-03,
20499  + 7.903e-01,-1.099e+00, 4.153e-01,-9.301e-02, 1.317e-02,-1.410e-03,
20500  +-1.704e-02,-1.130e-02, 2.882e-02,-1.341e-02, 3.040e-03,-3.600e-04,
20501  +-7.200e-04, 7.230e-03,-5.160e-03, 1.080e-03,-5.000e-05,-4.000e-05,
20502  + 3.050e-03,-4.610e-03, 1.660e-03,-1.300e-04,-1.000e-05, 1.000e-05,
20503  +-4.360e-03, 5.230e-03,-1.610e-03, 2.000e-04,-2.000e-05, 0.000e+00/
20504  DATA (((cehlq(ix,it,nx,7,2),ix=1,6),it=1,6),nx=1,2)/
20505  + 8.980e-03,-1.459e-02, 7.510e-03,-4.410e-03, 1.310e-03,-1.070e-03,
20506  + 5.970e-03,-9.440e-03, 4.800e-03,-3.020e-03, 9.100e-04,-8.500e-04,
20507  +-3.050e-03, 4.440e-03,-2.100e-03, 8.500e-04,-2.400e-04, 1.400e-04,
20508  + 5.300e-04,-1.300e-03, 5.600e-04,-2.700e-04, 3.000e-05,-2.000e-05,
20509  + 2.000e-04, 1.400e-04,-1.100e-04, 1.000e-04, 0.000e+00, 0.000e+00,
20510  +-2.600e-04, 3.200e-04, 0.000e+00,-3.000e-05, 1.000e-05,-1.000e-05,
20511  + 8.672e-01,-1.174e+00, 4.265e-01,-9.252e-02, 1.244e-02,-1.460e-03,
20512  + 8.500e-01,-1.194e+00, 4.630e-01,-1.083e-01, 1.614e-02,-1.830e-03,
20513  +-2.241e-02,-5.630e-03, 2.815e-02,-1.425e-02, 3.520e-03,-4.300e-04,
20514  +-7.300e-04, 8.030e-03,-5.780e-03, 1.380e-03,-1.300e-04,-4.000e-05,
20515  + 3.460e-03,-5.380e-03, 1.960e-03,-2.100e-04, 1.000e-05, 1.000e-05,
20516  +-4.850e-03, 5.950e-03,-1.890e-03, 2.600e-04,-3.000e-05, 0.000e+00/
20517 C...EXPANSION COEFFICIENTS FOR TOP SEA QUARK DISTRIBUTION.
20518  DATA (((cehlq(ix,it,nx,8,1),ix=1,6),it=1,6),nx=1,2)/
20519  + 4.410e-03,-7.480e-03, 3.770e-03,-2.580e-03, 7.300e-04,-7.100e-04,
20520  + 3.840e-03,-6.050e-03, 3.030e-03,-2.030e-03, 5.800e-04,-5.900e-04,
20521  +-8.800e-04, 1.660e-03,-7.500e-04, 4.700e-04,-1.000e-04, 1.000e-04,
20522  +-8.000e-05,-1.500e-04, 1.200e-04,-9.000e-05, 3.000e-05, 0.000e+00,
20523  + 1.300e-04,-2.200e-04,-2.000e-05,-2.000e-05,-2.000e-05,-2.000e-05,
20524  +-7.000e-05, 1.900e-04,-4.000e-05, 2.000e-05, 0.000e+00, 0.000e+00,
20525  + 6.623e-01,-9.248e-01, 3.519e-01,-7.930e-02, 1.110e-02,-1.180e-03,
20526  + 6.380e-01,-9.062e-01, 3.582e-01,-8.479e-02, 1.265e-02,-1.390e-03,
20527  +-2.581e-02, 2.125e-02, 4.190e-03,-4.980e-03, 1.490e-03,-2.100e-04,
20528  + 7.100e-04, 5.300e-04,-1.270e-03, 3.900e-04,-5.000e-05,-1.000e-05,
20529  + 3.850e-03,-5.060e-03, 1.860e-03,-3.500e-04, 4.000e-05, 0.000e+00,
20530  +-3.530e-03, 4.460e-03,-1.500e-03, 2.700e-04,-3.000e-05, 0.000e+00/
20531  DATA (((cehlq(ix,it,nx,8,2),ix=1,6),it=1,6),nx=1,2)/
20532  + 4.260e-03,-7.530e-03, 3.830e-03,-2.680e-03, 7.600e-04,-7.300e-04,
20533  + 3.640e-03,-6.050e-03, 3.030e-03,-2.090e-03, 5.900e-04,-6.000e-04,
20534  +-9.200e-04, 1.710e-03,-8.200e-04, 5.000e-04,-1.200e-04, 1.000e-04,
20535  +-5.000e-05,-1.600e-04, 1.300e-04,-9.000e-05, 3.000e-05, 0.000e+00,
20536  + 1.300e-04,-2.100e-04,-1.000e-05,-2.000e-05,-2.000e-05,-1.000e-05,
20537  +-8.000e-05, 1.800e-04,-5.000e-05, 2.000e-05, 0.000e+00, 0.000e+00,
20538  + 7.146e-01,-1.007e+00, 3.932e-01,-9.246e-02, 1.366e-02,-1.540e-03,
20539  + 6.856e-01,-9.828e-01, 3.977e-01,-9.795e-02, 1.540e-02,-1.790e-03,
20540  +-3.053e-02, 2.758e-02, 2.150e-03,-4.880e-03, 1.640e-03,-2.500e-04,
20541  + 9.200e-04, 4.200e-04,-1.340e-03, 4.600e-04,-8.000e-05,-1.000e-05,
20542  + 4.230e-03,-5.660e-03, 2.140e-03,-4.300e-04, 6.000e-05, 0.000e+00,
20543  +-3.890e-03, 5.000e-03,-1.740e-03, 3.300e-04,-4.000e-05, 0.000e+00/
20544 
20545 C...THE FOLLOWING DATA LINES ARE COEFFICIENTS NEEDED IN THE
20546 C...DUKE, OWENS PROTON STRUCTURE FUNCTION PARAMETRIZATIONS, SEE BELOW.
20547 C...EXPANSION COEFFICIENTS FOR (UP+DOWN) VALENCE QUARK DISTRIBUTION.
20548  DATA ((cdo(ip,is,1,1),is=1,6),ip=1,3)/
20549  + 4.190e-01, 3.460e+00, 4.400e+00, 0.000e+00, 0.000e+00, 0.000e+00,
20550  + 4.000e-03, 7.240e-01,-4.860e+00, 0.000e+00, 0.000e+00, 0.000e+00,
20551  +-7.000e-03,-6.600e-02, 1.330e+00, 0.000e+00, 0.000e+00, 0.000e+00/
20552  DATA ((cdo(ip,is,1,2),is=1,6),ip=1,3)/
20553  + 3.740e-01, 3.330e+00, 6.030e+00, 0.000e+00, 0.000e+00, 0.000e+00,
20554  + 1.400e-02, 7.530e-01,-6.220e+00, 0.000e+00, 0.000e+00, 0.000e+00,
20555  + 0.000e+00,-7.600e-02, 1.560e+00, 0.000e+00, 0.000e+00, 0.000e+00/
20556 C...EXPANSION COEFFICIENTS FOR DOWN VALENCE QUARK DISTRIBUTION.
20557  DATA ((cdo(ip,is,2,1),is=1,6),ip=1,3)/
20558  + 7.630e-01, 4.000e+00, 0.000e+00, 0.000e+00, 0.000e+00, 0.000e+00,
20559  +-2.370e-01, 6.270e-01,-4.210e-01, 0.000e+00, 0.000e+00, 0.000e+00,
20560  + 2.600e-02,-1.900e-02, 3.300e-02, 0.000e+00, 0.000e+00, 0.000e+00/
20561  DATA ((cdo(ip,is,2,2),is=1,6),ip=1,3)/
20562  + 7.610e-01, 3.830e+00, 0.000e+00, 0.000e+00, 0.000e+00, 0.000e+00,
20563  +-2.320e-01, 6.270e-01,-4.180e-01, 0.000e+00, 0.000e+00, 0.000e+00,
20564  + 2.300e-02,-1.900e-02, 3.600e-02, 0.000e+00, 0.000e+00, 0.000e+00/
20565 C...EXPANSION COEFFICIENTS FOR (UP+DOWN+STRANGE) SEA QUARK DISTRIBUTION.
20566  DATA ((cdo(ip,is,3,1),is=1,6),ip=1,3)/
20567  + 1.265e+00, 0.000e+00, 8.050e+00, 0.000e+00, 0.000e+00, 0.000e+00,
20568  +-1.132e+00,-3.720e-01, 1.590e+00, 6.310e+00,-1.050e+01, 1.470e+01,
20569  + 2.930e-01,-2.900e-02,-1.530e-01,-2.730e-01,-3.170e+00, 9.800e+00/
20570  DATA ((cdo(ip,is,3,2),is=1,6),ip=1,3)/
20571  + 1.670e+00, 0.000e+00, 9.150e+00, 0.000e+00, 0.000e+00, 0.000e+00,
20572  +-1.920e+00,-2.730e-01, 5.300e-01, 1.570e+01,-1.010e+02, 2.230e+02,
20573  + 5.820e-01,-1.640e-01,-7.630e-01,-2.830e+00, 4.470e+01,-1.170e+02/
20574 C...EXPANSION COEFFICIENTS FOR CHARM SEA QUARK DISTRIBUTION.
20575  DATA ((cdo(ip,is,4,1),is=1,6),ip=1,3)/
20576  + 0.000e+00,-3.600e-02, 6.350e+00, 0.000e+00, 0.000e+00, 0.000e+00,
20577  + 1.350e-01,-2.220e-01, 3.260e+00,-3.030e+00, 1.740e+01,-1.790e+01,
20578  +-7.500e-02,-5.800e-02,-9.090e-01, 1.500e+00,-1.130e+01, 1.560e+01/
20579  DATA ((cdo(ip,is,4,2),is=1,6),ip=1,3)/ 0.000e+00,-1.200e-01,
20580  +3.510e+00, 0.000e+00, 0.000e+00, 0.000e+00, 6.700e-02,-2.330e-01,
20581  +3.660e+00,-4.740e-01, 9.500e+00,-1.660e+01,-3.100e-02,-2.300e-02,
20582  +-4.530e-01, 3.580e-01,-5.430e+00, 1.550e+01/
20583 C...EXPANSION COEFFICIENTS FOR GLUON DISTRIBUTION.
20584  DATA ((cdo(ip,is,5,1),is=1,6),ip=1,3)/
20585  + 1.560e+00, 0.000e+00, 6.000e+00, 9.000e+00, 0.000e+00, 0.000e+00,
20586  +-1.710e+00,-9.490e-01, 1.440e+00,-7.190e+00,-1.650e+01, 1.530e+01,
20587  + 6.380e-01, 3.250e-01,-1.050e+00, 2.550e-01, 1.090e+01,-1.010e+01/
20588  DATA ((cdo(ip,is,5,2),is=1,6),ip=1,3)/
20589  + 8.790e-01, 0.000e+00, 4.000e+00, 9.000e+00, 0.000e+00, 0.000e+00,
20590  +-9.710e-01,-1.160e+00, 1.230e+00,-5.640e+00,-7.540e+00,-5.960e-01,
20591  + 4.340e-01, 4.760e-01,-2.540e-01,-8.170e-01, 5.500e+00, 1.260e-01/
20592 
20593 C...THE FOLLOWING DATA LINES ARE COEFFICIENTS NEEDED IN THE
20594 C...MORFIN AND TUNG STRUCTURE FUNCTION PARAMETRIZATIONS.
20595 C...12 COEFFICIENTS EACH FOR D(VALENCE), U(VALENCE), G, U(SEA),
20596 C...D(SEA), S, C, B AND T, IN THAT ORDER.
20597 C...EXPANSION COEFFICIENTS FOR SET 1 (FIT S1).
20598  DATA (((cmt(iex,ipn,ifl,1),ifl=1,9),ipn=0,2),iex=0,3)/
20599  + 1.30, 1.64, 1.86, -0.60, -0.45, -1.10, -3.87, -6.14,-12.53,
20600  + -0.57, -0.33, -2.76, -1.68, -1.64, -1.66, 0.79, 2.65, 8.13,
20601  + -0.08, -0.10, 0.10, 0.08, 0.05, 0.13, -0.70, -1.24, -2.64,
20602  + 0.18, 0.08, -0.17, -0.19, -0.18, -0.19, -0.03, -0.10, -0.38,
20603  + 0.16, 0.14, -0.07, -0.16, -0.19, -0.09, -0.17, -0.03, 0.34,
20604  + -0.02, -0.01, 0.02, 0.04, 0.06, 0.01, 0.03, -0.02, -0.14,
20605  + 5.27, 3.74, 7.33, 9.31, 9.36, 9.07, 7.96, 6.90, 16.30,
20606  + 0.43, 0.54, -0.88, -1.17, -1.01, -1.39, 0.95, 1.52,-13.23,
20607  + 0.06, 0.03, -0.08, 0.29, 0.20, 0.47, -0.38, -0.50, 4.77,
20608  + -1.85, -2.04, -0.88, -1.45, -1.48, -1.26, 0.60, 0.80, -0.57,
20609  + 1.08, 0.88, 2.47, 1.65, 1.49, 1.96, 0.60, 1.05, 3.58,
20610  + -0.03, 0.02, -0.32, -0.20, -0.12, -0.36, 0.08, -0.14, -0.99/
20611 C...EXPANSION COEFFICIENTS FOR SET 2 (FIT B1).
20612  DATA (((cmt(iex,ipn,ifl,2),ifl=1,9),ipn=0,2),iex=0,3)/
20613  + 1.34, 1.62, 1.88, -0.99, -0.99, -0.99, -3.98, -6.28,-13.08,
20614  + -0.57, -0.33, -2.78, -1.54, -1.54, -1.54, 0.72, 2.62, 8.54,
20615  + -0.08, -0.10, 0.13, 0.10, 0.10, 0.10, -0.63, -1.18, -2.70,
20616  + 0.15, 0.11, -0.33, -0.33, -0.33, -0.33, -0.15, -0.18, -0.40,
20617  + 0.16, 0.14, 0.10, 0.03, 0.03, 0.03, -0.06, 0.02, 0.31,
20618  + -0.02, -0.01, -0.04, -0.03, -0.03, -0.03, 0.00, -0.03, -0.12,
20619  + 5.30, 3.68, 7.52, 8.53, 8.53, 8.53, 7.46, 6.56, 15.35,
20620  + 0.43, 0.53, -1.13, -1.08, -1.08, -1.08, 0.96, 1.40,-11.83,
20621  + 0.06, 0.03, 0.04, 0.39, 0.39, 0.39, -0.30, -0.38, 4.16,
20622  + -1.96, -1.94, -1.34, -1.55, -1.55, -1.55, 0.35, 0.65, -0.43,
20623  + 1.08, 0.87, 2.92, 2.02, 2.02, 2.02, 0.89, 1.13, 3.18,
20624  + -0.03, 0.02, -0.49, -0.39, -0.39, -0.39, -0.04, -0.16, -0.82/
20625 C...EXPANSION COEFFICIENTS FOR SET 3 (FIT B2).
20626  DATA (((cmt(iex,ipn,ifl,3),ifl=1,9),ipn=0,2),iex=0,3)/
20627  + 1.38, 1.64, 1.52, -0.85, -0.85, -0.85, -3.74, -6.07,-12.08,
20628  + -0.59, -0.33, -2.71, -1.43, -1.43, -1.43, 0.21, 2.33, 7.31,
20629  + -0.08, -0.10, 0.15, -0.03, -0.03, -0.03, -0.50, -1.15, -2.35,
20630  + 0.18, 0.09, -0.72, -0.82, -0.82, -0.82, -0.58, -0.52, -0.73,
20631  + 0.16, 0.14, 0.45, 0.35, 0.35, 0.35, 0.24, 0.22, 0.54,
20632  + -0.02, -0.01, -0.15, -0.09, -0.10, -0.10, -0.07, -0.07, -0.18,
20633  + 5.40, 3.74, 7.75, 9.19, 9.19, 9.19, 9.63, 8.33, 21.14,
20634  + 0.42, 0.54, -1.56, -0.92, -0.92, -0.92, -1.13, 0.28,-19.17,
20635  + 0.06, 0.03, 0.16, 0.12, 0.12, 0.12, 0.25, -0.28, 6.64,
20636  + -1.91, -2.02, -2.18, -2.76, -2.76, -2.76, -1.09, -0.52, -1.92,
20637  + 1.11, 0.88, 3.75, 2.56, 2.56, 2.56, 2.10, 1.91, 4.59,
20638  + -0.03, 0.02, -0.76, -0.40, -0.40, -0.40, -0.33, -0.31, -1.25/
20639 C...EXPANSION COEFFICIENTS FOR SET 4 (FIT E1).
20640  DATA (((cmt(iex,ipn,ifl,4),ifl=1,9),ipn=0,2),iex=0,3)/
20641  + 1.43, 1.69, 2.11, -0.84, -0.84, -0.84, -3.87, -6.09,-12.56,
20642  + -0.65, -0.33, -3.01, -1.65, -1.65, -1.65, 0.85, 2.81, 8.69,
20643  + -0.08, -0.11, 0.18, 0.12, 0.12, 0.12, -0.73, -1.34, -2.93,
20644  + 0.16, 0.11, -0.33, -0.32, -0.32, -0.32, -0.15, -0.17, -0.38,
20645  + 0.16, 0.14, 0.10, 0.02, 0.02, 0.02, -0.07, 0.01, 0.30,
20646  + -0.02, -0.01, -0.04, -0.03, -0.03, -0.03, 0.00, -0.03, -0.12,
20647  + 6.17, 3.69, 7.93, 8.96, 8.96, 8.96, 7.83, 6.75, 14.62,
20648  + 0.43, 0.54, -1.40, -1.24, -1.24, -1.24, 1.00, 1.74,-11.27,
20649  + 0.06, 0.03, 0.09, 0.45, 0.45, 0.45, -0.36, -0.56, 4.29,
20650  + -1.94, -1.99, -1.51, -1.70, -1.70, -1.70, 0.21, 0.54, -0.41,
20651  + 1.12, 0.90, 3.14, 2.15, 2.15, 2.15, 0.93, 1.15, 3.19,
20652  + -0.02, 0.02, -0.55, -0.43, -0.43, -0.43, -0.03, -0.16, -0.87/
20653 
20654 C...EULER'S BETA FUNCTION, REQUIRES ORDINARY GAMMA FUNCTION
20655  eulbet(x,y)=gamma(x)*gamma(y)/gamma(x+y)
20656 
20657 C...CONVERT LST SWITCHES TO MSPT, AND PARL PARAMETERS TO PARP
20658  mstp57=1
20659  IF(lst(15).LT.0) mstp57=0
20660  mstp51=iabs(lst(15))
20661  mstp52=lst(16)
20662  mstp58=lst(12)
20663  parp51=parl(20)
20664  parl(26)=0.
20665 
20666 C...RESET OUTPUT ARRAY.
20667  DO 10 kfl=-6,6
20668  10 xppr(kfl)=0.
20669 
20670  IF(mstp51.EQ.1.OR.mstp51.EQ.2) THEN
20671 C...PROTON STRUCTURE FUNCTIONS FROM EICHTEN, HINCHLIFFE, LANE, QUIGG.
20672 C...ALLOWED VARIABLE RANGE: 5 GEV^2 < Q^2 < 1E8 GEV^2; 1E-4 < X < 1
20673 
20674 C...DETERMINE SET, LAMBDA AND X AND T EXPANSION VARIABLES.
20675  nset=mstp51
20676  IF(nset.EQ.1) alam=0.2
20677  IF(nset.EQ.2) alam=0.29
20678  tmin=log(5./alam**2)
20679  tmax=log(1e8/alam**2)
20680  IF(mstp57.EQ.0) THEN
20681  t=tmin
20682  ELSE
20683  t=log(max(1.,q2/alam**2))
20684  ENDIF
20685  vt=max(-1.,min(1.,(2.*t-tmax-tmin)/(tmax-tmin)))
20686  nx=1
20687  IF(x.LE.0.1) nx=2
20688  IF(nx.EQ.1) vx=(2.*x-1.1)/0.9
20689  IF(nx.EQ.2) vx=max(-1.,(2.*log(x)+11.51293)/6.90776)
20690  cxs=1.
20691  IF(x.LT.1e-4.AND.abs(parp51-1.).GT.0.01) cxs=
20692  + (1e-4/x)**(parp51-1.)
20693 
20694 C...CHEBYSHEV POLYNOMIALS FOR X AND T EXPANSION.
20695  tx(1)=1.
20696  tx(2)=vx
20697  tx(3)=2.*vx**2-1.
20698  tx(4)=4.*vx**3-3.*vx
20699  tx(5)=8.*vx**4-8.*vx**2+1.
20700  tx(6)=16.*vx**5-20.*vx**3+5.*vx
20701  tt(1)=1.
20702  tt(2)=vt
20703  tt(3)=2.*vt**2-1.
20704  tt(4)=4.*vt**3-3.*vt
20705  tt(5)=8.*vt**4-8.*vt**2+1.
20706  tt(6)=16.*vt**5-20.*vt**3+5.*vt
20707 
20708 C...CALCULATE STRUCTURE FUNCTIONS.
20709  DO 30 kfl=1,6
20710  xqsum=0.
20711  DO 20 it=1,6
20712  DO 20 ix=1,6
20713  20 xqsum=xqsum+cehlq(ix,it,nx,kfl,nset)*tx(ix)*tt(it)
20714  30 xq(kfl)=xqsum*(1.-x)**nehlq(kfl,nset)*cxs
20715 
20716 C...PUT INTO OUTPUT ARRAY.
20717  xppr(0)=xq(4)
20718  xppr(1)=xq(2)+xq(3)
20719  xppr(2)=xq(1)+xq(3)
20720  xppr(3)=xq(5)
20721  xppr(4)=xq(6)
20722  xppr(-1)=xq(3)
20723  xppr(-2)=xq(3)
20724  xppr(-3)=xq(5)
20725  xppr(-4)=xq(6)
20726 
20727 C...SPECIAL EXPANSION FOR BOTTOM (THRESHOLD EFFECTS).
20728  IF(mstp58.GE.5) THEN
20729  IF(nset.EQ.1) tmin=8.1905
20730  IF(nset.EQ.2) tmin=7.4474
20731  IF(t.GT.tmin) THEN
20732  vt=max(-1.,min(1.,(2.*t-tmax-tmin)/(tmax-tmin)))
20733  tt(1)=1.
20734  tt(2)=vt
20735  tt(3)=2.*vt**2-1.
20736  tt(4)=4.*vt**3-3.*vt
20737  tt(5)=8.*vt**4-8.*vt**2+1.
20738  tt(6)=16.*vt**5-20.*vt**3+5.*vt
20739  xqsum=0.
20740  DO 40 it=1,6
20741  DO 40 ix=1,6
20742  40 xqsum=xqsum+cehlq(ix,it,nx,7,nset)*tx(ix)*tt(it)
20743  xppr(5)=xqsum*(1.-x)**nehlq(7,nset)*cxs
20744  xppr(-5)=xppr(5)
20745  ENDIF
20746  ENDIF
20747 
20748 C...SPECIAL EXPANSION FOR TOP (THRESHOLD EFFECTS).
20749  IF(mstp58.GE.6) THEN
20750  IF(nset.EQ.1) tmin=11.5528
20751  IF(nset.EQ.2) tmin=10.8097
20752  tmin=tmin+2.*log(pmas(6,1)/30.)
20753  tmax=tmax+2.*log(pmas(6,1)/30.)
20754  IF(t.GT.tmin) THEN
20755  vt=max(-1.,min(1.,(2.*t-tmax-tmin)/(tmax-tmin)))
20756  tt(1)=1.
20757  tt(2)=vt
20758  tt(3)=2.*vt**2-1.
20759  tt(4)=4.*vt**3-3.*vt
20760  tt(5)=8.*vt**4-8.*vt**2+1.
20761  tt(6)=16.*vt**5-20.*vt**3+5.*vt
20762  xqsum=0.
20763  DO 50 it=1,6
20764  DO 50 ix=1,6
20765  50 xqsum=xqsum+cehlq(ix,it,nx,8,nset)*tx(ix)*tt(it)
20766  xppr(6)=xqsum*(1.-x)**nehlq(8,nset)*cxs
20767  xppr(-6)=xppr(6)
20768  ENDIF
20769  ENDIF
20770 
20771  ELSEIF(mstp51.EQ.3.OR.mstp51.EQ.4) THEN
20772 C...PROTON STRUCTURE FUNCTIONS FROM DUKE, OWENS.
20773 C...ALLOWED VARIABLE RANGE: 4 GEV^2 < Q^2 < APPROX 1E6 GEV^2.
20774 
20775 C...DETERMINE SET, LAMBDA AND S EXPANSION PARAMETER.
20776  nset=mstp51-2
20777  IF(nset.EQ.1) alam=0.2
20778  IF(nset.EQ.2) alam=0.4
20779  IF(mstp57.LE.0) THEN
20780  sd=0.
20781  ELSE
20782  q2in=min(1e6,max(4.,q2))
20783  sd=log(log(q2in/alam**2)/log(4./alam**2))
20784  ENDIF
20785 
20786 C...CALCULATE STRUCTURE FUNCTIONS.
20787  DO 70 kfl=1,5
20788  DO 60 is=1,6
20789  60 ts(is)=cdo(1,is,kfl,nset)+cdo(2,is,kfl,nset)*sd+ cdo(3,is,
20790  + kfl,nset)*sd**2
20791  IF(kfl.LE.2) THEN
20792  xq(kfl)=x**ts(1)*(1.-x)**ts(2)*(1.+ts(3)*x)/(eulbet(ts(1),
20793  + ts(2)+1.)*(1.+ts(3)*ts(1)/(ts(1)+ts(2)+1.)))
20794  ELSE
20795  xq(kfl)=ts(1)*x**ts(2)*(1.-x)**ts(3)*(1.+ts(4)*x+ts(5)*x**
20796  + 2+ ts(6)*x**3)
20797  ENDIF
20798  70 CONTINUE
20799 
20800 C...PUT INTO OUTPUT ARRAYS.
20801  xppr(0)=xq(5)
20802  xppr(1)=xq(2)+xq(3)/6.
20803  xppr(2)=3.*xq(1)-xq(2)+xq(3)/6.
20804  xppr(3)=xq(3)/6.
20805  xppr(4)=xq(4)
20806  xppr(-1)=xq(3)/6.
20807  xppr(-2)=xq(3)/6.
20808  xppr(-3)=xq(3)/6.
20809  xppr(-4)=xq(4)
20810 
20811  ELSEIF(mstp51.GE.5.AND.mstp51.LE.8) THEN
20812 C...PROTON STRUCTURE FUNCTIONS FROM MORFIN AND TUNG.
20813 C...ALLOWED VARIABLE RANGE: 4 GEV^2 < Q^2 < 1E8 GEV^2, 0 < X < 1.
20814 
20815 C...CALCULATE EXPANSION PARAMETERS.
20816  nset=mstp51-4
20817  IF(nset.EQ.1) alam=0.187
20818  IF(nset.EQ.2) alam=0.212
20819  IF(nset.EQ.3) alam=0.191
20820  IF(nset.EQ.4) alam=0.155
20821  IF(mstp57.EQ.0) THEN
20822  sd=0.
20823  ELSE
20824  sd=log(log(max(4.,q2)/alam**2)/log(4./alam**2))
20825  ENDIF
20826  xl=log(max(1e-10,x))
20827  x1l=log(max(1e-10,1.-x))
20828  xll=log(max(1e-10,log(1.+1./max(1e-10,x))))
20829 
20830 C...CALCULATE STRUCTURE FUNCTIONS UP TO B.
20831  DO 90 ip=1,8
20832  DO 80 iex=0,3
20833  80 exmt(iex)=cmt(iex,0,ip,nset)+cmt(iex,1,ip,nset)*sd+ cmt(iex,
20834  + 2,ip,nset)*sd**2
20835  exmts=exmt(0)+exmt(1)*xl+exmt(2)*x1l+exmt(3)*xll
20836  IF(exmts.LT.-50.) THEN
20837  xq(ip)=0.
20838  ELSE
20839  xq(ip)=exp(exmts)
20840  ENDIF
20841  90 CONTINUE
20842  IF(q2.LE.2.25) xq(7)=0.
20843  IF(q2.LE.25.0) xq(8)=0.
20844 
20845 C...CALCULATE T STRUCTURE FUNCTION, SHIFTING EFFECTIVE Q SCALE FOR
20846 C...NONDEFAULT T MASS, Q_ACTUAL = Q_NOMINAL * M_T_NOMINAL/M_T_ACTUAL.
20847  IF(mstp57.EQ.0.OR.q2.LE.pmas(6,1)**2) THEN
20848  xq(9)=0.
20849  ELSE
20850  sd=log(log(max(4.,q2)/alam**2*(100./pmas(6,1))**2)/
20851  + log(4./alam**2))
20852  DO 100 iex=0,3
20853  100 exmt(iex)=cmt(iex,0,9,nset)+cmt(iex,1,9,nset)*sd+
20854  + cmt(iex,2,9,nset)*sd**2
20855  exmts=exmt(0)+exmt(1)*xl+exmt(2)*x1l+exmt(3)*xll
20856  IF(exmts.LT.-50.) THEN
20857  xq(9)=0.
20858  ELSE
20859  xq(9)=exp(exmts)
20860  ENDIF
20861  ENDIF
20862 
20863 C...PUT INTO OUTPUT ARRAY.
20864  xppr(0)=xq(3)
20865  xppr(1)=xq(1)+xq(5)
20866  xppr(-1)=xq(5)
20867  xppr(2)=xq(2)+xq(4)
20868  xppr(-2)=xq(4)
20869  xppr(3)=xq(6)
20870  xppr(-3)=xq(6)
20871  xppr(4)=xq(7)
20872  xppr(-4)=xq(7)
20873  xppr(5)=xq(8)
20874  xppr(-5)=xq(8)
20875  xppr(6)=xq(9)
20876  xppr(-6)=xq(9)
20877 
20878  ELSEIF(mstp51.EQ.9) THEN
20879 C...LOWEST ORDER PARAMETRIZATION OF GLUCK, REYA, VOGT.
20880 C...ALLOWED VARIABLE RANGE: 0.2 GEV^2 < Q2 < 1E6 GEV^2; 1E-4 < X < 1;
20881 C...EXTENDED TO 0.2 GEV^2 < Q2 < 1E8 GEV^2; 1E-6 < X < 1
20882 C...AFTER CONSULTATION WITH THE AUTHORS.
20883 
20884 C...DETERMINE S AND X.
20885  alam=0.25
20886  IF(mstp57.EQ.0) THEN
20887  sd=0.
20888  ELSE
20889  q2in=min(1e8,max(0.2,q2))
20890  sd=log(log(q2in/alam**2)/log(0.2/alam**2))
20891  ENDIF
20892  xc=max(1e-6,x)
20893  xl=-log(xc)
20894 
20895 C...CALCULATE STRUCTURE FUNCTIONS.
20896  xq(1)=(0.794+0.312*sd)*xc**(0.427-0.011*sd)*
20897  + (1.+(6.887-2.227*sd)*xc+(-11.083+2.136*sd)*xc**2+
20898  + (3.900+1.079*sd)*xc**3)*(1.-xc)**(1.037+1.077*sd)
20899  xq(2)=(0.486+0.139*sd)*xc**(0.434-0.018*sd)*
20900  + (1.+(7.716-2.684*sd)*xc+(-12.768+3.122*sd)*xc**2+
20901  + (4.564+0.470*sd)*xc**3)*(1.-xc)**(1.889+1.129*sd)
20902  xq(3)=(xc**(0.415+0.186*sd)*((0.786+0.942*sd)+
20903  + (5.256-5.810*sd)*xc+(-4.599+5.842*sd)*xc**2)+sd**0.592*
20904  + exp(-(0.398+2.135*sd)+sqrt(3.779*sd**1.250*xl)))*
20905  + (1.-xc)**(1.622+1.980*sd)
20906  xq(4)=sd**0.448*(1.-xc)**(5.540-0.445*sd)*
20907  + exp(-(4.668+1.230*sd)+sqrt((13.173-1.361*sd)*sd**0.442*xl))/
20908  + xl**(3.181-0.862*sd)
20909  xq(5)=0.
20910  IF(sd.GT.1.125) xq(5)=(sd-1.125)*(1.-xc)**(2.038+1.022*sd)*
20911  + exp(-(4.290+1.569*sd)+sqrt((2.982+1.452*sd)*sd**0.5*xl))
20912  xq(6)=0.
20913  IF(sd.GT.1.603) xq(6)=(sd-1.603)*(1.-xc)**(2.230+1.052*sd)*
20914  + exp(-(4.566+1.559*sd)+sqrt((4.147+1.268*sd)*sd**0.5*xl))
20915 
20916 C...PUT INTO OUTPUT ARRAY - SPECIAL FACTOR FOR SMALL X.
20917  cxs=1.
20918  IF(x.LT.1e-6.AND.abs(parp51-1.).GT.0.01)
20919  + cxs=(1e-6/x)**(parp51-1.)
20920  xppr(0)=cxs*xq(3)
20921  xppr(1)=cxs*(xq(2)+xq(4))
20922  xppr(-1)=cxs*xq(4)
20923  xppr(2)=cxs*(xq(1)+xq(4))
20924  xppr(-2)=cxs*xq(4)
20925  xppr(3)=cxs*xq(4)
20926  xppr(-3)=cxs*xq(4)
20927  xppr(4)=cxs*xq(5)
20928  xppr(-4)=cxs*xq(5)
20929  xppr(5)=cxs*xq(6)
20930  xppr(-5)=cxs*xq(6)
20931 
20932  ELSEIF(mstp51.EQ.10) THEN
20933 C...HIGHER ORDER PARAMETRIZATION OF GLUCK, REYA, VOGT.
20934 C...ALLOWED VARIABLE RANGE: 0.2 GEV^2 < Q2 < 1E6 GEV^2; 1E-4 < X < 1;
20935 C...EXTENDED TO 0.2 GEV^2 < Q2 < 1E8 GEV^2; 1E-6 < X < 1
20936 C...AFTER CONSULTATION WITH THE AUTHORS.
20937 
20938 C...DETERMINE S AND X.
20939  alam=0.20
20940  IF(mstp57.EQ.0) THEN
20941  sd=0.
20942  ELSE
20943  q2in=min(1e8,max(0.2,q2))
20944  sd=log(log(q2in/alam**2)/log(0.2/alam**2))
20945  ENDIF
20946  sd2=sd**2
20947  xc=max(1e-6,x)
20948  xl=-log(xc)
20949 
20950 C...CALCULATE STRUCTURE FUNCTIONS.
20951  xq(1)=(1.364+0.989*sd-0.236*sd2)*xc**(0.593-0.048*sd)*
20952  + (1.+(8.912-6.092*sd+0.852*sd2)*xc+(-16.737+7.039*sd)*xc**2+
20953  + (10.275+0.806*sd-2.000*sd2)*xc**3)*
20954  + (1.-xc)**(2.043+1.408*sd-0.283*sd2)
20955  xq(2)=(0.835+0.527*sd-0.144*sd2)*xc**(0.600-0.054*sd)*
20956  + (1.+(10.245-7.821*sd+1.325*sd2)*xc+(-19.511+10.940*sd-
20957  + 1.133*sd2)*xc**2+(12.836-2.570*sd-1.041*sd2)*xc**3)*
20958  + (1.-xc)**(3.083+1.382*sd-0.276*sd2)
20959  xq(3)=(xc**(0.321-0.135*sd)*((10.51-2.299*sd)+
20960  + (-17.28+0.755*sd)*xc+(8.242+2.543*sd)*xc**2)*
20961  + xl**(-2.023-0.103*sd)+sd**1.044*
20962  + exp(-(-1.178+2.792*sd)+sqrt(2.318*sd**1.673*xl)))*
20963  + (1.-xc)**(3.720+2.337*sd-0.199*sd2)
20964  xq(4)=sd**0.761*(1.+(6.078-2.065*sd)*xc)*(1.-xc)**(4.654+
20965  + 0.603*sd-0.326*sd2)*exp(-(4.231+1.036*sd)+sqrt(3.419*sd**0.316*
20966  + xl))/xl**(0.897-0.618*sd)
20967  xq(5)=0.
20968  IF(sd.GT.0.918) xq(5)=(sd-0.918)*(1.-xc)**(3.328+0.859*sd)*
20969  + exp(-(3.837+1.504*sd)+sqrt((2.150+1.291*sd)*sd**0.5*xl))
20970  xq(6)=0.
20971  IF(sd.GT.1.353) xq(6)=(sd-1.353)*(1.-xc)**(3.382+0.909*sd)*
20972  + exp(-(4.130+1.486*sd)+sqrt((2.895+1.240*sd)*sd**0.5*xl))
20973 
20974 C...PUT INTO OUTPUT ARRAY - SPECIAL FACTOR FOR SMALL X.
20975  cxs=1.
20976  IF(x.LT.1e-6.AND.abs(parp51-1.).GT.0.01)
20977  + cxs=(1e-6/x)**(parp51-1.)
20978  xppr(0)=cxs*xq(3)
20979  xppr(1)=cxs*(xq(2)+xq(4))
20980  xppr(-1)=cxs*xq(4)
20981  xppr(2)=cxs*(xq(1)+xq(4))
20982  xppr(-2)=cxs*xq(4)
20983  xppr(3)=cxs*xq(4)
20984  xppr(-3)=cxs*xq(4)
20985  xppr(4)=cxs*xq(5)
20986  xppr(-4)=cxs*xq(5)
20987  xppr(5)=cxs*xq(6)
20988  xppr(-5)=cxs*xq(6)
20989  ENDIF
20990  parl(26)=alam
20991 
20992  RETURN
20993  END
20994 *CMZ : 1.01/50 23/05/96 12.34.50 by Piero Zucchelli
20995 *-- Author : Piero Zucchelli 20/03/96
20996 
20997  SUBROUTINE ranmar(RVEC,ISEQ)
20998  dimension rvec(*)
20999  CALL ranlux(rvec,iseq)
21000  RETURN
21001  END
21002 *CMZ : 1.02/11 14/01/97 23.32.59 by P. Zucchelli
21003 *CMZ : 1.02/04 13/01/97 14.45.27 by P. Zucchelli
21004 *CMZ : 1.01/51 13/06/96 18.29.39 by Piero Zucchelli
21005 *CMZ : 1.01/50 26/04/96 14.52.50 by Piero Zucchelli
21006 *CMZ : 1.01/45 08/01/96 09.37.30 by Piero Zucchelli
21007 *CMZ : 1.01/43 15/12/95 17.58.41 by Piero Zucchelli
21008 *CMZ : 1.01/41 14/12/95 14.48.28 by Piero Zucchelli
21009 *CMZ : 1.01/40 12/12/95 12.30.14 by Piero Zucchelli
21010 *CMZ : 1.01/39 02/11/95 18.35.07 by Piero Zucchelli
21011 *CMZ : 1.01/37 21/09/95 11.21.48 BY PIERO ZUCCHELLI
21012 *CMZ : 1.01/36 26/07/95 18.29.05 BY PIERO ZUCCHELLI
21013 *CMZ : 1.01/33 03/07/95 17.33.30 BY PIERO ZUCCHELLI
21014 *CMZ : 1.01/27 02/06/95 14.58.52 BY PIERO ZUCCHELLI
21015 *CMZ : 1.01/08 05/03/95 11.35.13 BY PIERO ZUCCHELLI
21016 *CMZ : 1.01/01 14/09/94 16.25.32 BY PIERO ZUCCHELLI
21017 *CMZ : 1.01/00 01/09/94 17.36.14 BY PIERO ZUCCHELLI
21018 *-- AUTHOR : PIERO ZUCCHELLI 01/09/94
21019  SUBROUTINE readffky
21020 *KEEP,KEYS.
21021  common/cfread/space(5000)
21022  common/mykeys/ievar,if5cc,ineut,iinte,iferm,iflat,icoun,
21023  & refix,imudo,ikat1,ikat2,ikat3,ikat4,ikat5,ikat6,
21024  & inevt,ijak1,ijak2,iitdk,rptau,rxk0d,ntgr,idimuon,iglu,
21025  & iqden,lome(2),ifiles,iccha,iseed,idsubs,ionem,ehac,ipsel,
21026  & ihist
21027 
21028 
21029 *KEND.
21030  CALL ffinit(3000)
21031 
21032  CALL ffkey('PSEL',ipsel,1,'INTEGER')
21033  CALL ffkey('SEED',iseed,1,'INTEGER')
21034  CALL ffkey('IGLU',iglu,1,'INTEGER')
21035  CALL ffkey('EVAR',ievar,1,'INTEGER')
21036  CALL ffkey('F5CC',if5cc,1,'INTEGER')
21037  CALL ffkey('NEUT',ineut,1,'INTEGER')
21038  CALL ffkey('INTE',iinte,1,'INTEGER')
21039  CALL ffkey('FERM',iferm,1,'INTEGER')
21040  CALL ffkey('FLAT',iflat,1,'INTEGER')
21041  CALL ffkey('COUN',icoun,1,'INTEGER')
21042  CALL ffkey('HIST',ihist,1,'INTEGER')
21043  CALL ffkey('EFIX',refix,1,'REAL')
21044  CALL ffkey('QDEN',iqden,1,'INTEGER')
21045  CALL ffkey('MUDO',imudo,1,'INTEGER')
21046  CALL ffkey('NGTR',ntgr,1,'INTEGER')
21047  CALL ffkey('DIMU',idimuon,1,'INTEGER')
21048  CALL ffkey('CCHA',iccha,1,'INTEGER')
21049  CALL ffkey('LOME',lome,2,'INTEGER')
21050  CALL ffkey('FILE',ifiles,1,'INTEGER')
21051  CALL ffkey('KAT1',ikat1,1,'INTEGER')
21052  CALL ffkey('KAT2',ikat2,1,'INTEGER')
21053  CALL ffkey('KAT3',ikat3,1,'INTEGER')
21054  CALL ffkey('KAT4',ikat4,1,'INTEGER')
21055  CALL ffkey('KAT5',ikat5,1,'INTEGER')
21056  CALL ffkey('KAT6',ikat6,1,'INTEGER')
21057  CALL ffkey('NEVT',inevt,1,'INTEGER')
21058  CALL ffkey('JAK1',ijak1,1,'INTEGER')
21059  CALL ffkey('JAK2',ijak2,1,'INTEGER')
21060  CALL ffkey('ITDK',iitdk,1,'INTEGER')
21061  CALL ffkey('DSUBS',idsubs,1,'INTEGER')
21062  CALL ffkey('PTAU',rptau,1,'REAL')
21063  CALL ffkey('XK0D',rxk0d,1,'REAL')
21064  CALL ffkey('EHAC',ehac,1,'REAL')
21065 
21066  ninp=17
21067 C OPEN(NINP,FILE="./jetta.crd",STATUS='OLD')
21068  OPEN(ninp,file="./jetta.crd",status='UNKNOWN')
21069  CALL ffset('LINP',ninp)
21070  CALL ffgo
21071  CLOSE(ninp)
21072 
21073  IF (ntgr.EQ.0) ntgr=1
21074  IF (iitdk.EQ.0) iitdk=1
21075  IF (rxk0d.EQ.0.) rxk0d=0.001
21076 
21077 
21078  RETURN
21079  END
21080 *CMZ : 1.02/03 13/01/97 13.46.08 by P. Zucchelli
21081 *CMZ : 1.01/50 23/05/96 10.19.16 by Piero Zucchelli
21082 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
21083 *-- AUTHOR :
21084  SUBROUTINE reslu
21085 C ****************
21086 C INITIALIZE LUND COMMON
21087  parameter(nmxhep=2000)
21088 *KEEP,HEPEVT.
21089  DOUBLE PRECISION phep,vhep
21090  common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),
21091  &jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)
21092  SAVE /hepevt/
21093 
21094 *KEND.
21095  nhep=0
21096  END
21097 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
21098 *-- AUTHOR :
21099 C **********************************************************************
21100 
21101  DOUBLE PRECISION FUNCTION riwfun(V)
21102  DOUBLE PRECISION v(2)
21103  COMMON /leptou/ cut(14),lst(40),parl(30),x,y,w2,q2,u
21104  COMMON /lintrl/ psave(3,4,5),ksave(4),xmin,xmax,ymin,ymax,
21105  &q2min,q2max,w2min,w2max,ilep,inu,ig,iz
21106  DATA v2min,v2max/2*0./
21107 
21108  riwfun=0.d0
21109  v1min=xmin
21110  v1max=xmax
21111  IF(lst(31).EQ.1) THEN
21112  v2min=q2min
21113  v2max=q2max
21114  ELSEIF(lst(31).EQ.2) THEN
21115  v2min=ymin
21116  v2max=ymax
21117  ELSEIF(lst(31).EQ.3) THEN
21118  v2min=w2min
21119  v2max=w2max
21120  ENDIF
21121  v1=v1min+v(1)*(v1max-v1min)
21122  v2=v2min+v(2)*(v2max-v2min)
21123  riwfun=dcross(v1,v2)*(v1max-v1min)*(v2max-v2min)
21124 
21125  RETURN
21126  END
21127 *CMZ : 1.01/14 14/05/95 11.26.26 BY PIERO ZUCCHELLI
21128 *CMZ : 1.00/00 04/07/94 15.02.27 BY PIERO ZUCCHELLI
21129 *-- AUTHOR :
21130 C **********************************************************************
21131 
21132  SUBROUTINE riwibd
21133 C BLOCK DATA SUBSTITUTE FROM RIWIAD
21134  IMPLICIT REAL*8(a-h,o-z)
21135  common/store/xa(11),xb(11),xc(11),xd(11),ma(11),mb(11),mc(11)
21136  common/store1/r(10000),lr
21137  common/option/iprriw,iconv,ireset
21138  common/random/nshots
21139  common/intern/factor,alfa,beta,gamma,delta,level,nmin
21140  COMMON /lpflag/ lst3
21141  DATA init/0/
21142  IF(init.EQ.1) RETURN
21143  init=1
21144  ma(1)=0
21145  lr=10000
21146  iconv=1
21147  ireset=0
21148  nshots=2
21149  factor=1.65
21150  level=90
21151  alfa=0.3
21152  beta=0.3
21153  gamma=0.3
21154  delta=.7
21155  nmin=2
21156 C...PRINT FLAG TO BE CHANGED HERE.
21157  iprriw=0
21158  IF(lst3.GE.4) WRITE(6,10000) iprriw
21159  RETURN
21160 10000 FORMAT(5x,'RIWIAD PRINT FLAG CHANGED: IPRRIW =',i5)
21161  END
21162 *CMZ : 1.01/50 23/05/96 12.34.50 by Piero Zucchelli
21163 *-- Author : Piero Zucchelli 20/03/96
21164 
21165  REAL*4 FUNCTION rlu(IDUMMY)
21166  CALL ranlux(rtim,1)
21167  rlu=rtim
21168  RETURN
21169  END
21170 *CMZ : 1.01/50 23/05/96 12.34.50 by Piero Zucchelli
21171 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
21172 *-- AUTHOR :
21173  SUBROUTINE rotod1(PH1,PVEC,QVEC)
21174 C ----------------------------------------------------------------------
21175 C
21176 C USED BY : KORALZ
21177 C ----------------------------------------------------------------------
21178  IMPLICIT DOUBLE PRECISION (a-h,o-z)
21179  dimension pvec(4),qvec(4),rvec(4)
21180 C
21181  phi=ph1
21182  cs=cos(phi)
21183  sn=sin(phi)
21184  DO 10 i=1,4
21185  10 rvec(i)=pvec(i)
21186  qvec(1)=rvec(1)
21187  qvec(2)= cs*rvec(2)-sn*rvec(3)
21188  qvec(3)= sn*rvec(2)+cs*rvec(3)
21189  qvec(4)=rvec(4)
21190  RETURN
21191  END
21192 *-- Author : Piero Zucchelli 20/03/96
21193 
21194  REAL*4 FUNCTION rndmm(IDUMMY)
21195  CALL ranlux(rtim,1)
21196  rndmm=rtim
21197  RETURN
21198  END
21199 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
21200 *-- AUTHOR :
21201  SUBROUTINE rotod2(PH1,PVEC,QVEC)
21202 C ----------------------------------------------------------------------
21203 C
21204 C USED BY : KORALZ RADKOR
21205 C ----------------------------------------------------------------------
21206  IMPLICIT DOUBLE PRECISION (a-h,o-z)
21207  dimension pvec(4),qvec(4),rvec(4)
21208 C
21209  phi=ph1
21210  cs=cos(phi)
21211  sn=sin(phi)
21212  DO 10 i=1,4
21213  10 rvec(i)=pvec(i)
21214  qvec(1)= cs*rvec(1)+sn*rvec(3)
21215  qvec(2)=rvec(2)
21216  qvec(3)=-sn*rvec(1)+cs*rvec(3)
21217  qvec(4)=rvec(4)
21218  RETURN
21219  END
21220 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
21221 *-- AUTHOR :
21222  SUBROUTINE rotod3(PH1,PVEC,QVEC)
21223 C ----------------------------------------------------------------------
21224 C
21225 C USED BY : KORALZ RADKOR
21226 C ----------------------------------------------------------------------
21227  IMPLICIT DOUBLE PRECISION (a-h,o-z)
21228 C
21229  dimension pvec(4),qvec(4),rvec(4)
21230  phi=ph1
21231  cs=cos(phi)
21232  sn=sin(phi)
21233  DO 10 i=1,4
21234  10 rvec(i)=pvec(i)
21235  qvec(1)= cs*rvec(1)-sn*rvec(2)
21236  qvec(2)= sn*rvec(1)+cs*rvec(2)
21237  qvec(3)=rvec(3)
21238  qvec(4)=rvec(4)
21239  END
21240 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
21241 *-- AUTHOR :
21242  SUBROUTINE rotor1(PH1,PVEC,QVEC)
21243 C ----------------------------------------------------------------------
21244 C
21245 C CALLED BY :
21246 C ----------------------------------------------------------------------
21247  REAL*4 pvec(4),qvec(4),rvec(4)
21248 C
21249  phi=ph1
21250  cs=cos(phi)
21251  sn=sin(phi)
21252  DO 10 i=1,4
21253  10 rvec(i)=pvec(i)
21254  qvec(1)=rvec(1)
21255  qvec(2)= cs*rvec(2)-sn*rvec(3)
21256  qvec(3)= sn*rvec(2)+cs*rvec(3)
21257  qvec(4)=rvec(4)
21258  END
21259 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
21260 *-- AUTHOR :
21261  SUBROUTINE rotor2(PH1,PVEC,QVEC)
21262 C ----------------------------------------------------------------------
21263 C
21264 C USED BY : TAUOLA
21265 C ----------------------------------------------------------------------
21266  IMPLICIT REAL*4(a-h,o-z)
21267  REAL*4 pvec(4),qvec(4),rvec(4)
21268 C
21269  phi=ph1
21270  cs=cos(phi)
21271  sn=sin(phi)
21272  DO 10 i=1,4
21273  10 rvec(i)=pvec(i)
21274  qvec(1)= cs*rvec(1)+sn*rvec(3)
21275  qvec(2)=rvec(2)
21276  qvec(3)=-sn*rvec(1)+cs*rvec(3)
21277  qvec(4)=rvec(4)
21278  END
21279 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
21280 *-- AUTHOR :
21281  SUBROUTINE rotor3(PHI,PVEC,QVEC)
21282 C ----------------------------------------------------------------------
21283 C
21284 C USED BY : TAUOLA
21285 C ----------------------------------------------------------------------
21286  REAL*4 pvec(4),qvec(4),rvec(4)
21287 C
21288  cs=cos(phi)
21289  sn=sin(phi)
21290  DO 10 i=1,4
21291  10 rvec(i)=pvec(i)
21292  qvec(1)= cs*rvec(1)-sn*rvec(2)
21293  qvec(2)= sn*rvec(1)+cs*rvec(2)
21294  qvec(3)=rvec(3)
21295  qvec(4)=rvec(4)
21296  END
21297 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
21298 *-- AUTHOR :
21299  SUBROUTINE rotpol(THET,PHI,PP)
21300 C ----------------------------------------------------------------------
21301 C
21302 C CALLED BY : DADMAA,DPHSAA
21303 C ----------------------------------------------------------------------
21304  REAL pp(4)
21305 C
21306  CALL rotor2(thet,pp,pp)
21307  CALL rotor3( phi,pp,pp)
21308  RETURN
21309  END
21310 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
21311 *-- AUTHOR :
21312  SUBROUTINE rotpox(THET,PHI,PP)
21313  IMPLICIT REAL*8 (a-h,o-z)
21314 C ----------------------------------------------------------------------
21315 C
21316 C ----------------------------------------------------------------------
21317  dimension pp(4)
21318 C
21319  CALL rotod2(thet,pp,pp)
21320  CALL rotod3( phi,pp,pp)
21321  RETURN
21322  END
21323 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
21324 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
21325 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
21326 *-- AUTHOR :
21327  FUNCTION sigee(Q2,JNP)
21328 C ----------------------------------------------------------------------
21329 C E+E- CROSS SECTION IN THE (1.GEV2,AMTAU**2) REGION
21330 C NORMALISED TO SIG0 = 4/3 PI ALFA2
21331 C USED IN MATRIX ELEMENT FOR MULTIPION TAU DECAYS
21332 C CF YS.TSAI PHYS.REV D4 ,2821(1971)
21333 C F.GILMAN ET AL PHYS.REV D17,1846(1978)
21334 C C.KIESLING, TO BE PUB. IN HIGH ENERGY E+E- PHYSICS (1988)
21335 C DATSIG(*,1) = E+E- -> PI+PI-2PI0
21336 C DATSIG(*,2) = E+E- -> 2PI+2PI-
21337 C DATSIG(*,3) = 5-PION CONTRIBUTION (A LA TN.PHAM ET AL)
21338 C (PHYS LETT 78B,623(1978)
21339 C DATSIG(*,5) = E+E- -> 6PI
21340 C
21341 C 4- AND 6-PION CROSS SECTIONS FROM DATA
21342 C 5-PION CONTRIBUTION RELATED TO 4-PION CROSS SECTION
21343 C
21344 C CALLED BY DPHNPI
21345 C ----------------------------------------------------------------------
21346  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
21347  + ,ampiz,ampi,amro,gamro,ama1,gama1
21348  + ,amk,amkz,amkst,gamkst
21349 C
21350  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
21351  + ,ampiz,ampi,amro,gamro,ama1,gama1
21352  + ,amk,amkz,amkst,gamkst
21353  REAL*4 datsig(17,6)
21354 C
21355  DATA datsig/
21356  + 7.40,12.00,16.15,21.25,24.90,29.55,34.15,37.40,37.85,37.40,
21357  + 36.00,33.25,30.50,27.70,24.50,21.25,18.90,
21358  + 1.24, 2.50, 3.70, 5.40, 7.45,10.75,14.50,18.20,22.30,28.90,
21359  + 29.35,25.60,22.30,18.60,14.05,11.60, 9.10,
21360  + 17*.0,
21361  + 17*.0,
21362  + 9*.0,.65,1.25,2.20,3.15,5.00,5.75,7.80,8.25,
21363  + 17*.0/
21364  DATA sig0 / 86.8 /
21365  DATA pi /3.141592653589793238462643/
21366  DATA init / 0 /
21367 C
21368  sigee = 0.
21369  jnpi=jnp
21370  IF(jnp.EQ.4) jnpi=3
21371  IF(jnp.EQ.3) jnpi=4
21372  IF(init.EQ.0) THEN
21373  init=1
21374  ampi2=ampi**2
21375  fpi = .943*ampi
21376  DO 30 i=1,17
21377  datsig(i,2) = datsig(i,2)/2.
21378  datsig(i,1) = datsig(i,1) + datsig(i,2)
21379  s = 1.025+(i-1)*.05
21380  fact=0.
21381  s2=s**2
21382  DO 10 j=1,17
21383  t= 1.025+(j-1)*.05
21384  IF(t . gt. s-ampi ) go to 20
21385  t2=t**2
21386  fact=(t2/s2)**2*sqrt((s2-t2-ampi2)**2-4.*t2*ampi2)/s2 *2.*
21387  + t*.05
21388  fact = fact * (datsig(j,1)+datsig(j+1,1))
21389  10 datsig(i,3) = datsig(i,3) + fact
21390  20 datsig(i,3) = datsig(i,3) /(2*pi*fpi)**2
21391  datsig(i,4) = datsig(i,3)
21392  datsig(i,6) = datsig(i,5)
21393  30 CONTINUE
21394 C WRITE(6,1000) DATSIG
21395 10000 FORMAT(///1x,' EE SIGMA USED IN MULTIPI DECAYS'/
21396  + (17f7.2/))
21397  ENDIF
21398  q=sqrt(q2)
21399  qmin=1.
21400  IF(q.LT.qmin) THEN
21401  sigee=datsig(1,jnpi)+
21402  + (datsig(2,jnpi)-datsig(1,jnpi))*(q-1.)/.05
21403  ELSEIF(q.LT.1.8) THEN
21404  DO 40 i=1,16
21405  qmax = qmin + .05
21406  IF(q.LT.qmax) go to 50
21407  qmin = qmin + .05
21408  40 CONTINUE
21409  50 sigee=datsig(i,jnpi)+
21410  + (datsig(i+1,jnpi)-datsig(i,jnpi)) * (q-qmin)/.05
21411  ELSEIF(q.GT.1.8) THEN
21412  sigee=datsig(17,jnpi)+
21413  + (datsig(17,jnpi)-datsig(16,jnpi)) * (q-1.8)/.05
21414  ENDIF
21415  IF(sigee.LT..0) sigee=0.
21416 C
21417  sigee = sigee/(6.*pi**2*sig0)
21418 C
21419  RETURN
21420  END
21421 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
21422 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
21423 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
21424 *-- AUTHOR :
21425  FUNCTION sigold(Q2,JNPI)
21426 C ----------------------------------------------------------------------
21427 C E+E- CROSS SECTION IN THE (1.GEV2,AMTAU**2) REGION
21428 C NORMALISED TO SIG0 = 4/3 PI ALFA2
21429 C USED IN MATRIX ELEMENT FOR MULTIPION TAU DECAYS
21430 C CF YS.TSAI PHYS.REV D4 ,2821(1971)
21431 C F.GILMAN ET AL PHYS.REV D17,1846(1978)
21432 C C.KIESLING, TO BE PUB. IN HIGH ENERGY E+E- PHYSICS (1988)
21433 C DATSIG(*,1) = E+E- -> PI+PI-2PI0
21434 C DATSIG(*,2) = E+E- -> 2PI+2PI-
21435 C DATSIG(*,3) = 5-PION CONTRIBUTION (A LA TN.PHAM ET AL)
21436 C (PHYS LETT 78B,623(1978)
21437 C DATSIG(*,4) = E+E- -> 6PI
21438 C
21439 C 4- AND 6-PION CROSS SECTIONS FROM DATA
21440 C 5-PION CONTRIBUTION RELATED TO 4-PION CROSS SECTION
21441 C
21442 C CALLED BY DPHNPI
21443 C ----------------------------------------------------------------------
21444  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
21445  + ,ampiz,ampi,amro,gamro,ama1,gama1
21446  + ,amk,amkz,amkst,gamkst
21447 C
21448  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
21449  + ,ampiz,ampi,amro,gamro,ama1,gama1
21450  + ,amk,amkz,amkst,gamkst
21451  REAL*4 datsig(17,4)
21452 C
21453  DATA datsig/
21454  + 7.40,12.00,16.15,21.25,24.90,29.55,34.15,37.40,37.85,37.40,
21455  + 36.00,33.25,30.50,27.70,24.50,21.25,18.90,
21456  + 1.24, 2.50, 3.70, 5.40, 7.45,10.75,14.50,18.20,22.30,28.90,
21457  + 29.35,25.60,22.30,18.60,14.05,11.60, 9.10,
21458  + 17*.0,
21459  + 9*.0,.65,1.25,2.20,3.15,5.00,5.75,7.80,8.25/
21460  DATA sig0 / 86.8 /
21461  DATA pi /3.141592653589793238462643/
21462  DATA init / 0 /
21463 C
21464  IF(init.EQ.0) THEN
21465  init=1
21466  ampi2=ampi**2
21467  fpi = .943*ampi
21468  DO 30 i=1,17
21469  datsig(i,2) = datsig(i,2)/2.
21470  datsig(i,1) = datsig(i,1) + datsig(i,2)
21471  s = 1.025+(i-1)*.05
21472  fact=0.
21473  s2=s**2
21474  DO 10 j=1,17
21475  t= 1.025+(j-1)*.05
21476  IF(t . gt. s-ampi ) go to 20
21477  t2=t**2
21478  fact=(t2/s2)**2*sqrt((s2-t2-ampi2)**2-4.*t2*ampi2)/s2 *2.*
21479  + t*.05
21480  fact = fact * (datsig(j,1)+datsig(j+1,1))
21481  10 datsig(i,3) = datsig(i,3) + fact
21482  20 datsig(i,3) = datsig(i,3) /(2*pi*fpi)**2
21483  30 CONTINUE
21484 C WRITE(6,1000) DATSIG
21485 10000 FORMAT(///1x,' EE SIGMA USED IN MULTIPI DECAYS'/
21486  + (17f7.2/))
21487  ENDIF
21488  q=sqrt(q2)
21489  qmin=1.
21490  IF(q.LT.qmin) THEN
21491  sigol=datsig(1,jnpi)+
21492  + (datsig(2,jnpi)-datsig(1,jnpi))*(q-1.)/.05
21493  ELSEIF(q.LT.1.8) THEN
21494  DO 40 i=1,16
21495  qmax = qmin + .05
21496  IF(q.LT.qmax) go to 50
21497  qmin = qmin + .05
21498  40 CONTINUE
21499  50 sigol=datsig(i,jnpi)+
21500  + (datsig(i+1,jnpi)-datsig(i,jnpi)) * (q-qmin)/.05
21501  ELSEIF(q.GT.1.8) THEN
21502  sigol=datsig(17,jnpi)+
21503  + (datsig(17,jnpi)-datsig(16,jnpi)) * (q-1.8)/.05
21504  ENDIF
21505  IF(sigol.LT..0) sigol=0.
21506 C
21507  sigol = sigol/(6.*pi**2*sig0)
21508  sigold=sigol
21509 C
21510  RETURN
21511  END
21512 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
21513 *-- AUTHOR :
21514  SUBROUTINE sphera(R,X)
21515 C ----------------------------------------------------------------------
21516 C GENERATES UNIFORMLY THREE-VECTOR X ON SPHERE OF RADIUS R
21517 C
21518 C CALLED BY : DPHSXX,DADMPI,DADMKK
21519 C ----------------------------------------------------------------------
21520  REAL x(4)
21521  REAL*4 rrr(2)
21522  DATA pi /3.141592653589793238462643/
21523 C
21524  CALL ranmar(rrr,2)
21525  costh=-1.+2.*rrr(1)
21526  sinth=sqrt(1.-costh**2)
21527  x(1)=r*sinth*cos(2*pi*rrr(2))
21528  x(2)=r*sinth*sin(2*pi*rrr(2))
21529  x(3)=r*costh
21530  RETURN
21531  END
21532 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
21533 *-- AUTHOR :
21534  SUBROUTINE spherd(R,X)
21535 C ----------------------------------------------------------------------
21536 C GENERATES UNIFORMLY THREE-VECTOR X ON SPHERE OF RADIUS R
21537 C DOUBLE PRECISON VERSION OF SPHERA
21538 C ----------------------------------------------------------------------
21539  REAL*8 r,x(4),pi,costh,sinth
21540  REAL*4 rrr(2)
21541  DATA pi /3.141592653589793238462643d0/
21542 C
21543  CALL ranmar(rrr,2)
21544  costh=-1+2*rrr(1)
21545  sinth=sqrt(1 -costh**2)
21546  x(1)=r*sinth*cos(2*pi*rrr(2))
21547  x(2)=r*sinth*sin(2*pi*rrr(2))
21548  x(3)=r*costh
21549  RETURN
21550  END
21551 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
21552 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
21553 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
21554 *-- AUTHOR :
21555  FUNCTION sqm2(ITDKRC,QP,XN,XA,XK,AK0,HV)
21556 C
21557 C **********************************************************************
21558 C REAL PHOTON MATRIX ELEMENT SQUARED *
21559 C PARAMETERS: *
21560 C HV- POLARIMETRIC FOUR-VECTOR OF TAU *
21561 C QP,XN,XA,XK - 4-MOMENTA OF ELECTRON (MUON), NU, NUBAR AND PHOTON *
21562 C ALL FOUR-VECTORS IN TAU REST FRAME (IN GEV) *
21563 C AK0 - INFRARED CUTOFF, MINIMAL ENERGY OF HARD PHOTONS (GEV) *
21564 C SQM2 - VALUE FOR S=0 *
21565 C SEE EQS. (2.9)-(2.10) FROM CJK ( NUCL.PHYS.B(1991) ) *
21566 C **********************************************************************
21567 C
21568  IMPLICIT REAL*8(a-h,o-z)
21569  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
21570  + ,ampiz,ampi,amro,gamro,ama1,gama1
21571  + ,amk,amkz,amkst,gamkst
21572 C
21573  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
21574  + ,ampiz,ampi,amro,gamro,ama1,gama1
21575  + ,amk,amkz,amkst,gamkst
21576  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
21577  REAL*4 gfermi,gv,ga,ccabib,scabib,gamel
21578  COMMON / qedprm /alfinv,alfpi,xk0
21579  REAL*8 alfinv,alfpi,xk0
21580  REAL*8 qp(4),xn(4),xa(4),xk(4)
21581  REAL*8 r(4)
21582  REAL*8 hv(4)
21583  REAL*8 s0(3),rxa(3),rxk(3),rqp(3)
21584  DATA pi /3.141592653589793238462643d0/
21585 C
21586  tmass=amtau
21587  gf=gfermi
21588  alphai=alfinv
21589  tmass2=tmass**2
21590  emass2=qp(4)**2-qp(1)**2-qp(2)**2-qp(3)**2
21591  r(4)=tmass
21592 C SCALAR PRODUCTS OF FOUR-MOMENTA
21593  DO 10 i=1,3
21594  r(1)=0.d0
21595  r(2)=0.d0
21596  r(3)=0.d0
21597  r(i)=tmass
21598  rxa(i)=r(4)*xa(4)-r(1)*xa(1)-r(2)*xa(2)-r(3)*xa(3)
21599 C RXN(I)=R(4)*XN(4)-R(1)*XN(1)-R(2)*XN(2)-R(3)*XN(3)
21600  rxk(i)=r(4)*xk(4)-r(1)*xk(1)-r(2)*xk(2)-r(3)*xk(3)
21601  rqp(i)=r(4)*qp(4)-r(1)*qp(1)-r(2)*qp(2)-r(3)*qp(3)
21602  10 CONTINUE
21603  qpxn=qp(4)*xn(4)-qp(1)*xn(1)-qp(2)*xn(2)-qp(3)*xn(3)
21604  qpxa=qp(4)*xa(4)-qp(1)*xa(1)-qp(2)*xa(2)-qp(3)*xa(3)
21605  qpxk=qp(4)*xk(4)-qp(1)*xk(1)-qp(2)*xk(2)-qp(3)*xk(3)
21606 C XNXA=XN(4)*XA(4)-XN(1)*XA(1)-XN(2)*XA(2)-XN(3)*XA(3)
21607  xnxk=xn(4)*xk(4)-xn(1)*xk(1)-xn(2)*xk(2)-xn(3)*xk(3)
21608  xaxk=xa(4)*xk(4)-xa(1)*xk(1)-xa(2)*xk(2)-xa(3)*xk(3)
21609  txn=tmass*xn(4)
21610  txa=tmass*xa(4)
21611  tqp=tmass*qp(4)
21612  txk=tmass*xk(4)
21613 C
21614  x= xnxk/qpxn
21615  z= txk/tqp
21616  a= 1+x
21617  b= 1+ x*(1+z)/2+z/2
21618  s1= qpxn*txa*( -emass2/qpxk**2*a + 2*tqp/(qpxk*txk)*b-
21619  +tmass2/txk**2) +
21620  +qpxn/txk**2* ( tmass2*xaxk - txa*txk+ xaxk*txk) -
21621  +txa*txn/txk - qpxn/(qpxk*txk)* (tqp*xaxk-txk*qpxa)
21622  const4=256*pi/alphai*gf**2
21623  IF (itdkrc.EQ.0) const4=0d0
21624  sqm2=s1*const4
21625  DO 20 i=1,3
21626  s0(i) = qpxn*rxa(i)*(-emass2/qpxk**2*a + 2*tqp/(qpxk*txk)*b-
21627  + tmass2/txk**2) +
21628  + qpxn/txk**2* (tmass2*xaxk - txa*rxk(i)+ xaxk*rxk(i))-
21629  + rxa(i)*txn/txk - qpxn/(qpxk*txk)*(rqp(i)*xaxk- rxk(i)*qpxa)
21630  20 hv(i)=s0(i)/s1-1.d0
21631  RETURN
21632  END
21633 *CMZ : 1.01/14 14/05/95 11.26.28 BY PIERO ZUCCHELLI
21634 *CMZ : 1.01/08 05/03/95 11.39.27 BY PIERO ZUCCHELLI
21635 *CMZ : 1.00/00 09/08/94 17.43.59 BY PIERO ZUCCHELLI
21636 *-- AUTHOR :
21637  SUBROUTINE taufil
21638 C *****************
21639 C SUBSITUTE OF TAU PRODUCTION GENERATOR
21640 C
21641  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
21642  + ,ampiz,ampi,amro,gamro,ama1,gama1
21643  + ,amk,amkz,amkst,gamkst
21644 C
21645  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
21646  + ,ampiz,ampi,amro,gamro,ama1,gama1
21647  + ,amk,amkz,amkst,gamkst
21648  COMMON / idfc / idff
21649 C POSITIONS OF TAUS IN THE LUND COMMON BLOCK
21650 C IT WILL BE USED BY TAUOLA OUTPUT ROUTINES.
21651  COMMON /taupos / npa,npb
21652  dimension xpb1(4),xpb2(4),aqf1(4),aqf2(4)
21653 C
21654 C --- DEFINING DUMMY EVENTS MOMENTA
21655  DO 10 k=1,3
21656  xpb1(k)=0.0
21657  xpb2(k)=0.0
21658  aqf1(k)=0.0
21659  aqf2(k)=0.0
21660  10 CONTINUE
21661  aqf1(4)=amtau
21662  aqf2(4)=amtau
21663 C --- TAU MOMENTA
21664  CALL tralo4(1,aqf1,aqf1,am)
21665  CALL tralo4(2,aqf2,aqf2,am)
21666 C --- BEAMS MOMENTA AND IDENTIFIERS
21667  kfb1= 11*idff/iabs(idff)
21668  kfb2=-11*idff/iabs(idff)
21669  xpb1(4)= aqf1(4)
21670  xpb1(3)= aqf1(4)
21671  IF(aqf1(3).NE.0.0) xpb1(3)= aqf1(4)*aqf1(3)/abs(aqf1(3))
21672  xpb2(4)= aqf2(4)
21673  xpb2(3)=-aqf2(4)
21674  IF(aqf2(3).NE.0.0) xpb2(3)= aqf2(4)*aqf2(3)/abs(aqf2(3))
21675 C --- POSITION OF FIRST AND SECOND TAU IN LUND COMMON
21676  npa=3
21677  npb=4
21678 C --- FILL TO LUND COMMON
21679  CALL filhep( 1,3, kfb1,0,0,0,0,xpb1, amel,.true.)
21680  CALL filhep( 2,3, kfb2,0,0,0,0,xpb2, amel,.true.)
21681  CALL filhep(npa,1, idff,1,2,0,0,aqf1,amtau,.true.)
21682  CALL filhep(npb,1,-idff,1,2,0,0,aqf2,amtau,.true.)
21683  END
21684 *CMZ : 1.01/15 14/05/95 11.41.24 BY PIERO ZUCCHELLI
21685 *CMZ : 1.01/11 13/05/95 18.41.54 BY PIERO ZUCCHELLI
21686 *CMZ : 1.01/08 05/03/95 11.39.27 BY PIERO ZUCCHELLI
21687 *CMZ : 1.00/00 10/08/94 12.08.29 BY PIERO ZUCCHELLI
21688 *-- AUTHOR :
21689  SUBROUTINE tauinit
21690 C **************
21691 C NOTE THAT THE ROUTINES ARE NOT LIKE IN CPC DECK THIS IS HISTORICAL !!
21692 C=======================================================================
21693 C====================== DECTES : TEST OF TAU DECAY LIBRARY===========
21694 C====================== KTORY = 1 : INTERFACE OF KORAL-Z TYPE ==========
21695 C====================== KTORY = 2 : INTERFACE OF KORAL-B TYPE =========
21696 C=======================================================================
21697  COMMON / / blan(10000)
21698  COMMON / inout / inut,iout
21699  inut=5
21700  iout=6
21701  ktory=1
21702  CALL dectes(ktory)
21703 C KTORY=2
21704 C CALL DECTES(KTORY)
21705  END
21706 *CMZ : 1.01/14 14/05/95 11.26.28 BY PIERO ZUCCHELLI
21707 *CMZ : 1.01/08 05/03/95 11.39.27 BY PIERO ZUCCHELLI
21708 *CMZ : 1.00/00 09/08/94 17.43.59 BY PIERO ZUCCHELLI
21709 *-- AUTHOR :
21710  SUBROUTINE taurdf(KTO)
21711 C THIS ROUTINE CAN BE CALLED BEFORE ANY TAU+ OR TAU- EVENT IS GENERATED
21712 C IT CAN BE USED TO GENERATE TAU+ AND TAU- SAMPLES OF DIFFERENT
21713 C CONTENTS
21714  COMMON / taukle / bra1,brk0,brk0b,brks
21715  REAL*4 bra1,brk0,brk0b,brks
21716  COMMON / taubra / gamprt(30),jlist(30),nchan
21717  IF (kto.EQ.1) THEN
21718 C ==================
21719 C LIST OF BRANCHING RATIOS
21720  nchan = 19
21721  DO 10 i = 1,30
21722  IF (i.LE.nchan) THEN
21723  jlist(i) = i
21724  IF(i.EQ. 1) gamprt(i) = .0000
21725  IF(i.EQ. 2) gamprt(i) = .0000
21726  IF(i.EQ. 3) gamprt(i) = .0000
21727  IF(i.EQ. 4) gamprt(i) = .0000
21728  IF(i.EQ. 5) gamprt(i) = .0000
21729  IF(i.EQ. 6) gamprt(i) = .0000
21730  IF(i.EQ. 7) gamprt(i) = .0000
21731  IF(i.EQ. 8) gamprt(i) = 1.0000
21732  IF(i.EQ. 9) gamprt(i) = 1.0000
21733  IF(i.EQ.10) gamprt(i) = 1.0000
21734  IF(i.EQ.11) gamprt(i) = 1.0000
21735  IF(i.EQ.12) gamprt(i) = 1.0000
21736  IF(i.EQ.13) gamprt(i) = 1.0000
21737  IF(i.EQ.14) gamprt(i) = 1.0000
21738  IF(i.EQ.15) gamprt(i) = 1.0000
21739  IF(i.EQ.16) gamprt(i) = 1.0000
21740  IF(i.EQ.17) gamprt(i) = 1.0000
21741  IF(i.EQ.18) gamprt(i) = 1.0000
21742  IF(i.EQ.19) gamprt(i) = 1.0000
21743  ELSE
21744  jlist(i) = 0
21745  gamprt(i) = 0.
21746  ENDIF
21747  10 CONTINUE
21748 C --- COEFFICIENTS TO FIX RATIO OF:
21749 C --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
21750 C --- PROBABILITY OF K0 TO BE KS
21751 C --- PROBABILITY OF K0B TO BE KS
21752 C --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
21753 C --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
21754 C --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
21755 C --- NEGLECTS MASS-PHASE SPACE EFFECTS
21756  bra1=0.5
21757  brk0=0.5
21758  brk0b=0.5
21759  brks=0.6667
21760  ELSE
21761 C ====
21762 C LIST OF BRANCHING RATIOS
21763  nchan = 19
21764  DO 20 i = 1,30
21765  IF (i.LE.nchan) THEN
21766  jlist(i) = i
21767  IF(i.EQ. 1) gamprt(i) = .0000
21768  IF(i.EQ. 2) gamprt(i) = .0000
21769  IF(i.EQ. 3) gamprt(i) = .0000
21770  IF(i.EQ. 4) gamprt(i) = .0000
21771  IF(i.EQ. 5) gamprt(i) = .0000
21772  IF(i.EQ. 6) gamprt(i) = .0000
21773  IF(i.EQ. 7) gamprt(i) = .0000
21774  IF(i.EQ. 8) gamprt(i) = 1.0000
21775  IF(i.EQ. 9) gamprt(i) = 1.0000
21776  IF(i.EQ.10) gamprt(i) = 1.0000
21777  IF(i.EQ.11) gamprt(i) = 1.0000
21778  IF(i.EQ.12) gamprt(i) = 1.0000
21779  IF(i.EQ.13) gamprt(i) = 1.0000
21780  IF(i.EQ.14) gamprt(i) = 1.0000
21781  IF(i.EQ.15) gamprt(i) = 1.0000
21782  IF(i.EQ.16) gamprt(i) = 1.0000
21783  IF(i.EQ.17) gamprt(i) = 1.0000
21784  IF(i.EQ.18) gamprt(i) = 1.0000
21785  IF(i.EQ.19) gamprt(i) = 1.0000
21786  ELSE
21787  jlist(i) = 0
21788  gamprt(i) = 0.
21789  ENDIF
21790  20 CONTINUE
21791 C --- COEFFICIENTS TO FIX RATIO OF:
21792 C --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
21793 C --- PROBABILITY OF K0 TO BE KS
21794 C --- PROBABILITY OF K0B TO BE KS
21795 C --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
21796 C --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
21797 C --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
21798 C --- NEGLECTS MASS-PHASE SPACE EFFECTS
21799  bra1=0.5
21800  brk0=0.5
21801  brk0b=0.5
21802  brks=0.6667
21803  ENDIF
21804 C =====
21805  END
21806 *CMZ : 1.01/14 14/05/95 11.26.27 BY PIERO ZUCCHELLI
21807 *CMZ : 1.01/08 05/03/95 11.39.26 BY PIERO ZUCCHELLI
21808 *CMZ : 1.00/00 10/08/94 16.29.40 BY PIERO ZUCCHELLI
21809 *-- AUTHOR :
21810  FUNCTION thb(ITDKRC,QP,XN,XA,AK0,HV)
21811 C
21812 C **********************************************************************
21813 C BORN +VIRTUAL+SOFT PHOTON MATRIX ELEMENT**2 O(ALPHA) *
21814 C PARAMETERS: *
21815 C HV- POLARIMETRIC FOUR-VECTOR OF TAU *
21816 C QP,XN,XA - FOUR-MOMENTA OF ELECTRON (MUON), NU AND NUBAR IN GEV *
21817 C ALL FOUR-VECTORS IN TAU REST FRAME *
21818 C AK0 - INFRARED CUTOFF, MINIMAL ENERGY OF HARD PHOTONS *
21819 C THB - VALUE FOR S=0 *
21820 C SEE EQS. (2.2),(2.4)-(2.5) FROM CJK (NUCL.PHYS.B351(1991)70 *
21821 C AND (C.2) FROM JK (NUCL.PHYS.B320(1991)20 ) *
21822 C **********************************************************************
21823 C
21824  IMPLICIT REAL*8(a-h,o-z)
21825  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
21826  + ,ampiz,ampi,amro,gamro,ama1,gama1
21827  + ,amk,amkz,amkst,gamkst
21828 C
21829  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
21830  + ,ampiz,ampi,amro,gamro,ama1,gama1
21831  + ,amk,amkz,amkst,gamkst
21832  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
21833  REAL*4 gfermi,gv,ga,ccabib,scabib,gamel
21834  COMMON / qedprm /alfinv,alfpi,xk0
21835  REAL*8 alfinv,alfpi,xk0
21836  dimension qp(4),xn(4),xa(4)
21837  REAL*8 hv(4)
21838  dimension r(4)
21839  REAL*8 rxa(3),rxn(3),rqp(3)
21840  REAL*8 bornpl(3),am3pol(3),xm3pol(3)
21841  DATA pi /3.141592653589793238462643d0/
21842 C
21843  tmass=amtau
21844  gf=gfermi
21845  alphai=alfinv
21846 C
21847  tmass2=tmass**2
21848  r(4)=tmass
21849  DO 10 i=1,3
21850  r(1)=0.d0
21851  r(2)=0.d0
21852  r(3)=0.d0
21853  r(i)=tmass
21854  rxa(i)=r(4)*xa(4)-r(1)*xa(1)-r(2)*xa(2)-r(3)*xa(3)
21855  rxn(i)=r(4)*xn(4)-r(1)*xn(1)-r(2)*xn(2)-r(3)*xn(3)
21856 C RXK(I)=R(4)*XK(4)-R(1)*XK(1)-R(2)*XK(2)-R(3)*XK(3)
21857  rqp(i)=r(4)*qp(4)-r(1)*qp(1)-r(2)*qp(2)-r(3)*qp(3)
21858  10 CONTINUE
21859 C QUASI TWO-BODY VARIABLES
21860  u0=qp(4)/tmass
21861  u3=sqrt(qp(1)**2+qp(2)**2+qp(3)**2)/tmass
21862  w3=u3
21863  w0=(xn(4)+xa(4))/tmass
21864  up=u0+u3
21865  um=u0-u3
21866  wp=w0+w3
21867  wm=w0-w3
21868  yu=log(up/um)/2
21869  yw=log(wp/wm)/2
21870  eps2=u0**2-u3**2
21871  eps=sqrt(eps2)
21872  y=w0**2-w3**2
21873  al=ak0/tmass
21874 C FORMFACTORS
21875  f0=2*u0/u3*( dilog(1-(um*wm/(up*wp)))- dilog(1-wm/wp) +
21876  +dilog(1-um/up) -2*yu+ 2*log(up)*(yw+yu) ) +
21877  +1/y* ( 2*u3*yu + (1-eps2- 2*y)*log(eps) ) +
21878  + 2 - 4*(u0/u3*yu -1)* log(2*al)
21879  fp= yu/(2*u3)*(1 + (1-eps2)/y ) + log(eps)/y
21880  fm= yu/(2*u3)*(1 - (1-eps2)/y ) - log(eps)/y
21881  f3= eps2*(fp+fm)/2
21882 C SCALAR PRODUCTS OF FOUR-MOMENTA
21883  qpxn=qp(4)*xn(4)-qp(1)*xn(1)-qp(2)*xn(2)-qp(3)*xn(3)
21884  qpxa=qp(4)*xa(4)-qp(1)*xa(1)-qp(2)*xa(2)-qp(3)*xa(3)
21885  xnxa=xn(4)*xa(4)-xn(1)*xa(1)-xn(2)*xa(2)-xn(3)*xa(3)
21886  txn=tmass*xn(4)
21887  txa=tmass*xa(4)
21888  tqp=tmass*qp(4)
21889 C DECAY DIFFERENTIAL WIDTH WITHOUT AND WITH POLARIZATION
21890  const3=1/(2*alphai*pi)*64*gf**2
21891  IF (itdkrc.EQ.0) const3=0d0
21892  xm3= -( f0* qpxn*txa + fp*eps2* txn*txa +
21893  +fm* qpxn*qpxa + f3* tmass2*xnxa )
21894  am3=xm3*const3
21895 C V-A AND V+A COUPLINGS, BUT IN THE BORN PART ONLY
21896  brak= (gv+ga)**2*tqp*xnxa+(gv-ga)**2*txa*qpxn
21897  + -(gv**2-ga**2)*tmass*amnuta*qpxa
21898  born= 32*(gfermi**2/2.)*brak
21899  DO 20 i=1,3
21900  xm3pol(i)= -( f0* qpxn*rxa(i) + fp*eps2* txn*rxa(i) +
21901  + fm* qpxn* (qpxa + (rxa(i)*tqp-txa*rqp(i))/tmass2 ) +
21902  + f3* (tmass2*xnxa +txn*rxa(i) -rxn(i)*txa) )
21903  am3pol(i)=xm3pol(i)*const3
21904 C V-A AND V+A COUPLINGS, BUT IN THE BORN PART ONLY
21905  bornpl(i)=born+(
21906  + (gv+ga)**2*tmass*xnxa*qp(i)
21907  + -(gv-ga)**2*tmass*qpxn*xa(i)
21908  + +(gv**2-ga**2)*amnuta*txa*qp(i)
21909  + -(gv**2-ga**2)*amnuta*tqp*xa(i) )*
21910  + 32*(gfermi**2/2.)
21911  20 hv(i)=(bornpl(i)+am3pol(i))/(born+am3)-1.d0
21912  thb=born+am3
21913  IF (thb/born.LT.0.1d0) THEN
21914  print *, 'ERROR IN THB, THB/BORN=',thb/born
21915  stop
21916  ENDIF
21917  RETURN
21918  END
21919 *CMZ : 1.00/00 09/08/94 17.43.59 BY PIERO ZUCCHELLI
21920 *-- AUTHOR :
21921  SUBROUTINE tralo4(KTO,P,Q,AM)
21922 C **************************
21923 C SUBSITUTE OF TRALO4
21924  REAL p(4),q(4)
21925 C
21926  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
21927  * ,ampiz,ampi,amro,gamro,ama1,gama1
21928  * ,amk,amkz,amkst,gamkst
21929 C
21930  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
21931  * ,ampiz,ampi,amro,gamro,ama1,gama1
21932  * ,amk,amkz,amkst,gamkst
21933  COMMON /ptau/ ptau
21934  am=amas4(p)
21935  etau=sqrt(ptau**2+amtau**2)
21936  exe=(etau+ptau)/amtau
21937  IF(kto.EQ.2) exe=(etau-ptau)/amtau
21938  CALL bostr3(exe,p,q)
21939 C ======================================================================
21940 C END OF THE TEST JOB
21941 C ======================================================================
21942  END
21943 *CMZ : 1.00/00 10/08/94 16.29.32 BY PIERO ZUCCHELLI
21944 *-- AUTHOR :
21945  FUNCTION wigfor(S,XM,XGAM)
21946  COMPLEX wigfor,wignor
21947  wignor=cmplx(-xm**2,xm*xgam)
21948  wigfor=wignor/cmplx(s-xm**2,xm*xgam)
21949  END
21950 
lframe
subroutine lframe(IFR, IPH)
Definition: leptonew.f:11476
phoinf
subroutine phoinf
Definition: leptonew.f:17991
cats
subroutine cats
Definition: leptonew.f:1776
version
const XML_Char * version
Definition: include/expat.h:187
fpirho
function fpirho(W)
Definition: leptonew.f:8508
ltimex
subroutine ltimex(TIME)
Definition: leptonew.f:14697
dexnew
subroutine dexnew(MODE, ISGN, POL, PNU, PAA, PNPI, JNPI)
Definition: leptonew.f:4590
HepGeom::Transform3D::yy
double yy() const
Definition: Transform3D.h:264
pysspb
subroutine pysspb(IPU1, IPU2)
Definition: leptonew.f:19588
lnstrf
subroutine lnstrf(X, Q2, XPQ)
Definition: leptonew.f:13443
gbspec
subroutine gbspec(BEAM, IFLAV, RADIUS, SPEC)
Definition: leptonew.f:9033
rlu
real *4 function rlu(IDUMMY)
Definition: leptonew.f:21166
luexec
subroutine luexec
Definition: jetset74ku.f:955
lminto
subroutine lminto(PINT)
Definition: leptonew.f:12969
pystpr
subroutine pystpr(X, Q2, XPPR)
Definition: leptonew.f:20311
getneu
subroutine getneu(IPNUM, NEUTYPE, VECT, GKIN, MESTYPE, G4MES, NEUFORCE, IMODE)
Definition: leptonew.f:9358
distrr
real *4 function distrr(DUMMY)
Definition: leptonew.f:4796
flipol
subroutine flipol(FLQ, FLG, FLM)
Definition: leptonew.f:7684
dexks
subroutine dexks(MODE, ISGN, POL, PNU, PKS, PKK, PPI, JKST)
Definition: leptonew.f:4495
dsum
G4ErrorMatrix dsum(const G4ErrorMatrix &, const G4ErrorMatrix &)
Definition: G4ErrorMatrix.cc:201
bostd3
subroutine bostd3(EXE, PVEC, QVEC)
Definition: leptonew.f:1632
plu
function plu(I, J)
Definition: jetset74ku.f:6207
dphsro
subroutine dphsro(DGAMT, HV, PN, PR, PIC, PIZ)
Definition: leptonew.f:6085
phooma
subroutine phooma(IFIRST, ILAST, POINTR)
Definition: leptonew.f:18246
lqcdpr
subroutine lqcdpr(QG, QQB)
Definition: leptonew.f:13584
flqint
function flqint(Z)
Definition: leptonew.f:7757
phlupa
subroutine phlupa(IPOINT)
Definition: leptonew.f:16856
no
Definition: G4DataQuestionaire.hh:35
G4Abla::nint
G4int nint(G4double number)
Definition: G4Abla.cc:3631
linit
subroutine linit(LFILE, LEPIN, PLZ, PPZ, INTER)
Definition: leptonew.f:11611
phofac
real function phofac(MODE)
Definition: leptonew.f:17809
phochk
subroutine phochk(JFIRST)
Definition: leptonew.f:17151
red
Definition: test07.cc:36
sigee
function sigee(Q2, JNP)
Definition: leptonew.f:21328
dqcdi
function dqcdi(IPART, IP, XP, ZPMIN, ZPMAX)
Definition: leptonew.f:6487
dexro
subroutine dexro(MODE, ISGN, POL, PNU, PRO, PIC, PIZ)
Definition: leptonew.f:4669
fpikm
complex function fpikm(W, XM1, XM2)
Definition: leptonew.f:8416
dwlupi
subroutine dwlupi(KTO, ISGN, PPI, PNU)
Definition: leptonew.f:7271
ranmar
subroutine ranmar(RVEC, ISEQ)
Definition: leptonew.f:20998
CLHEP::HepBoost::xt
double xt() const
G4StokesVector::p2
G4double p2() const
Definition: G4StokesVector.hh:75
dekay
subroutine dekay(KTO, HX)
Definition: leptonew.f:3795
phocha
real function phocha(IDHEP)
Definition: leptonew.f:17088
gethneu
subroutine gethneu(IPNUM, NEUTYPE, VECT, GKIN, MESTYPE, G4MES, NEUFORCE, IMODE)
Definition: leptonew.f:9198
jettout
subroutine jettout
Definition: leptonew.f:10147
lmcmnd
subroutine lmcmnd
Definition: leptonew.f:12254
dadmro
subroutine dadmro(MODE, ISGN, HHV, PNU, PRO, PIC, PIZ)
Definition: leptonew.f:2820
phtype
subroutine phtype(ID)
Definition: leptonew.f:19045
jaker
subroutine jaker(JAK)
Definition: leptonew.f:9930
gbinit
subroutine gbinit
Definition: leptonew.f:8942
rotor3
subroutine rotor3(PHI, PVEC, QVEC)
Definition: leptonew.f:21282
G4String::first
G4int first(char) const
int
typedef int(XMLCALL *XML_NotStandaloneHandler)(void *userData)
phorep
subroutine phorep
Definition: leptonew.f:18565
s
const XML_Char * s
Definition: include/expat.h:262
z
G4double z
Definition: TRTMaterials.hh:39
form3
complex function form3(MNUM, QQ, S1, SDWA)
Definition: leptonew.f:8188
lqqbev
subroutine lqqbev
Definition: leptonew.f:13932
dexay
subroutine dexay(KTO, POL)
Definition: leptonew.f:4212
gadap
subroutine gadap(A0, B0, F, EPS, SUM)
Definition: leptonew.f:8665
p
const char * p
Definition: xmltok.h:285
ludecy
subroutine ludecy(IP)
Definition: jetset74ku.f:1887
lmrazz
subroutine lmrazz(YNEW, PNEW)
Definition: leptonew.f:13171
gadap2
subroutine gadap2(A0, B0, FL, FU, F, EPS, SUM)
Definition: leptonew.f:8751
lucomp
function lucomp(KF)
Definition: dpm25nonu.f:31
lprikt
subroutine lprikt(S, PT, PHI)
Definition: leptonew.f:13469
HepGeom::BasicVector3D::unit
BasicVector3D< T > unit() const
Definition: BasicVector3D.h:304
phomak
subroutine phomak(IPPAR, NHEP0)
Definition: leptonew.f:18186
phobos
subroutine phobos(IP, PBOOS1, PBOOS2, FIRST, LAST)
Definition: leptonew.f:17007
luprep
subroutine luprep(IP)
Definition: jetset74ku.f:1075
ulangl
function ulangl(X, Y)
Definition: jetset74ku.f:5015
photri
real function photri(A, B, C)
Definition: leptonew.f:18953
dilog
function dilog(X)
Definition: leptonew.f:4727
phoran
real *4 function phoran(IDUMMY)
Definition: leptonew.f:18557
gadapf
function gadapf(X, A0, B0, F, EPS)
Definition: leptonew.f:8869
fltabl
subroutine fltabl
Definition: leptonew.f:7784
lu1ent
subroutine lu1ent(IP, KF, PE, THE, PHI)
Definition: jetset74ku.f:88
angfi
function angfi(X, Y)
Definition: leptonew.f:1593
pyp
function pyp(I, J)
Definition: pythia61.f:38097
HepGeom::Transform3D::dx
double dx() const
Definition: Transform3D.h:279
wigfor
complex function wigfor(S, XM, XGAM)
Definition: leptonew.f:21946
c2_factory::tan
static c2_tan_p< float_type > & tan()
make a *new object
Definition: c2_factory.hh:136
a
G4double a
Definition: TRTMaterials.hh:39
amast
function amast(PP)
Definition: leptonew.f:1577
lscale
subroutine lscale(INFIN, QMAX)
Definition: leptonew.f:14130
phoan2
double precision function phoan2(X, Y)
Definition: leptonew.f:16948
sigold
function sigold(Q2, JNPI)
Definition: leptonew.f:21426
HepGeom::Plane3D::d
T d() const
Definition: Plane3D.h:86
c2_transformation::ident
static float_type ident(float_type x)
utility function f(x)=x useful in axis transforms
Definition: c2_function.hh:1199
dekay2
subroutine dekay2(IMOD, HH, ISGN)
Definition: leptonew.f:4066
btocho2
subroutine btocho2(VIN, PIN, PTX, PTY)
Definition: leptonew.f:1679
rotor2
subroutine rotor2(PH1, PVEC, QVEC)
Definition: leptonew.f:21262
lshowr
subroutine lshowr(ICALL)
Definition: leptonew.f:14194
lsigmx
subroutine lsigmx(NPAR, DERIV, DIFSIG, XF, IFLAG)
Definition: leptonew.f:14588
curr
subroutine curr(MNUM, PIM1, PIM2, PIM3, PIM4, HADCUR)
Definition: leptonew.f:2041
dwlumu
subroutine dwlumu(KTO, ISGN, PNU, PWB, PMU, PNM)
Definition: leptonew.f:7200
dadmpi
subroutine dadmpi(MODE, ISGN, HV, PPI, PNU)
Definition: leptonew.f:2745
dadmmu
subroutine dadmmu(MODE, ISGN, HHV, PNU, PWB, Q1, Q2, PHX)
Definition: leptonew.f:2642
dphnpi
subroutine dphnpi(DGAMT, HVX, PNX, PRX, PPIX, JNPI)
Definition: leptonew.f:5479
dampaa
subroutine dampaa(PT, PN, PIM1, PIM2, PIPL, AMPLIT, HV)
Definition: leptonew.f:3137
fermii
subroutine fermii(F)
Definition: leptonew.f:7468
dwluro
subroutine dwluro(KTO, ISGN, PNU, PRHO, PIC, PIZ)
Definition: leptonew.f:7302
fltint
function fltint(Z)
Definition: leptonew.f:7886
phorin
subroutine phorin
Definition: leptonew.f:18623
dwluph
subroutine dwluph(KTO, PHOT)
Definition: leptonew.f:7239
G4Abla::mod
G4int mod(G4int a, G4int b)
Definition: G4Abla.cc:3675
luptdi
subroutine luptdi(KFL, PX, PY)
Definition: jetset74ku.f:3099
lminew
subroutine lminew
Definition: leptonew.f:12896
lkinem
function lkinem(L)
Definition: leptonew.f:12147
lepto
subroutine lepto
Definition: leptonew.f:1201
dbeta
double precision function dbeta(X1, X2, BET)
Definition: dpm25nuc7.f:2672
orth
subroutine orth(PO, P, PB)
Definition: leptonew.f:16676
dadmel
subroutine dadmel(MODE, ISGN, HHV, PNU, PWB, Q1, Q2, PHX)
Definition: leptonew.f:2335
lqgev
subroutine lqgev
Definition: leptonew.f:13703
G4StokesVector::p3
G4double p3() const
Definition: G4StokesVector.hh:76
phodo
subroutine phodo(IP, NCHARB, NEUDAU)
Definition: leptonew.f:17419
sphera
subroutine sphera(R, X)
Definition: leptonew.f:21515
lqmcut
function lqmcut(XP, ZP, AM1, AM2, AM3)
Definition: leptonew.f:13886
lmsimp
subroutine lmsimp
Definition: leptonew.f:13243
clnut
subroutine clnut(HJ, B, HV)
Definition: leptonew.f:2002
clvec
subroutine clvec(HJ, PN, PIV)
Definition: leptonew.f:2020
lutoge
function lutoge(KF)
Definition: leptonew.f:16009
lustrf
subroutine lustrf(IP)
Definition: leptonew.f:14883
photwo
subroutine photwo(MODE)
Definition: leptonew.f:18984
ulmass
function ulmass(KF)
Definition: jetset74ku.f:4491
dadmkk
subroutine dadmkk(MODE, ISGN, HV, PKK, PNU)
Definition: leptonew.f:2443
lugive
subroutine lugive(CHIN)
Definition: jetset74ku.f:547
formom
complex function formom(XMAA, XMOM)
Definition: leptonew.f:8350
energy
double precision function energy(A, Z)
Definition: dpm25nuc6.f:4106
phoerr
subroutine phoerr(IMES, TEXT, DATA)
Definition: leptonew.f:17691
jetmc
subroutine jetmc
Definition: leptonew.f:9995
tralo4
subroutine tralo4(KTO, P, Q, AM)
Definition: leptonew.f:21922
fzclos
subroutine fzclos
Definition: leptonew.f:8536
CLHEP::HepLorentzVector::vect
Hep3Vector vect() const
lprwts
subroutine lprwts(NSTEP)
Definition: leptonew.f:13484
lu2ent
subroutine lu2ent(IP, KF1, KF2, PECM)
Definition: jetset74ku.f:135
dphsaa
subroutine dphsaa(DGAMT, HV, PN, PAA, PIM1, PIM2, PIPL, JAA)
Definition: leptonew.f:5688
lmeps
subroutine lmeps
Definition: leptonew.f:12343
CLHEP::HepBoost::tt
double tt() const
lxsect
subroutine lxsect
Definition: leptonew.f:16423
forced_decay
subroutine forced_decay(NUFORCE, ISTATUS)
Definition: leptonew.f:7911
CLHEP::HepLorentzVector::py
double py() const
dexaa
subroutine dexaa(MODE, ISGN, POL, PNU, PAA, PIM1, PIM2, PIPL, JAA)
Definition: leptonew.f:4165
lazimu
subroutine lazimu(XP, ZP)
Definition: leptonew.f:10587
dqcd
function dqcd(ICOSFI, IPART, IP, XP, ZP, Y)
Definition: leptonew.f:6408
inimas
subroutine inimas
Definition: leptonew.f:9573
fpikmd
complex function fpikmd(W, XM1, XM2)
Definition: leptonew.f:8445
fpik
complex function fpik(W)
Definition: leptonew.f:8387
iz
G4double iz
Definition: TRTMaterials.hh:39
dvnopt
subroutine dvnopt
Definition: leptonew.f:6927
dampog
subroutine dampog(PT, PN, PIM1, PIM2, PIPL, AMPLIT, HV)
Definition: leptonew.f:3228
bwigm
complex function bwigm(S, M, G, XM1, XM2)
Definition: leptonew.f:1719
thb
function thb(ITDKRC, QP, XN, XA, AK0, HV)
Definition: leptonew.f:21811
rotod3
subroutine rotod3(PH1, PVEC, QVEC)
Definition: leptonew.f:21223
dphsmu
subroutine dphsmu(DGAMX, HVX, XNX, PAAX, QPX, XAX, PHX)
Definition: leptonew.f:5925
lulist
subroutine lulist(MLIST)
Definition: jetset74ku.f:5388
CLHEP::HepLorentzVector::px
double px() const
lmidat
subroutine lmidat
Definition: leptonew.f:12702
dfun
double precision function dfun(NDIM, X)
Definition: leptonew.f:4718
dsigma
function dsigma(XP)
Definition: leptonew.f:6713
flintg
subroutine flintg(CFLQ, CFLG, CFLM)
Definition: leptonew.f:7625
G4StokesVector::p1
G4double p1() const
Definition: G4StokesVector.hh:74
dwrph
subroutine dwrph(KTO, PHX)
Definition: leptonew.f:7343
dectes
subroutine dectes(KTORY)
Definition: leptonew.f:3632
tauinit
subroutine tauinit
Definition: leptonew.f:21690
reslu
subroutine reslu
Definition: leptonew.f:21085
phocor
real function phocor(MPASQR, MCHREN, ME)
Definition: leptonew.f:17350
phocin
subroutine phocin
Definition: leptonew.f:17258
CLHEP::HepBoost::gamma
double gamma() const
phoro2
subroutine phoro2(ANGLE, PVEC)
Definition: leptonew.f:18684
dcross
function dcross(V1, V2)
Definition: leptonew.f:3567
n
const G4int n
Definition: G4UrQMD1_3Interface.hh:144
angxy
function angxy(X, Y)
Definition: leptonew.f:1613
phoini
subroutine phoini
Definition: leptonew.f:18146
CLHEP::HepLorentzRotation::boost
HepLorentzRotation & boost(double, double, double)
dphsrk
subroutine dphsrk(DGAMT, HV, PN, PR, PMULT, INUM)
Definition: leptonew.f:5982
dampry
subroutine dampry(ITDKRC, XK0DEC, XK, XA, QP, XN, AMPLIT, HV)
Definition: leptonew.f:3496
initdk
subroutine initdk
Definition: leptonew.f:9635
phoout
subroutine phoout(IP, BOOST, NHEP0)
Definition: leptonew.f:18300
filhep
subroutine filhep(N, IST, ID, JMO1, JMO2, JDA1, JDA2, P4, PINV, PHFLAG)
Definition: leptonew.f:7517
phoro3
subroutine phoro3(ANGLE, PVEC)
Definition: leptonew.f:18711
rotpox
subroutine rotpox(THET, PHI, PP)
Definition: leptonew.f:21313
mzini
subroutine mzini
Definition: leptonew.f:16643
lunpik
function lunpik(ID, ISGN)
Definition: leptonew.f:14709
riwfun
double precision function riwfun(V)
Definition: leptonew.f:21102
dwluaa
subroutine dwluaa(KTO, ISGN, PNU, PAA, PIM1, PIM2, PIPL, JAA)
Definition: leptonew.f:6995
lukfdi
subroutine lukfdi(KFL1, KFL2, KFL3, KF)
Definition: jetset74ku.f:2767
lweits
subroutine lweits(LFILE)
Definition: leptonew.f:16163
luhepc
subroutine luhepc(MCONV)
Definition: jetset74ku.f:9400
status
int status
Definition: tracer.cxx:24
choice
subroutine choice(MNUM, RR, ICHAN, PROB1, PROB2, PROB3, AMRX, GAMRX, AMRA, GAMRA, AMRB, GAMRB)
Definition: leptonew.f:1817
dekay1
subroutine dekay1(IMOD, HH, ISGN)
Definition: leptonew.f:3965
dupper
function dupper(V1)
Definition: leptonew.f:6901
dexay1
subroutine dexay1(KTO, JAKIN, JAK, POL, ISGN)
Definition: leptonew.f:4360
dwlukk
subroutine dwlukk(KTO, ISGN, PKK, PNU)
Definition: leptonew.f:7101
phopre
subroutine phopre(IPARR, WT, NEUDAU, NCHARB)
Definition: leptonew.f:18383
HepGeom::BasicVector3D::angle
T angle(const BasicVector3D< T > &v) const
luchge
function luchge(KF)
Definition: jetset74ku.f:4723
HepGeom::Transform3D::dz
double dz() const
Definition: Transform3D.h:285
phoin
subroutine phoin(IP, BOOST, NHEP0)
Definition: leptonew.f:17866
initdk_new
subroutine initdk_new
Definition: leptonew.f:9785
dph5pi
subroutine dph5pi(DGAMT, HV, PN, PAA, PMULT, JNPI)
Definition: leptonew.f:5206
phoene
subroutine phoene(MPASQR, MCHREN, BETA, IDENT)
Definition: leptonew.f:17603
title
subroutine title(NA, NB, NCA, NCB)
Definition: dpm25nuc7.f:1744
readffky
subroutine readffky
Definition: leptonew.f:21020
form1
complex function form1(MNUM, QQ, S1, SDWA)
Definition: leptonew.f:8066
c2_factory::log
static c2_log_p< float_type > & log()
make a *new object
Definition: c2_factory.hh:138
dadnew
subroutine dadnew(MODE, ISGN, HV, PNU, PWB, PNPI, JNPI)
Definition: leptonew.f:2926
rotor1
subroutine rotor1(PH1, PVEC, QVEC)
Definition: leptonew.f:21243
parupd
subroutine parupd
Definition: leptonew.f:16746
G4String::last
G4int last(char) const
lmprin
subroutine lmprin(IKODE, FVAL)
Definition: leptonew.f:13075
bostr3
subroutine bostr3(EXE, PVEC, QVEC)
Definition: leptonew.f:1655
ulalps
function ulalps(Q2)
Definition: jetset74ku.f:4957
pystfu
subroutine pystfu(KF, X, Q2, XPQ)
Definition: leptonew.f:20190
gfun
function gfun(QKWA)
Definition: leptonew.f:9551
jettarun
subroutine jettarun
Definition: leptonew.f:54
fpirk
function fpirk(W)
Definition: leptonew.f:8517
taurdf
subroutine taurdf(KTO)
Definition: leptonew.f:21711
dwluel
subroutine dwluel(KTO, ISGN, PNU, PWB, PEL, PNE)
Definition: leptonew.f:7062
lremh
subroutine lremh(IFLRO, IFLR, K2, Z)
Definition: leptonew.f:14054
dwlnew
subroutine dwlnew(KTO, ISGN, PNU, PWB, PNPI, MODE)
Definition: leptonew.f:6943
pyremm
subroutine pyremm(IPU1, IPU2)
Definition: leptonew.f:19141
rndmm
real *4 function rndmm(IDUMMY)
Definition: leptonew.f:21195
riwibd
subroutine riwibd
Definition: leptonew.f:21133
spherd
subroutine spherd(R, X)
Definition: leptonew.f:21535
phospi
real function phospi(IDHEP)
Definition: leptonew.f:18738
damppk
subroutine damppk(MNUM, PT, PN, PIM1, PIM2, PIM3, AMPLIT, HV)
Definition: leptonew.f:3337
dexel
subroutine dexel(MODE, ISGN, POL, PNU, PWB, Q1, Q2, PH)
Definition: leptonew.f:4421
HepGeom::Transform3D::xx
double xx() const
Definition: Transform3D.h:252
iniphy
subroutine iniphy(XK00)
Definition: leptonew.f:9613
lqev
subroutine lqev
Definition: leptonew.f:13798
sqm2
function sqm2(ITDKRC, QP, XN, XA, XK, AK0, HV)
Definition: leptonew.f:21556
c2_factory::sqrt
static c2_sqrt_p< float_type > & sqrt()
make a *new object
Definition: c2_factory.hh:142
dexpi
subroutine dexpi(MODE, ISGN, POL, PPI, PNU)
Definition: leptonew.f:4635
lxp
subroutine lxp(XP, IFAIL)
Definition: leptonew.f:16381
CLHEP::HepLorentzVector::pz
double pz() const
dphsel
subroutine dphsel(DGAMX, HVX, XNX, PAAX, QPX, XAX, PHX)
Definition: leptonew.f:5730
dadmaa
subroutine dadmaa(MODE, ISGN, HHV, PNU, PAA, PIM1, PIM2, PIPL, JAA)
Definition: leptonew.f:2233
lu3ent
subroutine lu3ent(IP, KF1, KF2, KF3, PECM, X1, X3)
Definition: jetset74ku.f:219
value
const XML_Char int const XML_Char * value
Definition: include/expat.h:331
CLHEP::HepBoost::tx
double tx() const
CLHEP::HepBoost::beta
double beta() const
form2
complex function form2(MNUM, QQ, S1, SDWA)
Definition: leptonew.f:8126
G4Abla::f
G4double f(G4double E)
Definition: G4Abla.cc:3026
dexkk
subroutine dexkk(MODE, ISGN, POL, PKK, PNU)
Definition: leptonew.f:4461
lmpint
real function lmpint(PEXTI, I)
Definition: leptonew.f:13013
flgint
function flgint(Z)
Definition: leptonew.f:7604
dphtre
subroutine dphtre(DGAMT, HV, PN, PAA, PIM1, AMPA, PIM2, AMPB, PIPL, AMP3, KEYT, MNUM)
Definition: leptonew.f:6178
phoan1
double precision function phoan1(X, Y)
Definition: leptonew.f:16917
claxi
subroutine claxi(HJ, PN, PIA)
Definition: leptonew.f:1963
form5
complex function form5(MNUM, QQ, S1, S2)
Definition: leptonew.f:8293
dwluks
subroutine dwluks(KTO, ISGN, PNU, PKS, PKK, PPI, JKST)
Definition: leptonew.f:7131
lzp
subroutine lzp(XP, ZP, IFAIL)
Definition: leptonew.f:16562
CLHEP::HepAxisAngle::delta
double delta() const
evtinfo
subroutine evtinfo
Definition: leptonew.f:7369
lflav
subroutine lflav(IFL, IFLR)
Definition: leptonew.f:11354
rotod2
subroutine rotod2(PH1, PVEC, QVEC)
Definition: leptonew.f:21202
rotod1
subroutine rotod1(PH1, PVEC, QVEC)
Definition: leptonew.f:21174
pyspla
subroutine pyspla(KPART, KFLIN, KFLCH, KFLSP)
Definition: leptonew.f:19421
photon
Definition: G4DataQuestionaire.hh:35
distr
subroutine distr(IOP, NHKKH1, PO, IGENER)
Definition: dpm25hist.f:9
dph4pi
subroutine dph4pi(DGAMT, HV, PN, PAA, PMULT, JNPI)
Definition: leptonew.f:4911
amas4
function amas4(PP)
Definition: leptonew.f:1562
print
void print(const std::vector< T > &data)
Definition: DicomRun.hh:111
bwigs
complex function bwigs(S, M, G)
Definition: leptonew.f:1746
dphspk
subroutine dphspk(DGAMT, HV, PN, PAA, PNPI, JAA)
Definition: leptonew.f:5950
rotpol
subroutine rotpol(THET, PHI, PP)
Definition: leptonew.f:21300
phint
real function phint(IDUM)
Definition: leptonew.f:16786
gentable
subroutine gentable(LFILE, LEPIN, ENERGY_FIX, PPZ, INTERACTION)
Definition: leptonew.f:9103
luerrm
subroutine luerrm(MERR, CHMESS)
Definition: jetset74ku.f:4872
dexmu
subroutine dexmu(MODE, ISGN, POL, PNU, PWB, Q1, Q2, PH)
Definition: leptonew.f:4546
dadmks
subroutine dadmks(MODE, ISGN, HHV, PNU, PKS, PKK, PPI, JKST)
Definition: leptonew.f:2523
dlower
function dlower(V1)
Definition: leptonew.f:4886
c2_factory::cos
static c2_cos_p< float_type > & cos()
make a *new object
Definition: c2_factory.hh:134
G4DataVector::index
size_t index(const G4double &)
ulalem
function ulalem(Q2)
Definition: jetset74ku.f:4921
test
program test
Definition: Main_HIJING.f:1
dphsks
subroutine dphsks(DGAMT, HV, PN, PKS, PKK, PPI, JKST)
Definition: leptonew.f:5754
c2_function::xmax
float_type xmax() const
return the upper bound of the domain for this function as set by set_domain()
Definition: c2_function.hh:299
lurobo
subroutine lurobo(THE, PHI, BEX, BEY, BEZ)
Definition: leptonew.f:14763
dam4pi
subroutine dam4pi(MNUM, PT, PN, PIM1, PIM2, PIM3, PIM4, AMPLIT, HV)
Definition: leptonew.f:3089
taufil
subroutine taufil
Definition: leptonew.f:21638
photos
subroutine photos(IPARR)
Definition: leptonew.f:18785
luzdis
subroutine luzdis(KFL1, KFL2, PR, Z)
Definition: jetset74ku.f:3120
ns
#define ns
Definition: xmlparse.cc:597
bwig
complex function bwig(S, M, G)
Definition: leptonew.f:1691
dcdmas
function dcdmas(IDENT)
Definition: leptonew.f:3523
fzopn
subroutine fzopn(CHNAME)
Definition: leptonew.f:8608
c2_function::xmin
float_type xmin() const
return the lower bound of the domain for this function as set by set_domain()
Definition: c2_function.hh:297
data
const XML_Char const XML_Char * data
Definition: include/expat.h:268
luedit
subroutine luedit(MEDIT)
Definition: jetset74ku.f:5113
lushow
subroutine lushow(IP1, IP2, QMAX)
Definition: jetset74ku.f:3240
lwbb
subroutine lwbb(ENU)
Definition: leptonew.f:16138
prod5
subroutine prod5(P1, P2, P3, PIA)
Definition: leptonew.f:19104
form4
complex function form4(MNUM, QQ, S1, S2, S3)
Definition: leptonew.f:8216
c2_factory::sin
static c2_sin_p< float_type > & sin()
make a *new object
Definition: c2_factory.hh:132
jetta
subroutine jetta
Definition: leptonew.f:10628
fzini
subroutine fzini
Definition: leptonew.f:8562
c2_factory::exp
static c2_exp_p< float_type > & exp()
make a *new object
Definition: c2_factory.hh:140
phobo3
subroutine phobo3(ANGLE, PVEC)
Definition: leptonew.f:16978
fpikmk
complex function fpikmk(W, XM1, XM2)
Definition: leptonew.f:8479
G4Abla::fd
G4double fd(G4double E)
Definition: G4Abla.cc:3019
leptox
subroutine leptox
Definition: leptonew.f:10815
drcmu
subroutine drcmu(DGAMT, HV, PH, PAA, XA, QP, XN, IELMU)
Definition: leptonew.f:6534
Generated on Wed Apr 30 2014 15:55:18 for Geant4.10 by   doxygen 1.8.7