1 /* copyright(c) 1991-2021 free software foundation, inc.
2 this file is part of the gnu c library.
4 the gnu c library is free software; you can redistribute it and/or
5 modify it under the terms of the gnu lesser general
Public
6 license as published by the free software foundation; either
7 version 2.1 of the license, or(at your option) any later version.
9 the gnu c library is distributed in the hope that it will be useful,
10 but without any warranty; without even the implied warranty of
11 merchantability or fitness for a particular purpose. see the gnu
12 lesser general
Public license for more details.
14 you should have received a copy of the gnu lesser general
Public
15 license along with the gnu c library;
if not, see
16 <https://www.gnu.org/licenses/>. */
19 /* this header is separate from features.h so that the compiler can
20 include it implicitly at the start of every compilation. it must
21 not itself include <features.h> or any other header that includes
22 <features.h> because the
implicit include comes before any feature
23 test macros that may be defined in a source file before it first
24 explicitly includes a system header. gcc knows the name of this
25 header in order to preinclude it. */
27 /* glibc
's intent is to support the IEC 559 math functionality, real
28 and complex. If the GCC (4.9 and later) predefined macros
29 specifying compiler intent are available, use them to determine
30 whether the overall intent is to support these features; otherwise,
31 presume an older compiler has intent to support these features and
32 define these macros by default. */
36 /* wchar_t uses Unicode 10.0.0. Version 10.0 of the Unicode Standard is
37 synchronized with ISO/IEC 10646:2017, fifth edition, plus
38 the following additions from Amendment 1 to the fifth edition:
41 - 3 additional Zanabazar Square characters */
45 C NOTE THAT THE ROUTINES ARE NOT LIKE IN CPC DECK THIS IS HISTORICAL !!
46 C=======================================================================
47 C====================== DECTES : TEST OF TAU DECAY LIBRARY===========
48 C====================== KTORY = 1 : INTERFACE OF KORAL-Z TYPE ==========
49 C====================== KTORY = 2 : INTERFACE OF KORAL-B TYPE =========
50 C=======================================================================
51 C COMMON /PAWC/ BLAN(10000)
52 COMMON / / BLAN(10000)
54 COMMON / INOUT / INUT,IOUT
60 OPEN(IOUT,FILE="./tauola.output")
61 OPEN(INUT,FILE="./dane.dat")
67 SUBROUTINE DECTES(KTORY)
68 C ************************
70 DOUBLE PRECISION HH(4)
71 C SWITCHES FOR TAUOLA;
72 COMMON / JAKI / JAK1,JAK2,JAKP,JAKM,KTOM
75 COMMON / INOUT / INUT,IOUT
76 C LUND TYPE IDENTIFIER FOR A1
78 C /PTAU/ IS USED IN ROUTINE TRALO4
80 COMMON / TAURAD / XK0DEC,ITDKRC
83 C special switch for tests of dGamma/dQ**2 in a1 decay
84 C KEYA1=1 constant width of a1 and rho
85 C KEYA1=2 free choice of rho propagator (defined in function FPIK)
86 C and free choice of a1 mass and width. function g(Q**2)
87 C (see formula 3.48 in Comp. Phys. Comm. 64 (1991) 275)
88 C hard coded both in Monte Carlo and in testing distribution.
89 C KEYA1=3 function g(Q**2) hardcoded in the Monte Carlo
90 C (it is timy to calculate!), but appropriately adjusted in
91 C testing distribution.
92 C-----------------------------------------------------------------------
94 C-----------------------------------------------------------------------
95 C======================================
102 .EQ.
IF (KTORY1) THEN
103 READ( NINP,3000) TESTIT
104 WRITE(NOUT,3000) TESTIT
105 READ( NINP,3001) KAT1,KAT2,KAT3,KAT4,KAT5,KAT6
106 READ( NINP,3002) NEVT,JAK1,JAK2,ITDKRC
107 READ( NINP,3003) PTAU,XK0DEC
109 C======================================
111 WRITE(NOUT,'(6a6/6i6)
')
112 $ 'kat1
','kat2
','kat3
','kat4
','kat5
','kat6
',
113 $ KAT1 , KAT2 , KAT3 , KAT4 , KAT5 , KAT6
114 WRITE(NOUT,'(4a12/4i12)
')
115 $ 'nevt
','jak1
','jak2
','itdkrc
',
116 $ NEVT, JAK1 , JAK2 , ITDKRC
117 WRITE(NOUT,'(2a12/2f12.6)
')
120 C======================================
124 C LUND IDENTIFIER (FOR TAU+) -15
125 .EQ.
IF (KTORY1) THEN
130 C KTO=1 DENOTES TAU DEFINED BY IDFF (I.E. TAU+)
131 C KTO=2 DENOTES THE OPPOSITE (I.E. TAU-)
134 PRINT *, 'for the sake of these tests kto has to be 2
'
135 PRINT *, 'to change tau- to tau+ change idff from -15 to 15
'
138 C TAU POLARIZATION IN ITS RESTFRAME;
142 C TAU MOMENTUM IN GEV;
144 C NUMBER OF EVENTS TO BE GENERATED;
147 PRINT *, 'nevtes=
',NEVTES
148 WRITE(IOUT,7011) KEYA1
150 .EQ.
IF (KTORY1) THEN
151 WRITE(IOUT,7001) JAK,IDFF,POL(3),PTAU
153 WRITE(IOUT,7004) JAK,IDFF,POL(3),PTAU
155 C INITIALISATION OF TAU DECAY PACKAGE TAUOLA
156 C ******************************************
162 .EQ.
IF (KTORY1) THEN
167 C-----------------------------------------------------------------------
169 C-----------------------------------------------------------------------
173 C RESLU INITIALISE THE LUND RECORD
176 .EQ.
IF (KTORY1) THEN
180 CALL DEKAY(KTO+10,HH)
185 .NE.
IF (KTORY1) THEN
192 .EQ.
IF(IPRI1) PRINT *, ' event no:
',NEV,' nevtes:
',NEVTES
195 C-----------------------------------------------------------------------
197 C-----------------------------------------------------------------------
198 .EQ.
IF (KTORY1) THEN
204 7001 FORMAT(//4(/1X,15(5H=====))
205 $ /,' ', 19X,' test of rad. corr in electron decay
',9X,1H ,
206 $ /,' ', 19X,' tests of tau decay routines
',9X,1H ,
207 $ /,' ', 19X,' INTERFACE of the koral-z
TYPE ',9X,1H ,
208 $ 2(/,1X,15(5H=====)),
209 $ /,5X ,'jak =
',I7 ,' key defining decay
TYPE ',9X,1H ,
210 $ /,5X ,'idff =
',I7 ,' lund identifier for first tau
',9X,1H ,
211 $ /,5X ,'pol(3)=
',F7.2,' third component of tau polariz.
',9X,1H ,
212 $ /,5X ,'ptau =
',F7.2,' third component of tau mom. gev
',9X,1H ,
213 $ 2(/,1X,15(5H=====))/)
214 7002 FORMAT(///1X, '===== event no.
',I4,1X,5H=====)
215 7003 FORMAT(5X,'polarimetric vector:
',
216 $ 7X,'hh(1)
',7X,'hh(2)
',7X,'hh(3)
',7X,'hh(4)
',
217 $ /, 5X,' ', 4(1X,F11.8) )
218 7004 FORMAT(//4(/1X,15(5H=====))
219 $ /,' ', 19X,' test of rad. corr in electron decay
',9X,1H ,
220 $ /,' ', 19X,' tests of tau decay routines
',9X,1H ,
221 $ /,' ', 19X,' INTERFACE of the koral-b
TYPE ',9X,1H ,
222 $ 2(/,1X,15(5H=====)),
223 $ /,5X ,'jak =
',I7 ,' key defining decay
TYPE ',9X,1H ,
224 $ /,5X ,'idff =
',I7 ,' lund identifier for first tau
',9X,1H ,
225 $ /,5X ,'pol(3)=
',F7.2,' third component of tau polariz.
',9X,1H ,
226 $ /,5X ,'ptau =
',F7.2,' third component of tau mom. gev
',9X,1H ,
227 $ 2(/,1X,15(5H=====))/)
228 7011 FORMAT(///1X, '=====
TYPE of current
',I4,1X,5H=====)
230 SUBROUTINE CHOICE(MNUM,RR,ICHAN,PROB1,PROB2,PROB3,
231 $ AMRX,GAMRX,AMRA,GAMRA,AMRB,GAMRB)
232 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
233 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
234 * ,AMK,AMKZ,AMKST,GAMKST
236 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
237 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
238 * ,AMK,AMKZ,AMKST,GAMKST
244 C XXXXA CORRESPOND TO S2 CHANNEL !
254 .EQ.
ELSEIF(MNUM1) THEN
263 .EQ.
ELSEIF(MNUM2) THEN
272 .EQ.
ELSEIF(MNUM3) THEN
281 .EQ.
ELSEIF(MNUM4) THEN
290 .EQ.
ELSEIF(MNUM5) THEN
299 .EQ.
ELSEIF(MNUM6) THEN
308 .EQ.
ELSEIF(MNUM7) THEN
317 .EQ.
ELSEIF(MNUM8) THEN
326 .EQ.
ELSEIF(MNUM101) THEN
335 .EQ.
ELSEIF(MNUM102) THEN
355 .LE.
IF (RRPROB1) THEN
357 .LE.
ELSEIF(RR(PROB1+PROB2)) THEN
372 PROB3=1.0-PROB1-PROB2
375 * ----------------------------------------------------------------------
376 * INITIALISATION OF TAU DECAY PARAMETERS and routines
379 * ----------------------------------------------------------------------
381 COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
382 REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
383 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
384 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
385 * ,AMK,AMKZ,AMKST,GAMKST
387 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
388 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
389 * ,AMK,AMKZ,AMKST,GAMKST
390 COMMON / TAUBRA / GAMPRT(30),JLIST(30),NCHAN
391 COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
392 REAL*4 BRA1,BRK0,BRK0B,BRKS
393 PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
394 COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
396 CHARACTER NAMES(NMODE)*31
397 CHARACTER OLDNAMES(7)*31
400 $ bxINIT ='(1x,1h*,g17.8, 16x, a31,a4,a4, 1x,1h*)
'
405 * LIST OF BRANCHING RATIOS
406 CAM normalised to e nu nutau channel
407 CAM enu munu pinu rhonu A1nu Knu K*nu pi
408 CAM DATA JLIST / 1, 2, 3, 4, 5, 6, 7,
409 *AM DATA GAMPRT /1.000,0.9730,0.6054,1.2432,0.8432,0.0432,O.O811,0.616
413 * conventions of particles names
414 * K-,P-,K+, K0,P-,KB, K-,P0,K0
415 * 3, 1,-3 , 4, 1,-4 , 3, 2, 4 ,
416 * P0,P0,K-, K-,P-,P+, P-,KB,P0
417 * 2, 2, 3 , 3, 1,-1 , 1,-4, 2 ,
422 DIMENSION NOPIK(6,NMODE),NPIK(NMODE)
423 *AM outgoing multiplicity and flavors of multi-pion /multi-K modes
432 DATA NOPIK / -1,-1, 1, 2, 0, 0, 2, 2, 2,-1, 0, 0,
433 1 -1,-1, 1, 2, 2, 0, -1,-1,-1, 1, 1, 0,
434 2 -1,-1,-1, 1, 1, 2, -1,-1, 1, 2, 2, 2,
435 3 -3,-1, 3, 0, 0, 0, -4,-1, 4, 0, 0, 0,
436 4 -3, 2,-4, 0, 0, 0, 2, 2,-3, 0, 0, 0,
437 5 -3,-1, 1, 0, 0, 0, -1, 4, 2, 0, 0, 0,
438 6 9,-1, 2, 0, 0, 0, -1, 2, 8, 0, 0, 0,
439 C AJWMOD fix sign bug, 2/22/99
440 7 -3,-4, 0, 0, 0, 0 /
441 * LIST OF BRANCHING RATIOS
444 .LE.
IF (INCHAN) THEN
446 .EQ.
IF(I 1) GAMPRT(I) =0.1800
447 .EQ.
IF(I 2) GAMPRT(I) =0.1751
448 .EQ.
IF(I 3) GAMPRT(I) =0.1110
449 .EQ.
IF(I 4) GAMPRT(I) =0.2515
450 .EQ.
IF(I 5) GAMPRT(I) =0.1790
451 .EQ.
IF(I 6) GAMPRT(I) =0.0071
452 .EQ.
IF(I 7) GAMPRT(I) =0.0134
453 .EQ.
IF(I 8) GAMPRT(I) =0.0450
454 .EQ.
IF(I 9) GAMPRT(I) =0.0100
455 .EQ.
IF(I10) GAMPRT(I) =0.0009
456 .EQ.
IF(I11) GAMPRT(I) =0.0004
457 .EQ.
IF(I12) GAMPRT(I) =0.0003
458 .EQ.
IF(I13) GAMPRT(I) =0.0005
459 .EQ.
IF(I14) GAMPRT(I) =0.0015
460 .EQ.
IF(I15) GAMPRT(I) =0.0015
461 .EQ.
IF(I16) GAMPRT(I) =0.0015
462 .EQ.
IF(I17) GAMPRT(I) =0.0005
463 .EQ.
IF(I18) GAMPRT(I) =0.0050
464 .EQ.
IF(I19) GAMPRT(I) =0.0055
465 .EQ.
IF(I20) GAMPRT(I) =0.0017
466 .EQ.
IF(I21) GAMPRT(I) =0.0013
467 .EQ.
IF(I22) GAMPRT(I) =0.0010
468 .EQ.
IF(I 1) OLDNAMES(I)=' tau- --> e-
'
469 .EQ.
IF(I 2) OLDNAMES(I)=' tau- --> mu-
'
470 .EQ.
IF(I 3) OLDNAMES(I)=' tau- --> pi-
'
471 .EQ.
IF(I 4) OLDNAMES(I)=' tau- --> pi-, pi0
'
472 .EQ.
IF(I 5) OLDNAMES(I)=' tau- --> a1- (two subch)
'
473 .EQ.
IF(I 6) OLDNAMES(I)=' tau- --> k-
'
474 .EQ.
IF(I 7) OLDNAMES(I)=' tau- --> k*- (two subch)
'
475 .EQ.
IF(I 8) NAMES(I-7)=' tau- --> 2pi-, pi0, pi+
'
476 .EQ.
IF(I 9) NAMES(I-7)=' tau- --> 3pi0, pi-
'
477 .EQ.
IF(I10) NAMES(I-7)=' tau- --> 2pi-, pi+, 2pi0
'
478 .EQ.
IF(I11) NAMES(I-7)=' tau- --> 3pi-, 2pi+,
'
479 .EQ.
IF(I12) NAMES(I-7)=' tau- --> 3pi-, 2pi+, pi0
'
480 .EQ.
IF(I13) NAMES(I-7)=' tau- --> 2pi-, pi+, 3pi0
'
481 .EQ.
IF(I14) NAMES(I-7)=' tau- --> k-, pi-, k+
'
482 .EQ.
IF(I15) NAMES(I-7)=' tau- --> k0, pi-, k0b
'
483 .EQ.
IF(I16) NAMES(I-7)=' tau- --> k-, k0, pi0
'
484 .EQ.
IF(I17) NAMES(I-7)=' tau- --> pi0 pi0 k-
'
485 .EQ.
IF(I18) NAMES(I-7)=' tau- --> k- pi- pi+
'
486 .EQ.
IF(I19) NAMES(I-7)=' tau- --> pi- k0b pi0
'
487 .EQ.
IF(I20) NAMES(I-7)=' tau- --> eta pi- pi0
'
488 .EQ.
IF(I21) NAMES(I-7)=' tau- --> pi- pi0 gam
'
489 .EQ.
IF(I22) NAMES(I-7)=' tau- --> k- k0
'
498 IDFFIN(J,I)=NOPIK(J,I)
503 * --- COEFFICIENTS TO FIX RATIO OF:
504 * --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
505 * --- PROBABILITY OF K0 TO BE KS
506 * --- PROBABILITY OF K0B TO BE KS
507 * --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
508 * --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
509 * --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
510 * --- NEGLECTS MASS-PHASE SPACE EFFECTS
524 * ZW 13.04.89 HERE WAS AN ERROR
525 SCABIB = SQRT(1.-CCABIB**2)
527 GAMEL = GFERMI**2*AMTAU**5/(192*PI**3)
529 * CALL DEXAY(-1,pol1)
533 FUNCTION DCDMAS(IDENT)
534 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
535 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
536 * ,AMK,AMKZ,AMKST,GAMKST
538 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
539 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
540 * ,AMK,AMKZ,AMKST,GAMKST
541 .EQ.
IF (IDENT 1) THEN
543 .EQ.
ELSEIF (IDENT-1) THEN
545 .EQ.
ELSEIF (IDENT 2) THEN
547 .EQ.
ELSEIF (IDENT-2) THEN
549 .EQ.
ELSEIF (IDENT 3) THEN
551 .EQ.
ELSEIF (IDENT-3) THEN
553 .EQ.
ELSEIF (IDENT 4) THEN
555 .EQ.
ELSEIF (IDENT-4) THEN
557 .EQ.
ELSEIF (IDENT 8) THEN
559 .EQ.
ELSEIF (IDENT-8) THEN
561 .EQ.
ELSEIF (IDENT 9) THEN
563 .EQ.
ELSEIF (IDENT-9) THEN
566 PRINT *, 'stop in apkmas, wrong ident=
',IDENT
571 FUNCTION LUNPIK(ID,ISGN)
572 COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
573 REAL*4 BRA1,BRK0,BRK0B,BRKS
576 .EQ.
IF (IDENT 1) THEN
578 .EQ.
ELSEIF (IDENT-1) THEN
580 .EQ.
ELSEIF (IDENT 2) THEN
582 .EQ.
ELSEIF (IDENT-2) THEN
584 .EQ.
ELSEIF (IDENT 3) THEN
586 .EQ.
ELSEIF (IDENT-3) THEN
588 .EQ.
ELSEIF (IDENT 4) THEN
590 * K0 --> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
592 .GT.
IF (XIO(1)BRK0) THEN
597 .EQ.
ELSEIF (IDENT-4) THEN
599 * K0B--> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
601 .GT.
IF (XIO(1)BRK0B) THEN
606 .EQ.
ELSEIF (IDENT 8) THEN
608 .EQ.
ELSEIF (IDENT-8) THEN
610 .EQ.
ELSEIF (IDENT 9) THEN
612 .EQ.
ELSEIF (IDENT-9) THEN
615 PRINT *, 'stop in ipkdef, wrong ident=
',IDENT
623 SUBROUTINE TAURDF(KTO)
624 C THIS ROUTINE CAN BE CALLED BEFORE ANY TAU+ OR TAU- EVENT IS GENERATED
625 C IT CAN BE USED TO GENERATE TAU+ AND TAU- SAMPLES OF DIFFERENT
627 COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
628 REAL*4 BRA1,BRK0,BRK0B,BRKS
629 COMMON / TAUBRA / GAMPRT(30),JLIST(30),NCHAN
632 C AJWMOD: Set the BRs for (A1+ -> rho+ pi0) and (K*+ -> K0 pi+)
639 C AJWMOD: Set the BRs for (A1+ -> rho+ pi0) and (K*+ -> K0 pi+)
648 SUBROUTINE INIPHY(XK00)
649 * ----------------------------------------------------------------------
650 * INITIALISATION OF PARAMETERS
651 * USED IN QED and/or GSW ROUTINES
652 * ----------------------------------------------------------------------
653 COMMON / QEDPRM /ALFINV,ALFPI,XK0
654 REAL*8 ALFINV,ALFPI,XK0
657 PI8 = 4.D0*DATAN(1.D0)
659 ALFPI = 1D0/(ALFINV*PI8)
664 C ----------------------------------------------------------------------
665 C INITIALISATION OF MASSES
668 C ----------------------------------------------------------------------
669 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
670 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
671 * ,AMK,AMKZ,AMKST,GAMKST
673 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
674 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
675 * ,AMK,AMKZ,AMKST,GAMKST
677 C IN-COMING / OUT-GOING FERMION MASSES
679 C --- let us update tau mass ...
687 * MASSES USED IN TAU DECAYS
701 C IN-COMING / OUT-GOING FERMION MASSES
702 !! AMNUTA = PKORB(1,2)
703 !! AMNUE = PKORB(1,4)
704 !! AMNUMU = PKORB(1,6)
706 C MASSES USED IN TAU DECAYS Cleo settings
707 !! AMPIZ = PKORB(1,7)
710 !! GAMRO = PKORB(2,9)
711 AMA1 = 1.275 !! PKORB(1,10)
712 GAMA1 = 0.615 !! PKORB(2,10)
714 !! AMKZ = PKORB(1,12)
715 !! AMKST = PKORB(1,13)
716 !! GAMKST = PKORB(2,13)
723 C SUBSITUTE OF tau PRODUCTION GENERATOR
725 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
726 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
727 * ,AMK,AMKZ,AMKST,GAMKST
729 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
730 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
731 * ,AMK,AMKZ,AMKST,GAMKST
733 C positions of taus in the LUND common block
734 C it will be used by TAUOLA output routines.
735 COMMON /TAUPOS / NPA,NPB
736 DIMENSION XPB1(4),XPB2(4),AQF1(4),AQF2(4)
738 C --- DEFINING DUMMY EVENTS MOMENTA
748 CALL TRALO4(1,AQF1,AQF1,AM)
749 CALL TRALO4(2,AQF2,AQF2,AM)
750 C --- BEAMS MOMENTA AND IDENTIFIERS
751 KFB1= 11*IDFF/IABS(IDFF)
752 KFB2=-11*IDFF/IABS(IDFF)
756 $ XPB1(3)= AQF1(4)*AQF1(3)/ABS(AQF1(3))
760 $ XPB2(3)= AQF2(4)*AQF2(3)/ABS(AQF2(3))
761 C --- Position of first and second tau in LUND common
764 C --- FILL TO LUND COMMON
765 CALL FILHEP( 1,3, KFB1,0,0,0,0,XPB1, AMEL,.TRUE.)
766 CALL FILHEP( 2,3, KFB2,0,0,0,0,XPB2, AMEL,.TRUE.)
767 CALL FILHEP(NPA,1, IDFF,1,2,0,0,AQF1,AMTAU,.TRUE.)
768 CALL FILHEP(NPB,1,-IDFF,1,2,0,0,AQF2,AMTAU,.TRUE.)
770 SUBROUTINE TRALO4(KTO,P,Q,AM)
771 C **************************
772 C SUBSITUTE OF TRALO4
775 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
776 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
777 * ,AMK,AMKZ,AMKST,GAMKST
779 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
780 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
781 * ,AMK,AMKZ,AMKST,GAMKST
784 ETAU=SQRT(PTAU**2+AMTAU**2)
785 EXE=(ETAU+PTAU)/AMTAU
786 .EQ.
IF(KTO2) EXE=(ETAU-PTAU)/AMTAU
788 C ======================================================================
789 C END OF THE TEST JOB
790 C ======================================================================
792 SUBROUTINE FILHEP(N,IST,ID,JMO1,JMO2,JDA1,JDA2,P4,PINV,PHFLAG)
793 C ----------------------------------------------------------------------
794 C this subroutine fills one entry into the HEPEVT common
795 C and updates the information for affected mother entries
797 C written by Martin W. Gruenewald (91/01/28)
799 C called by : ZTOHEP,BTOHEP,DWLUxy
800 C ----------------------------------------------------------------------
802 C this is the hepevt class in old style. No d_h_ class pre-name
804 PARAMETER (NMXHEP=10000)
805 REAL*8 phep, vhep ! to be real*4/ *8 depending on host
806 INTEGER nevhep,nhep,isthep,idhep,jmohep,
809 $ nevhep, ! serial number
810 $ nhep, ! number of particles
811 $ isthep(nmxhep), ! status code
812 $ idhep(nmxhep), ! particle ident KF
813 $ jmohep(2,nmxhep), ! parent particles
814 $ jdahep(2,nmxhep), ! childreen particles
815 $ phep(5,nmxhep), ! four-momentum, mass [GeV]
816 $ vhep(4,nmxhep) ! vertex [mm]
817 * ----------------------------------------------------------------------
820 $ qedrad(nmxhep) ! Photos flag
821 * ----------------------------------------------------------------------
823 C PARAMETER (NMXHEP=2000)
824 C COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
825 C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
827 C COMMON/PHOQED/QEDRAD(NMXHEP)
839 .GT.
ELSE IF (N0) THEN
850 .LE..OR..GT.
IF ((IHEP0)(IHEPNMXHEP)) RETURN
857 .LT.
IF(JMO10)JMOHEP(1,IHEP)=JMOHEP(1,IHEP)+IHEP
859 .LT.
IF(JMO20)JMOHEP(2,IHEP)=JMOHEP(2,IHEP)+IHEP
866 C KORAL-B and KORAL-Z do not provide vertex and/or lifetime informations
874 DO IP=JMOHEP(1,IHEP),JMOHEP(2,IHEP)
877 C if there is a daughter at IHEP, mother entry at IP has decayed
878 .EQ.
IF(ISTHEP(IP)1)ISTHEP(IP)=2
880 C and daughter pointers of mother entry must be updated
881 .EQ.
IF(JDAHEP(1,IP)0)THEN
885 JDAHEP(2,IP)=MAX(IHEP,JDAHEP(2,IP))