STARLIGHT/starlight/dpmjet/.svn/text-base/dpmjetint.f.svn-base

   1 *\r
   2 *===program crint======================================================*\r
   3 *\r
   4 C      OPTIONS/ EXTEND_SOURCE\r
   5 C      SUBROUTINE CRINT\r
   6       SUBROUTINE DT_PRODUCEEVENT(ENERGY_SL, NPARTICLES)\r
   7 \r
   8 \r
   9       IMPLICIT DOUBLE PRECISION (A-H,O-Z)\r
  10       REAL ENERGY_SL\r
  11       INTEGER INIT\r
  12       REAL ne,etest,prob,slump\r
  13       SAVE\r
  14 \r
  15 * Call the init sub routine in the first event\r
  16       DATA INIT /0/\r
  17 \r
  18       PARAMETER (NMXHKK=200000)\r
  19 \r
  20       COMMON /DTIONT/ LINP,LOUT,LDAT\r
  21 \r
  22       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),\r
  23      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),\r
  24      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)\r
  25 \r
  26 *     event flag\r
  27       COMMON /DTEVNO/ NEVENT, ICASCA\r
  28 \r
  29       IF(INIT.EQ.0) THEN\r
  30          OPEN (UNIT = 50, file = "my.input")    \r
  31          LINP = 50\r
  32          CALL DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IEMU)\r
  33 *        Init called, make sure it's not called again\r
  34          INIT = 1\r
  35       ENDIF\r
  36 *-----------------------------------------------------------------------\r
  37 *     generation of one event\r
  38       NEVENT = 1\r
  39       KKMAT = -1\r
  40 \r
  41 *   If an energy-range has been defined with the ENERGY input-card the\r
  42 *   laboratory energy ELAB can be set to any value within that range,..\r
  43 C        ELAB = DT_RNDM(EPN)*(EPN-0.5D7)+0.5D7\r
  44 \r
  45 *   ..otherwise it has to coincide with EPN.\r
  46 C        ELAB = EPN\r
  47 \r
  48       ELAB = ENERGY_SL\r
  49 \r
  50 *   sampling of one event\r
  51 \r
  52 *     TEST\r
  53 \r
  54       CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,ELAB,KKMAT,IREJ)\r
  55 \r
  56       IF (IREJ.NE.0) RETURN\r
  57 \r
  58 c     Return the number of particles produced\r
  59       \r
  60 c     Fill the particle info \r
  61       CALL DT_GETPARTICLES(NPARTICLES)\r
  62 \r
  63       END\r
  64 \r
  65 \r
  66       SUBROUTINE DT_GETPARTICLES(NPARTICLES)\r
  67 \r
  68       IMPLICIT DOUBLE PRECISION (A-H,O-Z)\r
  69       INTEGER pid,qch,q_sum,Ntpc,Nfinal,NACCEPT,IPART,RES\r
  70       DOUBLE PRECISION yrap,pt,mass,mt,etot\r
  71       DOUBLE PRECISION pt_cut_tpc\r
  72       PARAMETER(pt_cut_tpc=0.050)\r
  73 \r
  74       SAVE\r
  75 *\r
  76 * COMMON /DTEVT1/ :\r
  77 *                   NHKK         number of entries in common block\r
  78 *                   NEVHKK       number of the event\r
  79 *                   ISTHKK(i)    status code for entry i\r
  80 *                   IDHKK(i)     identifier for the entry\r
  81 *                                (for particles: identifier according\r
  82 *                                 to the PDG numbering scheme)\r
  83 *                   JMOHKK(1,i)  pointer to the entry of the first mother\r
  84 *                                of entry i\r
  85 *                   JMOHKK(2,i)  pointer to the entry of the second mother\r
  86 *                                of entry i\r
  87 *                   JDAHKK(1,i)  pointer to the entry of the first daughter\r
  88 *                                of entry i\r
  89 *                   JDAHKK(2,i)  pointer to the entry of the second daughter\r
  90 *                                of entry i\r
  91 *                   PHKK(1..3,i) 3-momentum\r
  92 *                   PHKK(4,i)    energy\r
  93 *                   PHKK(5,i)    mass\r
  94 *\r
  95 * event history\r
  96 \r
  97       PARAMETER (NMXHKK=200000)\r
  98 \r
  99       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),\r
 100      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),\r
 101      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)\r
 102 \r
 103 * extended event history\r
 104       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),\r
 105      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),\r
 106      &                IHIST(2,NMXHKK)\r
 107 \r
 108       DOUBLE PRECISION SLPX, SLPY, SLPZ, SLE, SLM\r
 109       INTEGER SLPID, SLCHARGE\r
 110       COMMON /DPMJETPARTICLE/ SLPX(NMXHKK), SLPY(NMXHKK), SLPZ(NMXHKK),\r
 111      &       SLE(NMXHKK), SLM(NMXHKK), SLPID(NMXHKK), SLCHARGE(NMXHKK)\r
 112 \r
 113 \r
 114 C     >> Set Counter to Zero\r
 115 \r
 116       Nfinal=0\r
 117       \r
 118       DO 42 I=1, NHKK\r
 119 c      I = IPART\r
 120 \r
 121 CC       >> Remove all non-final-state particles\r
 122         IF(.not.(ISTHKK(I).eq.1.or.ISTHKK(I).eq.-1.or.\r
 123      $ISTHKK(I).eq.1001)) GOTO 42\r
 124 \r
 125 C       >> Find Particle Charge, qch\r
 126         IF((ABS(ISTHKK(I)).eq.1).and.(IDHKK(I).ne.80000))THEN\r
 127 C         >> final state ptcles except nuclei\r
 128 \r
 129           qch=IPHO_CHR3(IDHKK(I),1)/3\r
 130         ELSEIF(IDHKK(I).eq.80000)THEN\r
 131 C         >> final state nuclei\r
 132           qch=IDXRES(I)\r
 133         ELSE\r
 134 C         >> not a final state particle, qch not interesting\r
 135           qch=-999\r
 136         ENDIF\r
 137 \r
 138         Nfinal = Nfinal + 1\r
 139         SLPX(Nfinal) = PHKK(1,I)\r
 140         SLPY(Nfinal) = PHKK(2,I)\r
 141         SLPZ(Nfinal) = PHKK(3,I)\r
 142         SLE(Nfinal) = PHKK(4,I)\r
 143         SLM(Nfinal) = PHKK(5,I)\r
 144         SLPID(Nfinal) = IDHKK(I)\r
 145         SLCHARGE(Nfinal) = qch\r
 146 \r
 147  42     CONTINUE\r
 148         NPARTICLES = Nfinal\r
 149   \r
 150       END\r
 151 \r
 152       SUBROUTINE DT_USRHIS(MODE)\r
 153 c Dummy to make the linker happy\r
 154       END\r
 155 \r