dpm25evt.f

Go to the documentation of this file.

C***********************************************************************
      SUBROUTINE dpmevt(ELABT,IIPROJ,IIP,IIPZ,IIT,IITZ,KKMAT,NHKKH1)
C
C           J.R.   Version 4/97 for dpmjet25
C
      IMPLICIT DOUBLE PRECISION (a-h,o-z)
      SAVE
*KEEP,HKKEVT.
c     INCLUDE (HKKEVT)
      parameter(nmxhkk=89998)
      COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
     +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
     +(4,nmxhkk)
C
      CHARACTER*8  aname
      COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
     +iibar(210),k1(210),k2(210)
C
*KEEP,NUCC.
      COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
      COMMON /nuccc/ jt,jtz,jp,jpz,jjproj,jbproj,jjtarg,jbtarg
C                               from DTUJET93
*  *********************************************************************
*     /COLLIS/       contains the input specifying the considered event
C        ECM dropped as now in /USER/CMENER
*        S = is the Mandelstam s variable (=ECM**2)
*        IJPROJ,IJTARG = specifies the projectile rsp. target Q.N.
*        PTTHR  = the minimum pt still hard
*        PTTHR2 = the  pt of the first sampled hard scattering
*        IOPHRD = the option chosen for the hard scatterring
*        IJPRLU,IJTALU =
*  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C     COMMON/COLLIS/S,IJPROX,IJTAR,PTTHR,IOPHRD,IJPRLU,IJTALU,PTTHR2
      common/collis/s,ijprox,ijtar,ptthr,ptthr2,iophrd,ijprlu,ijtalu
*
*  *********************************************************************
*KEEP,NNCMS.
      COMMON /nncms/  gamcm,bgcm,umo,pcm,eproj,pproj
*  *********************************************************************
*  /USER/ contains the parameters, expected to be modified by normal user
*      TITLE is a litteral string TITLE printet in the OUTPUT
*      PROJTY resp. TARGTY specify the type of particle scattering
*            The projectile moves in positive z-direction.
*          (Particle type specifications numbers for scatterers are stored
*           in COMMON /BOOKLT/ in BLOCKDATA on the end of this file.
*           Our comlete particle and resonance numbering is given in
*           the file DTUTCB in BLOCK DATA partic DATA ANAME
*           Also a list of our particle numbering
*           is obtained running the code word PARTICLE)
*      CMENERGY the center of mass energy in GeV
*      ISTRUF specifies the structure function as
*      ISINGD (ISINGX)specifies what is done with diffractive events
*              ISINGD=0: Single diffraction surpressed
*              ISINGD=1: Single diffraction included to fraction SDFRAC
*              ISINGD=2: Only single diffraction with target excited
*              ISINGD=3: Only single diffraction with projectile excited
*      IDUBLD specifies what is done with double diffractive events
*              ISINGD=0: Double diffraction included
*              ISINGD=1: Only double diffraction
*      SDFRAC see ISINGD
*      PTLAR  cutoff parameter requiring minijet of given size??

*  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      CHARACTER*80 titled
      CHARACTER*8 projty,targty
C     COMMON /USER/TITLED,PROJTY,TARGTY,CMENER,ISTRUF
C    &            ,ISINGX,IDUBLD,SDFRAC,PTLAR
      COMMON /user1/titled,projty,targty
      COMMON /user2/cmener,sdfrac,ptlar,istruf,isingx,idubld
      CHARACTER*8 btype
      COMMON /paname/ btype(30)
      COMMON /strufu/ istrum,istrut
C
      COMMON /bufueh/ annvv, annss, annsv, annvs, anncc, anndv,
     * annvd, annds, annsd, annhh, annzz, ptvv, ptss, ptsv, ptvs, 
     * ptcc, ptdv, ptvd, ptds, ptsd, pthh, ptzz, eevv, eess, eesv, 
     * eevs, eecc, eedv, eevd, eeds, eesd, eehh, eezz, anndi, ptdi, 
     * eedi, annzd, anndz, ptzd, ptdz, eezd, eedz
      COMMON /ncouch/ acouvv, acouss, acousv, acouvs, acouzz, acouhh,
     * acouds, acousd, acoudz, acouzd, acoudi, acoudv, acouvd, acoucc
C
       SAVE elabt_prev
C       ON DOUBLE PRECISION UNDERFLOW IGNORE
C       ON REAL UNDERFLOW IGNORE
       DATA elabt_prev/-10./      !  lab-energy of previous collision
       DATA ninit/0/
