5 * Revision 1.1.1.1 1995/10/24 10:21:13 cernlib
9 #include "geant321/pilot.h"
10 *CMZ : 3.21/02 29/03/94 15.41.40 by S.Giani
12 SUBROUTINE HIGXPT(IPPP,NFL,AVERN)
14 C *** GENERATION OF X- AND PT- VALUES FOR ALL PRODUCED PARTICLES ***
15 C *** NVE 02-MAY-1988 CERN GENEVA ***
17 C ORIGIN : H.FESEFELDT 11-OCT-1987
19 C A SIMPLE SINGLE VARIABLE DESCRIPTION E D3S/DP3= F(Q) WITH
20 C Q**2 = (M*X)**2 + PT**2 IS USED. FINAL STATE KINEMATIC IS PRODUCED
21 C BY AN FF-TYPE ITERATIVE CASCADE METHOD
23 #include "geant321/s_defcom.inc"
24 #include "geant321/s_genio.inc"
27 REAL MASPAR,LAMB,NUCSUP
28 DIMENSION MASPAR(8),BP(8),PTEX(8),C1PAR(5),G1PAR(5),TAVAI(2),
29 $ SIDE(MXGKCU),IAVAI(2),BINL(20),DNDL(20),TWSUP(8),
30 $ NUCSUP(6),PSUP(6),IPAX(100)
32 DATA MASPAR/0.75,0.70,0.65,0.60,0.50,0.40,0.20,0.10/
33 DATA BP/4.00,2.50,2.20,3.00,3.00,1.70,3.50,3.50/
34 DATA PTEX/1.70,1.70,1.50,1.70,1.40,1.20,1.70,1.20/
35 DATA C1PAR/0.6,0.6,0.35,0.15,0.10/
36 DATA G1PAR/2.6,2.6,1.80,1.30,1.20/
37 DATA BINL/0.,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0,1.11,1.25
38 $ ,1.43,1.67,2.0,2.5,3.33,5.00,10.00/
39 DATA TWSUP/1.,1.,0.7,0.5,0.3,0.2,0.1,0.0/
40 DATA NUCSUP/1.00,0.7,0.5,0.4,0.5,0.5/
41 DATA PSUP/3.,6.,20.,50.,100.,1000./
44 C** FOR ANNIHILATION INTERACTIONS INTRODUCE PROPER KINEMATICS
46 CALL CORANH(NIHIL,NFL)
49 C** CHECK FIRST MASS-INDICES
58 IF(IPA(I).EQ.0) GOTO 1
62 CALL VZERO(IPA(NT+1),MXGKCU-NT)
63 CALL UCOPY(IPA(1),IPAX(1),100)
65 C** FOR LOW MULTIPLICITY USE TWO-BODY RESONANCE MODEL OR SINGLE/DOUBLE
66 C** DIFFRACTION MODEL (--> HIGCLU (--> TWOB (--> COSCAT)))
68 CFA=0.025*((ATNO2-1.)/120.)*EXP(-(ATNO2-1.)/120.)
69 IF(NIHIL.GT.0) GOTO 200
74 IF(IPART.GE.10.AND.IPART.LE.13.AND.RAN.LT.0.5) GOTO 200
78 IF(RAN.GT.WSUP) GOTO 200
81 IF(EK.GT.RAN) GOTO 200
82 60 CALL UCOPY(IPAX,IPA,100)
83 CALL HIGCLU(IPPP,NFL,AVERN)
86 C** SET EFFECTIVE 4-MOMENTUM OF PRIMARY PARTICLE
105 PV( 8,MXGKPV-1)=IPART
107 PV(10,MXGKPV-1)=USERW
110 C** SOME RANDOMISATION OF ORDER OF FINAL STATE PARTICLES
114 IPX=IFIX(3.+RNDM(1)*(NT-2.))
120 C** DISTRIBUTE IN FORWARD AND BACKWARD HEMISPHERE IN CMS
126 IF(IPART.LT.10.OR.IPART.GT.13) GOTO 53
128 IF(RNDM(1).LT.0.9) GOTO 53
133 IF(IPART.LT.10.OR.IPART.EQ.14.OR.IPART.EQ.16) GOTO 532
135 IF(IPA1.LT.10.OR.IPA1.EQ.14.OR.IPA1.EQ.16) GOTO 531
139 IF(IPA1.LT.10.OR.IPA1.EQ.14.OR.IPA1.EQ.16) GOTO 532
145 IF(RNDM(1).LT.0.5) SIDE(I)=-1.
146 IF(SIDE(I).LT.-0.5) NTB=NTB+1
151 IF(RS.LT.(2.0+RNDM(1))) TB=(2.*NTB+NT)/2.
153 C** ADD PARTICLES FROM INTRANUCLEAR CASCADE
155 AFC=0.312+0.200*LOG(LOG(S))+S**1.5/6000.
156 IF(AFC.GT.0.5) AFC=0.5
157 XTARG=AFC*(ATNO2**0.33 -1.0)*TB
158 IF(XTARG.LE.0.) XTARG=0.01
159 C** SOME EXTRA STRANGE PARTICLES
161 CALL POISSO(XSTRAN,NSTRAN)
162 C** NUCLEONS AND PIONS
164 IF(P.LE.PSUP(IPX)) GOTO 882
167 882 XPNHMF = XTARG*NUCSUP(IPX)
168 XSHHMF = XTARG - XPNHMF
169 IF(XSHHMF.LT.0.01) XSHHMF=0.01
170 IF(XPNHMF.LT.0.01) XPNHMF=0.01
173 RSHHMF=SSHHMF**2/XSHHMF
174 RPNHMF=SPNHMF**2/XPNHMF
175 IF(RSHHMF.LT.1.1) THEN
176 CALL POISSO(XSHHMF,NSHHMF)
179 RSHHMF=XSHHMF/(RSHHMF-1.)
180 IF(RSHHMF.LE.20.) THEN
181 CALL SVGAM7(RSHHMF,XHMF)
183 KRSHMF=IFIX(RSHHMF+0.5)
184 CALL SVERL2(KRSHMF,XHMF)
186 XSHHMF=XHMF*XSHHMF/RSHHMF
187 CALL POISSO(XSHHMF,NSHHMF)
189 541 IF(RPNHMF.LE.1.1) THEN
190 CALL POISSO(XPNHMF,NPNHMF)
193 RPNHMF=XPNHMF/(RPNHMF-1.)
194 IF(RPNHMF.LE.20.) THEN
195 CALL SVGAM7(RPNHMF,XHMF)
197 KRPHMF=IFIX(RPNHMF+0.5)
198 CALL SVERL2(KRPHMF,XHMF)
200 XPNHMF=XHMF*XPNHMF/RPNHMF
201 CALL POISSO(XPNHMF,NPNHMF)
203 542 NTARG=NSHHMF+NPNHMF+NSTRAN
209 IF (NPRT(4)) WRITE(NEWBCD,3001) NTARG,NT
211 IF(NTARG.EQ.0) GOTO 51
213 C** CHECK NUMBER OF EXTRA NUCLEONS AND PIONS
216 IF(NPNHMF.GT.0) GOTO 52
217 IF(NSTRAN.GT.0) GOTO 59
219 IPA(I)=-(7+IFIX(RNDM(1)*3.0))
221 IF(RNDM(2).LT.0.2) THEN
230 IF(RNDM(1).GT.PNRAT) IPA(I)=-14
235 59 CALL GRNDM(RNDM,2)
237 IF(RNDM(1).GT.0.14) IPA(I)=-21
238 IF(RNDM(1).GT.0.20) IPA(I)=-10
239 IF(RNDM(1).GT.0.43) IPA(I)=-11
240 IF(RNDM(1).GT.0.66) IPA(I)=-12
241 IF(RNDM(1).GT.0.89) IPA(I)=-13
243 IF(RNDM(2).LT.0.2) THEN
252 C** CHOOSE MASSES AND CHARGES FOR ALL PARTICLES
259 IF(PV(5,I).LT.0.) PV(7,I)=-1.
263 C** CHECK AVAILABLE KINETIC ENERGY, IN THIS MODEL CONSERVATION OF
264 C** KINETIC ENERGY IN FORWARD AND BACKWARD HEMISPHERE IS ASSUMED
266 6 IF(NT.LE.1) GOTO 60
268 TAVAI(2)=(TARG+1.)*RS/2.
273 IF(SIDE(I).LT.0.) L=2
275 TAVAI(L)=TAVAI(L)-ABS(PV(5,I))
280 $ WRITE(NEWBCD,3002) TAVAI,IAVAI,(IPA(I),SIDE(I),I=1,NTH)
281 IF(IAVAI(1).LE.0) GOTO 60
282 IF(IAVAI(2).LE.0) GOTO 60
283 IF(TAVAI(1).GT.0.) GOTO 11
285 ISKIP=IFIX(RNDM(1)*(IAVAI(1)-1))+1
289 IF(SIDE(II).LT.0.) GOTO 10
291 IF(IS.NE.ISKIP) GOTO 10
307 11 IF(TAVAI(2).GT.0.) GOTO 15
309 ISKIP=IFIX(RNDM(1)*(IAVAI(2)-1))+1
313 IF(SIDE(II).GT.0.) GOTO 14
315 IF(IS.NE.ISKIP) GOTO 14
316 IF(SIDE(II).LT.-1.5) NTARG=NTARG-1
317 IF(NTARG.LT.0) NTARG=0
333 15 IF(NT.LE.1) GOTO 60
341 C** NOW THE PREPARATION IS FINISHED.
342 C** DEFINE INITIAL STATE VECTORS FOR LORENTZ TRANSFORMATIONS.
347 PV( 4,MX1)=SQRT(P*P+AMAS*AMAS)
357 PV( 4,MX4)=MP*(1.+TARG)
365 CALL ADD(MX1,MX2,MX3)
366 CALL ADD(MX4,MX1,MX4)
367 CALL LOR(MX1,MX3,MX1)
368 CALL LOR(MX2,MX3,MX2)
370 C** MAIN LOOP FOR 4-MOMENTUM GENERATION , SEE PITHA-REPORT (AACHEN)
371 C** FOR A DETAILED DESCRIPTION OF THE METHOD.
387 C** COUNT NUMBER OF BACKWARD NUCLEONS
392 IF(RNDM(1).LT.0.2) GOTO 301
393 ELSE IF(IPA1.GE.14) THEN
397 IF(SIDE(I).GT.-1.5) GOTO 38
398 IF(IPA1.EQ.14.OR.IPA1.EQ.16) GOTO 301
401 IF(NPG.GT.18) GOTO 38
402 RMG0=RMG0+ABS(PV(5,I))
410 IF(SIDE(I).LT.-1.5) J=7
411 IF(J.EQ.7.AND.IPA1.GE.14) J=8
413 C** SET PT - AND PHI VALUES, THEY ARE CHANGED SOMEWHAT IN THE ITERATION
414 C** LOOP, SET MASS PARAMETER FOR LAMBDA FRAGMENTATION MODEL
428 IF(PT.LT.0.001) PT=0.001
435 73 BINL(J)=RLMAX*(J-1)/19.
437 IF(SIDE(I).LT.0.) THEN
443 C** START OF BIG ITERATION LOOP
446 IF(NTRIAL.GT. 2) GOTO 169
449 X=(BINL(L)+BINL(L-1))/2.
450 IF(PV(10,I).LT.0.001) PV(10,I)=0.001
451 IF(X.GT.1./PV(10,I)) GOTO 17
453 DNDL(L)=ASPAR/SQRT((1.+(ASPAR*X)**2)**3)
454 DNDL(L)=ET*DNDL(L)/SQRT((X*PV(10,I)*ET)**2+PV(10,I)**2
457 17 DNDL(L)=DNDL(L-1)+DNDL(L)
459 31 CALL GRNDM(RNDM,1)
462 IF(RAN.LT.DNDL(L)) GOTO 19
465 C** START OF SMALL ITERATION LOOP
471 LAMB=BINL(L-1)+RAN*DX/2.
474 X=X*SIDE(I)/ABS(SIDE(I))
476 PV(4,I)=PV(3,I)**2+PV(10,I)**2+PV(5,I)**2
477 PV(4,I)=SQRT(PV(4,I))
478 IF(SIDE(I).LT.0.) GOTO 165
482 IF(EKIN.LT.0.) EKIN=0.04*ABS(RAN)
483 PV(4,I)=ABS(PV(5,I))+EKIN
484 RNVE=ABS(PV(4,I)**2-PV(5,I)**2)
488 IF (PP1 .GE. 1.0E-6) GO TO 8000
492 PV(1,I)=PP*SIN(RTHNVE)*COS(PHINVE)
493 PV(2,I)=PP*SIN(RTHNVE)*SIN(PHINVE)
494 PV(3,I)=PP*COS(RTHNVE)
497 PV(3,I) = PP**2 - PV(10,I)**2
498 IF(PV(3,I).LT.0.) PV(3,I)=0.
499 PV(3,I) = SQRT(PV(3,I))*SIDE(I)/ABS(SIDE(I))
504 20 EKIN=EKIN1+PV(4,I)-ABS(PV(5,I))
505 IF(EKIN.LT.0.95*TAVAI(1)) GOTO 161
506 IF(NTRI.GT. 5) GOTO 167
507 PV(10,I)=PV(10,I)*0.9
508 PV( 1,I)=PV( 1,I)*0.9
509 PV( 2,I)=PV( 2,I)*0.9
510 DNDL(20)=DNDL(20)*0.9
511 IF((TAVAI(2)-ABS(PV(5,I))).LT.0.) GOTO 31
513 TAVAI(1)=TAVAI(1)+ABS(PV(5,I))
514 TAVAI(2)=TAVAI(2)-ABS(PV(5,I))
516 161 CALL ADD(MX5,I,MX5)
517 EKIN1=EKIN1+PV(4,I)-ABS(PV(5,I))
519 165 EKIN=EKIN2+PV(4,I)-ABS(PV(5,I))
520 XXX=0.95+0.05*TARG/20.
521 IF(XXX.GT.0.999) X=0.999
522 IF(EKIN.LT.XXX*TAVAI(2)) GOTO 166
523 IF(NTRI.GT. 5) GOTO 167
524 PV(10,I)=PV(10,I)*0.9
525 PV( 1,I)=PV( 1,I)*0.9
526 PV( 2,I)=PV( 2,I)*0.9
527 DNDL(20)=DNDL(20)*0.9
528 IF((TAVAI(1)-ABS(PV(5,I))).LT.0.) GOTO 31
530 TAVAI(1)=TAVAI(1)-ABS(PV(5,I))
531 TAVAI(2)=TAVAI(2)+ABS(PV(5,I))
533 166 CALL ADD(MX6,I,MX6)
534 EKIN2=EKIN2+PV(4,I)-ABS(PV(5,I))
535 163 CALL ADD(MX5,MX6,MX7)
537 CALL ANG(MX7,MX9,COST,PHIS)
538 IF(PV(2,MX7).LT.0.) PHIS=TWPI-PHIS
542 IF(PHI.GT.TWPI) PHI=PHI-TWPI
543 IF(PHI.LT.0.) PHI=TWPI-PHI
546 C** PARTICLE MOMENTUM ZERO, REDUCE KINETIC ENERGY OF ALL OTHER
555 IF(ABS(IPA(L)).GE.14.AND.SIDE(L).LT.0.) GOTO 168
556 PV(4,L)=PV(4,L)*0.95+0.05*ABS(PV(5,L))
557 IF(PV(4,L).LT.ABS(PV(5,L))) PV(4,L)=ABS(PV(5,L))
558 RNVE=ABS(PV(4,L)**2-PV(5,L)**2)
562 IF (PP1 .GE. 1.0E-6) GO TO 8002
566 PV(1,L)=PP*SIN(RTHNVE)*COS(PHINVE)
567 PV(2,L)=PP*SIN(RTHNVE)*SIN(PHINVE)
568 PV(3,L)=PP*COS(RTHNVE)
571 PV(1,L)=PV(1,L)*PP/PP1
572 PV(2,L)=PV(2,L)*PP/PP1
573 PV(3,L)=PV(3,L)*PP/PP1
576 PV(10,L)=SQRT(PV(1,L)**2+PV(2,L)**2)
577 IF(SIDE(L).LT.0.) GOTO 164
578 EKIN1=EKIN1+PV(4,L)-ABS(PV(5,L))
581 164 EKIN2=EKIN2+PV(4,L)-ABS(PV(5,L))
584 C *** NEXT STMT. CHANGED TO PREVENT FROM INFINITE LOOPING ***
585 C************* GOTO 38
588 C** SKIP PARTICLE, IF NOT ENOUGH ENERGY
598 IF(IPA(I).EQ.0) GOTO 320
607 C** BACKWARD NUCLEONS PRODUCED WITH A CLUSTER MODEL
609 IF(NPG.EQ.0) GOTO 330
611 IF(NPG.EQ.1) GOTO 310
619 IF(DUMNVE.EQ.0.) DUMNVE=1.0E-10
620 RMG=RMG0+RMG**CPAR/DUMNVE
624 IF(EK.GT.5.) GOTO 311
625 EKIT1=EKIT1*EK**2/25.
626 EKIT2=EKIT2*EK**2/25.
627 311 A=(1.-GA)/(EKIT2**(1.-GA)-EKIT1**(1.-GA))
629 IF(SIDE(I).GT.-2.5) GOTO 312
631 EKIT=(RNDM(1)*(1.-GA)/A+EKIT1**(1.-GA))**(1./(1.-GA))
633 DUMNVE=ABS(PV(4,I)**2-PV(5,I)**2)
635 COST=LOG(2.23*RNDM(2)+0.383)/0.96
636 IF(COST.LT.-1.) COST=-1.
637 IF(COST.GT. 1.) COST= 1.
639 IF(DUMNVE.LT.0.0) DUMNVE=0.0
642 PV(1,I)=PP*SINT*SIN(PHI)
643 PV(2,I)=PP*SINT*COS(PHI)
649 $ WRITE(NEWBCD,2002) NTRIAL,EKIN1,EKIN2,TAVAI(1),TAVAI(2)
650 175 IF (.NOT.NPRT(4)) GOTO 36
651 CALL ADD(MX5,MX6,MX7)
652 EKIN1=PV(4,MX1)+PV(4,MX2)
653 EKIN2=PV(4,MX5)+PV(4,MX6)
654 WRITE(NEWBCD,2000) EKIN1,EKIN2
656 WRITE(NEWBCD,2001) I,(PV(J,I),J=1,4)
658 WRITE(NEWBCD,2001) I,(PV(J,I),J=1,4)
660 WRITE(NEWBCD,2001) I,(PV(J,I),J=1,5)
662 WRITE(NEWBCD,2001) I,(PV(J,I),J=1,5)
664 37 WRITE(NEWBCD,2001) I,(PV(J,I),J=1,10),IPA(I),SIDE(I)
666 C** LORENTZ TRANSFORMATION IN LAB SYSTEM
668 36 IF(NT.LE.2) GOTO 60
671 IF(PV(5,I).GT.0.5) TARG=TARG+1.
674 IF(TARG.LT.0.5) TARG=1.
675 IF(LEAD.EQ.0) GOTO 6085
677 IF(ABS(IPA(I)).EQ.LEAD) GOTO 6085
680 IF(LEAD.GE.14.AND.ABS(IPA(2)).GE.14) I=2
681 IF(LEAD.LT.14.AND.ABS(IPA(2)).LT.14) I=2
683 EKIN=PV(4,I)-ABS(PV(5,I))
686 IF(PV(5,I).LT.0.) PV(7,I)=-1.
691 RNVE=ABS(PV(4,I)**2-PV(5,I)**2)
693 PV(1,I)=PP1*PV(1,I)/PP
694 PV(2,I)=PP1*PV(2,I)/PP
695 PV(3,I)=PP1*PV(3,I)/PP
700 PV(4,MX4)=SQRT(P*P+AMAS*AMAS)
702 EKIN0=PV(4,MX4)-PV(5,MX4)
708 EKIN=PV(4,MX4)+PV(4,MX5)
710 IF (NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,5)
712 IF (NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,5)
713 CALL ADD(MX4,MX5,MX6)
714 CALL LOR(MX4,MX6,MX4)
715 CALL LOR(MX5,MX6,MX5)
716 TECM=PV(4,MX4)+PV(4,MX5)
725 IF (NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,10),IPA(I),SIDE(I)
727 EKIN1=EKIN1+PV(4,I)-PV(5,I)
732 IF(NPG.GT.18) GOTO 597
741 CALL LOR(MX7,MX5,MX7)
742 599 EKIN=EKIN+PV(4,MX7)-PV(5,MX7)
743 CALL ANG(MX8,MX4,COST,TETA)
744 IF (NPRT(4)) WRITE(NEWBCD,2003) TETA,EKIN0,EKIN1,EKIN
746 C** MAKE SHURE, THAT KINETIC ENERGIES ARE CORRECT.
747 C** EKIN= KINETIC ENERGY THEORETICALLY
748 C** EKIN1= KINETIC ENERGY SIMULATED
750 597 IF(EKIN1.EQ.0.) GOTO 600
762 RNVE=ABS(PV(4,I)**2-PV(5,I)**2)
766 IF (PP1 .GE. 1.0E-6) GO TO 8008
770 PV(1,I)=PP*SIN(RTHNVE)*COS(PHINVE)
771 PV(2,I)=PP*SIN(RTHNVE)*SIN(PHINVE)
772 PV(3,I)=PP*COS(RTHNVE)
775 PV(1,I)=PV(1,I)*PP/PP1
776 PV(2,I)=PV(2,I)*PP/PP1
777 PV(3,I)=PV(3,I)*PP/PP1
783 CALL ANG(MX7,MX4,COST,TETA)
784 IF (NPRT(4)) WRITE(NEWBCD,2003) TETA,EKIN0,EKIN1
786 C** ROTATE IN DIRECTION OF Z-AXIS, THIS DOES DISTURB IN SOME WAY OUR
787 C** INCLUSIVE DISTRIBUTIONS, BUT IT IS NESSACARY FOR MOMENTUM CONSER-
796 596 CALL ADD(MX7,I,MX7)
798 C** SOME SMEARING IN TRANSVERSE DIRECTION FROM FERMI MOTION
800 * call rannor(ran1,ran2)
808 PV(1,MX7)=PV(1,MX7)+RAN1*0.020*TARG
809 PV(2,MX7)=PV(2,MX7)+RAN2*0.020*TARG
810 CALL DEFS(MX4,MX7,MX8)
818 595 CALL ADD(MX7,I,MX7)
819 CALL ANG(MX7,MX4,COST,TETA)
820 IF (NPRT(4)) WRITE(NEWBCD,2003) TETA
822 C** ROTATE IN DIRECTION OF PRIMARY PARTICLE, SUBTRACT BINDING ENERGIES
823 C** AND MAKE SOME FURTHER CORRECTIONS IF REQUIRED (STEEP, STEEQ)
830 CALL DEFS1(I,MXGKPV-1,I)
831 IF (NPRT(4)) WRITE(NEWBCD,2001) I,(PV(J,I),J=1,10),IPA(I),SIDE(I)
832 IF(ATNO2.LT.1.5) GOTO 21
834 EKIN=PV(4,I)-ABS(PV(5,I))
836 EKIN=EKIN-CFA*(1.+0.5*RAN)
837 IF (EKIN .LT. 1.0E-6) EKIN=1.0E-6
839 DEKIN=DEKIN+EKIN*(1.-XXH)
841 IF(ABS(IPA(I)).GE.7.AND.ABS(IPA(I)).LE.9) NPIONS=NPIONS+1
842 IF(ABS(IPA(I)).GE.7.AND.ABS(IPA(I)).LE.9) EK1=EK1+EKIN
843 PP1=SQRT(EKIN*(EKIN+2.*ABS(PV(5,I))))
844 PV(4,I)=EKIN+ABS(PV(5,I))
846 IF (PP .GE. 1.0E-6) GO TO 8010
850 PV(1,I)=PP1*SIN(RTHNVE)*COS(PHINVE)
851 PV(2,I)=PP1*SIN(RTHNVE)*SIN(PHINVE)
852 PV(3,I)=PP1*COS(RTHNVE)
855 PV(1,I)=PV(1,I)*PP1/PP
856 PV(2,I)=PV(2,I)*PP1/PP
857 PV(3,I)=PV(3,I)*PP1/PP
861 IF(EK1.EQ.0.) GOTO 23
862 IF(NPIONS.EQ.0) GOTO 23
865 IF(ABS(IPA(I)).LT.7.OR.ABS(IPA(I)).GT.9) GOTO 22
867 EKIN=PV(4,I)-ABS(PV(5,I))
869 IF (EKIN .LT. 1.0E-6) EKIN=1.0E-6
870 PP1=SQRT(EKIN*(EKIN+2.*ABS(PV(5,I))))
871 PV(4,I)=EKIN+ABS(PV(5,I))
873 IF (PP .GE. 1.0E-6) GO TO 8012
877 PV(1,I)=PP1*SIN(RTHNVE)*COS(PHINVE)
878 PV(2,I)=PP1*SIN(RTHNVE)*SIN(PHINVE)
879 PV(3,I)=PP1*COS(RTHNVE)
882 PV(1,I)=PV(1,I)*PP1/PP
883 PV(2,I)=PV(2,I)*PP1/PP
884 PV(3,I)=PV(3,I)*PP1/PP
889 C** ADD BLACK TRACK PARTICLES, THE TOTAL NUMBER OF PARTICLES PRODUCED
890 C** IS RESTRICTED TO 198, THIS MAY HAVE INFLUENCE ON VERY HIGH ENERGY
891 C** FIRST PROTONS AND NEUTRONS
893 23 IF(ATNO2.LT.1.5) GOTO 40
896 IF(RNDM(1).LT.SPROB) GOTO 40
899 IF(TEX.LT.0.001) GOTO 445
900 BLACK=(1.5+1.25*TARG)*ENP(1)/(ENP(1)+ENP(3))
901 CALL POISSO(BLACK,NBL)
902 IF (NPRT(4)) WRITE(NEWBCD,3003) NBL,TEX
903 IF(IFIX(TARG)+NBL.GT.ATNO2) NBL=ATNO2-TARG
904 IF(NT+NBL.GT.MXGKPV-10) NBL=MXGKPV-10-NT
905 IF(NBL.LE.0) GOTO 445
911 IF(RNDM(1).LT.SPROB) GOTO 441
912 IF(NT.EQ.MXGKPV-10) GOTO 441
913 IF(EKIN2.GT.TEX) GOTO 443
917 EKIN1=-EKIN*LOG(RAN1)-CFA*(1.+0.5*RAN2)
918 IF(EKIN1.LT.0.0) EKIN1=-0.010*LOG(RAN1)
921 IF(EKIN2.GT.TEX) EKIN1=TEX-(EKIN2-EKIN1)
922 IF (EKIN1 .LT. 0.0) EKIN1=1.0E-6
926 IF(RNDM(1).GT.PNRAT) IPA1=14
930 SINT=SQRT(ABS(1.-COST*COST))
934 PV(5,NT)=ABS(RMASS(IPA1))
935 PV(6,NT)=RCHARG(IPA1)
937 PV(4,NT)=EKIN1+PV(5,NT)
938 RNVE=ABS(PV(4,NT)**2-PV(5,NT)**2)
940 PV(1,NT)=PP*SINT*SIN(PHI)
941 PV(2,NT)=PP*SINT*COS(PHI)
944 443 IF(ATNO2.LT.10.) GOTO 445
945 IF(EK.GT.2.0) GOTO 445
949 IF(EKA.GT.1.) EKA=EKA*EKA
950 IF(EKA.LT.0.1) EKA=0.1
951 IKA=3.6*EXP((ZNO2**2/ATNO2-35.56)/6.45)/EKA
952 IF(IKA.LE.0) GO TO 445
955 IF(IPA(II).NE.-14) GOTO 444
958 PV(5,II)=ABS(RMASS(IPA1))
959 PV(6,II)=RCHARG(IPA1)
961 IF(KK.GT.IKA) GOTO 445
964 C** THEN ALSO DEUTERONS, TRITONS AND ALPHAS
967 IF(TEX.LT.0.001) GOTO 40
968 BLACK=(1.5+1.25*TARG)*ENP(3)/(ENP(1)+ENP(3))
969 CALL POISSO(BLACK,NBL)
970 IF(NT+NBL.GT.MXGKPV-10) NBL=MXGKPV-10-NT
975 IF (NPRT(4)) WRITE(NEWBCD,3004) NBL,TEX
978 IF(RNDM(1).LT.SPROB) GOTO 442
979 IF(NT.EQ.MXGKPV-10) GOTO 442
980 IF(EKIN2.GT.TEX) GOTO 40
984 EKIN1=-EKIN*LOG(RAN1)-CFA*(1.+0.5*RAN2)
985 IF(EKIN1.LT.0.0) EKIN1=-0.010*LOG(RAN1)
988 IF(EKIN2.GT.TEX) EKIN1=TEX-(EKIN2-EKIN1)
989 IF (EKIN1 .LT. 0.0) EKIN1=1.0E-6
992 SINT=SQRT(ABS(1.-COST*COST))
996 IF(RAN.GT.0.60) IPA(NT+1)=-31
997 IF(RAN.GT.0.90) IPA(NT+1)=-32
999 PV(5,NT+1)=(ABS(IPA(NT+1))-28)*MP
1000 SPALL=SPALL+PV(5,NT+1)*1.066
1001 IF(SPALL.GT.ATNO2) GOTO 40
1004 IF(IPA(NT).EQ.-32) PV(6,NT)=2.
1006 PV(4,NT)=PV(5,NT)+EKIN1
1007 RNVE=ABS(PV(4,NT)**2-PV(5,NT)**2)
1009 PV(1,NT)=PP*SINT*SIN(PHI)
1010 PV(2,NT)=PP*SINT*COS(PHI)
1014 C** STORE ON EVENT COMMON
1016 40 CALL GRNDM(RNDM,1)
1017 IF(RS.GT.(4.+RNDM(1))) GOTO 42
1020 IF(ETB.LT.P) GOTO 41
1022 PV(4,I)=SQRT(PV(5,I)**2+ETF**2)
1028 42 EKIN=PV(4,MXGKPV)-ABS(PV(5,MXGKPV))
1029 EKIN1=PV(4,MXGKPV-1)-ABS(PV(5,MXGKPV-1))
1034 TOF=TOF-TOF1*LOG(RAN)
1036 IF(PV(7,I).LT.0.) PV(5,I)=-PV(5,I)
1043 EKIN2=EKIN2+PV(4,I)-ABS(PV(5,I))
1045 EKIN2=(EKIN2-EKIN)/EKIN
1047 $ WRITE(NEWBCD,2006) NT,EKIN,ENP(1),ENP(3),EKIN1,EKIN2
1048 IF(EKIN2.GT.0.2) GOTO 60
1053 IF(NT.EQ.1) GO TO 9999
1056 IF(NTOT.LT.NSIZE/12) GOTO 43
1061 2002 FORMAT(' *HIGXPT* PRODUCTION OF FINAL STATE KINEMATIC AFTER ',I3,
1062 $ ' TRIALS. KINETIC ENERGIES ',2F6.2,' OUT OF ',2F6.2)
1063 2000 FORMAT(' *HIGXPT* CMS PARAMETERS OF FINAL STATE PARTICLES,',
1064 $ ' ENERGIES IN INITIAL AND FINAL STATE ',2F6.2)
1065 2001 FORMAT(' *HIGXPT* TRACK',2X,I3,2X,10F8.3,2X,I3,2X,F4.0)
1066 2003 FORMAT(' *HIGXPT* TETA,EKIN0,EKIN1,EKIN ',4F10.4)
1067 2006 FORMAT(' *HIGXPT* COMP.',1X,I5,1X,5F7.2)
1068 3001 FORMAT(' *HIGXPT* NUCLEAR EXCITATION',I5,
1069 $ ' PARTICLES PRODUCED IN ADDITION TO ',I5,' NORMAL PARTICLES')
1070 3002 FORMAT(' *HIGXPT* AVAILABLE ENERGIES ',2F10.4,
1071 $ ' FOR ',2I3,' PARTICLES IN BEAM/TARGET FRAGM. REGION',
1072 $ ' WITH IPA/SIDE ARRAY '/
1073 $ 1H ,5X,10(I3,2X,F3.0,4X))
1074 3003 FORMAT(' *HIGXPT* ',I3,' BLACK TRACK PARTICLES PRODUCED',
1075 $ ' WITH TOTAL KINETIC ENERGY OF ',F8.3,' GEV')
1076 3004 FORMAT(' *HIGXPT* ',I5,' HEAVY FRAGMENTS PRODUCED',
1077 $ ' WITH TOTAL ENERGY OF',F8.4,' GEV')