utils/dpmjet/dpmjetint.f

0001 *

0002 *===program crint======================================================*

0003 *

0004 C      OPTIONS/ EXTEND_SOURCE

0005 C      SUBROUTINE CRINT

0006       SUBROUTINE DT_PRODUCEEVENT(ENERGY_SL, NPARTICLES)
0007
0008
0009       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
0010       REAL ENERGY_SL
0011       INTEGER INIT
0012       REAL ne,etest,prob,slump
0013       SAVE
0014
0015 * Call the init sub routine in the first event

0016       DATA INIT /0/
0017
0018       PARAMETER (NMXHKK=200000)
0019
0020       COMMON /DTIONT/ LINP,LOUT,LDAT
0021
0022       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
0023      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
0024      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
0025
0026 *     event flag

0027       COMMON /DTEVNO/ NEVENT, ICASCA
0028
0029       IF(INIT.EQ.0) THEN
0030          OPEN (UNIT = 50, file = "my.input")
0031          LINP = 50
0032          CALL DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IEMU)
0033 *        Init called, make sure it's not called again

0034          INIT = 1
0035       ENDIF
0036 *-----------------------------------------------------------------------

0037 *     generation of one event

0038       NEVENT = 1
0039       KKMAT = -1
0040
0041 *   If an energy-range has been defined with the ENERGY input-card the

0042 *   laboratory energy ELAB can be set to any value within that range,..

0043 C        ELAB = DT_RNDM(EPN)*(EPN-0.5D7)+0.5D7

0044
0045 *   ..otherwise it has to coincide with EPN.

0046 C        ELAB = EPN

0047
0048       ELAB = ENERGY_SL
0049
0050 *   sampling of one event

0051
0052 *     TEST

0053
0054       CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,ELAB,KKMAT,IREJ)
0055
0056       IF (IREJ.NE.0) RETURN
0057
0058 c     Return the number of particles produced

0059
0060 c     Fill the particle info

0061       CALL DT_GETPARTICLES(NPARTICLES)
0062
0063       END
0064
0065
0066       SUBROUTINE DT_GETPARTICLES(NPARTICLES)
0067
0068       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
0069       INTEGER pid,qch,q_sum,Ntpc,Nfinal,NACCEPT,IPART,RES
0070       DOUBLE PRECISION yrap,pt,mass,mt,etot
0071       DOUBLE PRECISION pt_cut_tpc
0072       PARAMETER(pt_cut_tpc=0.050)
0073
0074       SAVE
0075 *

0076 * COMMON /DTEVT1/ :

0077 *                   NHKK         number of entries in common block

0078 *                   NEVHKK       number of the event

0079 *                   ISTHKK(i)    status code for entry i

0080 *                   IDHKK(i)     identifier for the entry

0081 *                                (for particles: identifier according

0082 *                                 to the PDG numbering scheme)

0083 *                   JMOHKK(1,i)  pointer to the entry of the first mother

0084 *                                of entry i

0085 *                   JMOHKK(2,i)  pointer to the entry of the second mother

0086 *                                of entry i

0087 *                   JDAHKK(1,i)  pointer to the entry of the first daughter

0088 *                                of entry i

0089 *                   JDAHKK(2,i)  pointer to the entry of the second daughter

0090 *                                of entry i

0091 *                   PHKK(1..3,i) 3-momentum

0092 *                   PHKK(4,i)    energy

0093 *                   PHKK(5,i)    mass

0094 *

0095 * event history

0096
0097       PARAMETER (NMXHKK=200000)
0098
0099       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
0100      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
0101      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
0102
0103 * extended event history

0104       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
0105      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
0106      &                IHIST(2,NMXHKK)
0107
0108       DOUBLE PRECISION SLPX, SLPY, SLPZ, SLE, SLM
0109       INTEGER SLPID, SLCHARGE
0110       COMMON /DPMJETPARTICLE/ SLPX(NMXHKK), SLPY(NMXHKK), SLPZ(NMXHKK),
0111      &       SLE(NMXHKK), SLM(NMXHKK), SLPID(NMXHKK), SLCHARGE(NMXHKK)
0112
0113
0114 C     >> Set Counter to Zero

0115
0116       Nfinal=0
0117
0118       DO 42 I=1, NHKK
0119 c      I = IPART

0120
0121 CC       >> Remove all non-final-state particles

0122         IF(.not.(ISTHKK(I).eq.1.or.ISTHKK(I).eq.-1.or.
0123      $ISTHKK(I).eq.1001)) GOTO 42
0124
0125 C       >> Find Particle Charge, qch

0126         IF((ABS(ISTHKK(I)).eq.1).and.(IDHKK(I).ne.80000))THEN
0127 C         >> final state ptcles except nuclei

0128
0129           qch=IPHO_CHR3(IDHKK(I),1)/3
0130         ELSEIF(IDHKK(I).eq.80000)THEN
0131 C         >> final state nuclei

0132           qch=IDXRES(I)
0133         ELSE
0134 C         >> not a final state particle, qch not interesting

0135           qch=-999
0136         ENDIF
0137
0138         Nfinal = Nfinal + 1
0139         SLPX(Nfinal) = PHKK(1,I)
0140         SLPY(Nfinal) = PHKK(2,I)
0141         SLPZ(Nfinal) = PHKK(3,I)
0142         SLE(Nfinal) = PHKK(4,I)
0143         SLM(Nfinal) = PHKK(5,I)
0144         SLPID(Nfinal) = IDHKK(I)
0145         SLCHARGE(Nfinal) = qch
0146
0147  42     CONTINUE
0148         NPARTICLES = Nfinal
0149
0150       END
0151
0152       SUBROUTINE DT_USRHIS(MODE)
0153 c Dummy to make the linker happy

0154       END
0155