C
*  *********************************************************************
*                               PROJPAR
    iproj=iiproj
C                    New 4/97
C       KKMAT=IIP
    IF(iiproj.EQ.-1)iproj=1
C                    New 4/97
    IF(iproj.EQ.12.OR.iproj.EQ.19)THEN
      iproj=24
      IF(rndm(v).LT.0.5d0)iproj=25
    ENDIF
        projty=btype(iproj)
        ijproj=iproj
        ijprox=iproj
    ibproj=iibar(iproj)
    ip=iip
    ipz=iipz
*                               TARPAR
C       IT=14
C       ITZ=7
    it=iit
    itz=iitz
    ijtar=1
*                               MOMENTUM
      epn=1000.d0*elabt
      nnpp=ijproj
      amproj=aam(nnpp)
      pproj = sqrt((epn-amproj)*(epn+amproj))
      ppn=pproj
*                             nucleon-nucleon cms
      eproj=epn
      amtar=aam(1)
      umo = sqrt(amproj**2 + amtar**2 + 2.*amtar*eproj)
      cmener=umo
      gamcm = (eproj+amtar)/umo
      bgcm=pproj/umo
      ecm=umo
      s=ecm**2
      pcm=gamcm*pproj - bgcm*eproj
          IF(istrut.EQ.1)THEN
            ptthr=2.1+0.15*(log10(cmener/50.))**3
            ptthr2=ptthr
          ELSEIF(istrut.EQ.2)THEN
            ptthr=2.5+0.12*(log10(cmener/50.))**3
            ptthr2=ptthr
          ENDIF
C
C     IIT=IT 
C     IITZ=ITZ
C     IIP=IP
C     IIPZ=IPZ
      iiproj=ijproj
      iitarg = ijtarg
C
C-- INITIALIZE COUNTERS before call to KKINC
C
 765  CONTINUE
      annvv=0.001         ! common /BUFUEH/
      annss=0.001
      annsv=0.001
      annvs=0.001
      anncc=0.001
      anndv=0.001
      annvd=0.001
      annds=0.001
      annsd=0.001
      annhh=0.001
      annzz=0.001
      anndi=0.001
      annzd=0.001
      anndz=0.001
      ptvv=0.
      ptss=0.
      ptsv=0.
      ptvs=0.
      ptcc=0.
      ptdv=0.
      ptvd=0.
      ptds=0.
      ptsd=0.
      pthh=0.
      ptzz=0.
      ptdi=0.
      ptzd=0.
      ptdz=0.
      eevv=0.
      eess=0.
      eesv=0.
      eevs=0.
      eecc=0.
      eedv=0.
      eevd=0.
      eeds=0.
      eesd=0.
      eehh=0.
      eezz=0.
      eedi=0.
      eezd=0.
      eedz=0.
C  
C-- COMMON /NCOUCH/ variables
C
       acouvv=0.
       acouss=0.
       acousv=0.
       acouvs=0.
       acouzz=0.
       acouhh=0.
       acouds=0.
       acousd=0.
       acoudz=0.
       acouzd=0.
       acoudi=0.
       acoudv=0.
       acouvd=0.
       acoucc=0.
C
C-- Pt initialisation each time collision energy varies
C
      IF (elabt.NE.elabt_prev) THEN
CGB CALL RD2OUT(ISEED,JSEED)
CGB write(6,*) 'seeds before SAMPPT',ISEED,JSEED
    CALL samppt(0,pt)
CGB CALL RD2OUT(ISEED,JSEED)
CGB write(6,*) 'seeds after SAMPPT',ISEED,JSEED
CGB write(6,*)
      ENDIF
      elabt_prev = elabt
C
      IF(ninit.LT.10)THEN
      ninit=ninit+1
      WRITE(6,*)' DPMEVT  EPN=',epn,'IIT,IITZ,IIP,IIPZ,IIPROJ,KKMAT',
     *iit,iitz,iip,iipz,iiproj,kkmat, ' PTTHR=',ptthr 
      ENDIF
      CALL kkinc(epn,iit,iitz,iip,iipz,iiproj,kkmat,
     * iitarg,nhkkh1,irej)
      IF (irej.EQ.1) THEN
        WRITE(6,*)'Exits from KKINC with IREJ=1'
        go to 765
      ENDIF
C      WRITE(6,*)'DECHKK called from DPMEVT : NHKKH1=',NHKKH1
C      CALL DECHKK(NHKKH1)
      RETURN
      END
C