Update to version 3.0-5
authormorsch <morsch@f7af4fe6-9843-0410-8265-dc069ae4e863>
Tue, 18 Mar 2008 12:09:19 +0000 (12:09 +0000)
committermorsch <morsch@f7af4fe6-9843-0410-8265-dc069ae4e863>
Tue, 18 Mar 2008 12:09:19 +0000 (12:09 +0000)
DPMJET/dpmjet3.0-5.f [new file with mode: 0644]
DPMJET/libdpmjet.pkg
DPMJET/phojet1.12-35c3.f [new file with mode: 0644]
DPMJET/pythia6115dpm3.f [new file with mode: 0644]
DPMJET/user3.0-5.f [new file with mode: 0644]

diff --git a/DPMJET/dpmjet3.0-5.f b/DPMJET/dpmjet3.0-5.f
new file mode 100644 (file)
index 0000000..9087a7f
--- /dev/null
@@ -0,0 +1,40095 @@
+*$ CREATE DT_INIT.FOR
+*COPY DT_INIT
+*
+*    +-------------------------------------------------------------+
+*    |                                                             |
+*    |                                                             |
+*    |                        DPMJET 3.0                           |
+*    |                                                             |
+*    |                                                             |
+*    |         S. Roesler+), R. Engel#), J. Ranft*)                |
+*    |                                                             |
+*    |         +) CERN, SC-RP                                      |
+*    |            CH-1211 Geneva 23, Switzerland                   |
+*    |            Email: Stefan.Roesler@cern.ch                    |
+*    |                                                             |
+*    |         #) Institut fuer Kernphysik                         |
+*    |            Forschungszentrum Karlsruhe                      |
+*    |            D-76021 Karlsruhe, Germany                       |
+*    |                                                             |
+*    |         *) University of Siegen, Dept. of Physics           |
+*    |            D-57068 Siegen, Germany                          |
+*    |                                                             |
+*    |                                                             |
+*    |       http://home.cern.ch/sroesler/dpmjet3.html             |
+*    |                                                             |
+*    |                                                             |
+*    |       Monte Carlo models used for event generation:         |
+*    |          PHOJET 1.12, JETSET 7.4 and LEPTO 6.5.1            |
+*    |                                                             |
+*    +-------------------------------------------------------------+
+*
+*
+*===init===============================================================*
+*
+      SUBROUTINE DT_INIT(NCASES,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
+     &                                             IDP,IGLAU)
+
+************************************************************************
+* Initialization of event generation                                   *
+* This version dated  7.4.98  is written by S. Roesler.                *
+*                                                                      *
+* Last change 27.12.2006 by S. Roesler.                                *
+************************************************************************
+
+      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+      SAVE
+
+      PARAMETER ( LINP = 10 ,
+     &            LOUT = 6 ,
+     &            LDAT = 9 )
+      PARAMETER (ZERO=0.0D0,ONE=1.0D0)
+
+* particle properties (BAMJET index convention)
+      CHARACTER*8  ANAME
+      COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+     &                IICH(210),IIBAR(210),K1(210),K2(210)
+* names of hadrons used in input-cards
+      CHARACTER*8 BTYPE
+      COMMON /DTPAIN/ BTYPE(30)
+* (original name: PAREVT)
+      LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
+     &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
+      PARAMETER ( NALLWP = 39   )
+      COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
+     &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
+     &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
+     &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
+* (original name: INPFLG)
+      COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
+* (original name: FRBKCM)
+      PARAMETER ( MXFFBK =     6 )
+      PARAMETER ( MXZFBK =     9 )
+      PARAMETER ( MXNFBK =    10 )
+      PARAMETER ( MXAFBK =    16 )
+      PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
+      PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
+      PARAMETER ( NXAFBK = MXAFBK + 1 )
+      PARAMETER ( MXPSST =   300 )
+      PARAMETER ( MXPSFB = 41000 )
+      LOGICAL LFRMBK, LNCMSS
+      COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
+     &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
+     &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
+     &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
+     &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
+     &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
+     &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
+     &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
+     &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
+      PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+* emulsion treatment
+      COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
+     &                NCOMPO,IEMUL
+* Glauber formalism: parameters
+      COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
+     &                BMAX(NCOMPX),BSTEP(NCOMPX),
+     &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
+     &                NSITEB,NSTATB
+* Glauber formalism: cross sections
+      COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
+     &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
+     &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
+     &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
+     &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
+     &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
+     &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
+     &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
+     &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
+     &                BSLOPE,NEBINI,NQBINI
+* interface HADRIN-DPM
+      COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
+* central particle production, impact parameter biasing
+      COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
+* parameter for intranuclear cascade
+      LOGICAL LPAULI
+      COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
+* various options for treatment of partons (DTUNUC 1.x)
+* (chain recombination, Cronin,..)
+      LOGICAL LCO2CR,LINTPT
+      COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
+     &                LCO2CR,LINTPT
+* threshold values for x-sampling (DTUNUC 1.x)
+      COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
+     &                SSMIMQ,VVMTHR
+* flags for input different options
+      LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+      COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+     &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+* nuclear potential
+      LOGICAL LFERMI
+      COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
+     &                EBINDP(2),EBINDN(2),EPOT(2,210),
+     &                ETACOU(2),ICOUL,LFERMI
+* n-n cross section fluctuations
+      PARAMETER (NBINS = 1000)
+      COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
+* flags for particle decays
+      COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
+     &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
+     &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
+* diquark-breaking mechanism
+      COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
+* nucleon-nucleon event-generator
+      CHARACTER*8 CMODEL
+      LOGICAL LPHOIN
+      COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+* properties of interacting particles
+      COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+* properties of photon/lepton projectiles
+      COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
+* flags for diffractive interactions (DTUNUC 1.x)
+      COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
+* parameters for hA-diffraction
+      COMMON /DTDIHA/ DIBETA,DIALPH
+* Lorentz-parameters of the current interaction
+      COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+     &                UMO,PPCM,EPROJ,PPROJ
+* kinematical cuts for lepton-nucleus interactions
+      COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
+     &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
+* VDM parameter for photon-nucleus interactions
+      COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
+* Glauber formalism: flags and parameters for statistics
+      LOGICAL LPROD
+      CHARACTER*8 CGLB
+      COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
+* cuts for variable energy runs
+      COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
+* flags for activated histograms
+      COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
+      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
+      COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
+* LEPTO
+**LUND single / double precision
+      REAL CUT,PARL,TMPX,TMPY,TMPW2,TMPQ2,TMPU
+      COMMON /LEPTOU/ CUT(14),LST(40),PARL(30),
+     &                TMPX,TMPY,TMPW2,TMPQ2,TMPU
+* LEPTO
+      REAL RPPN
+      COMMON /LEPTOI/ RPPN,LEPIN,INTER
+* steering flags for qel neutrino scattering modules
+      COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
+* event flag
+      COMMON /DTEVNO/ NEVENT,ICASCA
+
+      INTEGER PYCOMP
+
+C     DIMENSION XPARA(5)
+      DIMENSION XDUMB(40),IPRANG(5)
+
+      PARAMETER (MXCARD=58)
+      CHARACTER*78 CLINE,CTITLE
+      CHARACTER*60 CWHAT
+      CHARACTER*8  BLANK,SDUM
+      CHARACTER*10 CODE,CODEWD
+      CHARACTER*72 HEADER
+      LOGICAL LSTART,LEINP,LXSTAB
+      DIMENSION WHAT(6),CODE(MXCARD)
+      DATA CODE/
+     &   'TITLE     ','PROJPAR   ','TARPAR    ','ENERGY    ',
+     &   'MOMENTUM  ','CMENERGY  ','EMULSION  ','FERMI     ',
+     &   'TAUFOR    ','PAULI     ','COULOMB   ','HADRIN    ',
+     &   'EVAP      ','EMCCHECK  ','MODEL     ','PHOINPUT  ',
+     &   'GLAUBERI  ','FLUCTUAT  ','CENTRAL   ','RECOMBIN  ',
+     &   'COMBIJET  ','XCUTS     ','INTPT     ','CRONINPT  ',
+     &   'SEADISTR  ','SEASU3    ','DIQUARKS  ','RESONANC  ',
+     &   'DIFFRACT  ','SINGLECH  ','NOFRAGME  ','HADRONIZE ',
+     &   'POPCORN   ','PARDECAY  ','BEAM      ','LUND-MSTU ',
+     &   'LUND-MSTJ ','LUND-MDCY ','LUND-PARJ ','LUND-PARU ',
+     &   'OUTLEVEL  ','FRAME     ','L-TAG     ','L-ETAG    ',
+     &   'ECMS-CUT  ','VDM-PAR1  ','HISTOGRAM ','XS-TABLE  ',
+     &   'GLAUB-PAR ','GLAUB-INI ','VDM-PAR2  ','XS-QELPRO ',
+     &   'RNDMINIT  ','LEPTO-CUT ','LEPTO-LST ','LEPTO-PARL',
+     &   'START     ','STOP      '/
+      DATA BLANK /'        '/
+
+      DATA LSTART,LXSTAB,IFIRST /.TRUE.,.FALSE.,1/
+      DATA CMEOLD /0.0D0/
+
+*---------------------------------------------------------------------
+* at the first call of INIT: initialize event generation
+      EPNSAV = EPN
+      IF (LSTART) THEN
+         CALL DT_TITLE
+*   initialization and test of the random number generator
+         IF (ITRSPT.NE.1) THEN
+            CALL DT_RNDMST(22,54,76,92)
+            CALL DT_RNDMTE(1)
+         ENDIF
+*   initialization of BAMJET, DECAY and HADRIN
+         CALL DT_DDATAR
+         CALL DT_DHADDE
+         CALL DT_DCHANT
+         CALL DT_DCHANH
+*   set default values for input variables
+         CALL DT_DEFAUL(EPN,PPN)
+         IGLAU  = 0
+         IXSQEL = 0
+*   flag for collision energy input
+         LEINP  = .FALSE.
+         LSTART = .FALSE.
+      ENDIF
+
+*---------------------------------------------------------------------
+   10 CONTINUE
+
+* bypass reading input cards (e.g. for use with Fluka)
+*  in this case Epn is expected to carry the beam momentum
+      IF (NCASES.EQ.-1) THEN
+         IP      = NPMASS
+         IPZ     = NPCHAR
+         PPN     = EPNSAV
+         EPN     = ZERO
+         CMENER  = ZERO
+         LEINP   = .TRUE.
+         MKCRON  = 0
+         WHAT(1) = 1
+         WHAT(2) = 0
+         CODEWD  = 'START     '
+         GOTO 900
+      ENDIF
+
+* read control card from input-unit LINP
+      READ(LINP,'(A78)',END=9999) CLINE
+      IF (CLINE(1:1).EQ.'*') THEN
+* comment-line
+         WRITE(LOUT,'(A78)') CLINE
+         GOTO 10
+      ENDIF
+C     READ(CLINE,1000,END=9999) CODEWD,(WHAT(I),I=1,6),SDUM
+C1000 FORMAT(A10,6E10.0,A8)
+      DO 1008 I=1,6
+         WHAT(I) = ZERO
+ 1008 CONTINUE
+      READ(CLINE,1006,END=9999) CODEWD,CWHAT,SDUM
+ 1006 FORMAT(A10,A60,A8)
+      READ(CWHAT,*,END=1007) (WHAT(I),I=1,6)
+ 1007 CONTINUE
+      WRITE(LOUT,1001) CODEWD,(WHAT(I),I=1,6),SDUM
+ 1001 FORMAT(A10,6G10.3,A8)
+
+  900 CONTINUE
+
+* check for valid control card and get card index
+      ICW = 0
+      DO 11 I=1,MXCARD
+         IF (CODEWD.EQ.CODE(I)) ICW = I
+   11 CONTINUE
+      IF (ICW.EQ.0) THEN
+         WRITE(LOUT,1002) CODEWD
+ 1002    FORMAT(/,1X,'---> ',A10,': invalid control-card !',/)
+         GOTO 10
+      ENDIF
+
+      GOTO(
+*------------------------------------------------------------
+*       TITLE   ,  PROJPAR ,  TARPAR  ,  ENERGY  ,  MOMENTUM,
+     &  100     ,  110     ,  120     ,  130     ,  140     ,
+*
+*------------------------------------------------------------
+*       CMENERGY,  EMULSION,  FERMI   ,  TAUFOR  ,  PAULI   ,
+     &  150     ,  160     ,  170     ,  180     ,  190     ,
+*
+*------------------------------------------------------------
+*       COULOMB ,  HADRIN  ,  EVAP    ,  EMCCHECK,  MODEL   ,
+     &  200     ,  210     ,  220     ,  230     ,  240     ,
+*
+*------------------------------------------------------------
+*       PHOINPUT,  GLAUBERI,  FLUCTUAT,  CENTRAL ,  RECOMBIN,
+     &  250     ,  260     ,  270     ,  280     ,  290     ,
+*
+*------------------------------------------------------------
+*       COMBIJET,  XCUTS   ,  INTPT   ,  CRONINPT,  SEADISTR,
+     &  300     ,  310     ,  320     ,  330     ,  340     ,
+*
+*------------------------------------------------------------
+*       SEASU3  ,  DIQUARKS,  RESONANC,  DIFFRACT,  SINGLECH,
+     &  350     ,  360     ,  370     ,  380     ,  390     ,
+*
+*------------------------------------------------------------
+*       NOFRAGME, HADRONIZE,  POPCORN ,  PARDECAY,  BEAM    ,
+     &  400     ,  410     ,  420     ,  430     ,  440     ,
+*
+*------------------------------------------------------------
+*      LUND-MSTU, LUND-MSTJ, LUND-MDCY, LUND-PARJ, LUND-PARU,
+     &  450     ,  451     ,  452     ,  460     ,  470     ,
+*
+*------------------------------------------------------------
+*       OUTLEVEL,  FRAME   , L-TAG    ,  L-ETAG  ,  ECMS-CUT,
+     &  480     ,  490     ,  500     ,  510     ,  520     ,
+*
+*------------------------------------------------------------
+*       VDM-PAR1, HISTOGRAM, XS-TABLE , GLAUB-PAR, GLAUB-INI,
+     &  530     ,  540     ,  550     ,  560     ,  565     ,
+*
+*------------------------------------------------------------
+*               ,          ,  VDM-PAR2, XS-QELPRO, RNDMINIT ,
+     &                        570     ,  580     ,  590     ,
+*
+*------------------------------------------------------------
+*      LEPTO-CUT, LEPTO-LST,LEPTO-PARL,  START   ,  STOP    )
+     &  600     ,  610     ,  620     ,  630     ,  640     ) , ICW
+*
+*------------------------------------------------------------
+
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = TITLE                       *
+*                                                                   *
+*       what (1..6), sdum   no meaning                              *
+*                                                                   *
+*       Note:  The control-card following this must consist of      *
+*              a string of characters usually giving the title of   *
+*              the run.                                             *
+*                                                                   *
+*********************************************************************
+
+  100 CONTINUE
+      READ(LINP,'(A78)') CTITLE
+      WRITE(LOUT,'(//,5X,A78,//)') CTITLE
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = PROJPAR                     *
+*                                                                   *
+*       what (1) =  mass number of projectile nucleus  default: 1   *
+*       what (2) =  charge of projectile nucleus       default: 1   *
+*       what (3..6)   no meaning                                    *
+*       sdum        projectile particle code word                   *
+*                                                                   *
+*       Note: If sdum is defined what (1..2) have no meaning.       *
+*                                                                   *
+*********************************************************************
+
+  110 CONTINUE
+      IF (SDUM.EQ.BLANK) THEN
+         IP     = INT(WHAT(1))
+         IPZ    = INT(WHAT(2))
+         IJPROJ = 1
+         IBPROJ = 1
+      ELSE
+         IJPROJ = 0
+         DO 111 II=1,30
+            IF (SDUM.EQ.BTYPE(II)) THEN
+               IP     = 1
+               IPZ    = 1
+               IF (II.EQ.26) THEN
+                  IJPROJ = 135
+               ELSEIF (II.EQ.27) THEN
+                  IJPROJ = 136
+               ELSEIF (II.EQ.28) THEN
+                  IJPROJ = 133
+               ELSEIF (II.EQ.29) THEN
+                  IJPROJ = 134
+               ELSE
+                  IJPROJ = II
+               ENDIF
+               IBPROJ = IIBAR(IJPROJ)
+* photon
+               IF ((IJPROJ.EQ.7).AND.(WHAT(1).GT.ZERO)) VIRT = WHAT(1)
+* lepton
+               IF (((IJPROJ.EQ. 3).OR.(IJPROJ.EQ. 4).OR.
+     &              (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11)).AND.
+     &                              (WHAT(1).GT.ZERO)) Q2HI = WHAT(1)
+            ENDIF
+  111    CONTINUE
+         IF (IJPROJ.EQ.0) THEN
+            WRITE(LOUT,1110)
+ 1110       FORMAT(/,1X,'invalid PROJPAR card !',/)
+            GOTO 9999
+         ENDIF
+      ENDIF
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = TARPAR                      *
+*                                                                   *
+*       what (1) =  mass number of target nucleus      default: 1   *
+*       what (2) =  charge of target nucleus           default: 1   *
+*       what (3..6)   no meaning                                    *
+*       sdum        target particle code word                       *
+*                                                                   *
+*       Note: If sdum is defined what (1..2) have no meaning.       *
+*                                                                   *
+*********************************************************************
+
+  120 CONTINUE
+      IF (SDUM.EQ.BLANK) THEN
+         IT     = INT(WHAT(1))
+         ITZ    = INT(WHAT(2))
+         IJTARG = 1
+         IBTARG = 1
+      ELSE
+         IJTARG = 0
+         DO 121 II=1,30
+            IF (SDUM.EQ.BTYPE(II)) THEN
+               IT     = 1
+               ITZ    = 1
+               IJTARG = II
+               IBTARG = IIBAR(IJTARG)
+            ENDIF
+  121    CONTINUE
+         IF (IJTARG.EQ.0) THEN
+            WRITE(LOUT,1120)
+ 1120       FORMAT(/,1X,'invalid TARPAR card !',/)
+            GOTO 9999
+         ENDIF
+      ENDIF
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = ENERGY                      *
+*                                                                   *
+*       what (1) =  energy (GeV) of projectile in Lab.              *
+*                   if what(1) < 0:  |what(1)| = kinetic energy     *
+*                                                default: 200 GeV   *
+*                   if |what(2)| > 0: min. energy for variable      *
+*                                     energy runs                   *
+*       what (2) =  max. energy for variable energy runs            *
+*                   if what(2) < 0:  |what(2)| = kinetic energy     *
+*                                                                   *
+*********************************************************************
+
+  130 CONTINUE
+      EPN    = WHAT(1)
+      PPN    = ZERO
+      CMENER = ZERO
+      IF ((ABS(WHAT(2)).GT.ZERO).AND.
+     &    (ABS(WHAT(2)).GT.ABS(WHAT(1)))) THEN
+         VARELO = WHAT(1)
+         VAREHI = WHAT(2)
+         EPN    = VAREHI
+      ENDIF
+      LEINP  = .TRUE.
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = MOMENTUM                    *
+*                                                                   *
+*       what (1) =  momentum (GeV/c) of projectile in Lab.          *
+*                                                default: 200 GeV/c *
+*       what (2..6), sdum   no meaning                              *
+*                                                                   *
+*********************************************************************
+
+  140 CONTINUE
+      EPN    = ZERO
+      PPN    = WHAT(1)
+      CMENER = ZERO
+      LEINP  = .TRUE.
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = CMENERGY                    *
+*                                                                   *
+*       what (1) =  energy in nucleon-nucleon cms.                  *
+*                                                default: none      *
+*       what (2..6), sdum   no meaning                              *
+*                                                                   *
+*********************************************************************
+
+  150 CONTINUE
+      EPN    = ZERO
+      PPN    = ZERO
+      CMENER = WHAT(1)
+      LEINP  = .TRUE.
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = EMULSION                    *
+*                                                                   *
+*               definition of nuclear emulsions                     *
+*                                                                   *
+*     what(1)      mass number of emulsion component                *
+*     what(2)      charge of emulsion component                     *
+*     what(3)      fraction of events in which a scattering on a    *
+*                  nucleus of this properties is performed          *
+*     what(4,5,6)  as what(1,2,3) but for another component         *
+*                                             default: no emulsion  *
+*     sdum         no meaning                                       *
+*                                                                   *
+*     Note: If this input-card is once used with valid parameters   *
+*           TARPAR is obsolete.                                     *
+*           Not the absolute values of the fractions are important  *
+*           but only the ratios of fractions of different comp.     *
+*           This control card can be repeatedly used to define      *
+*           emulsions consisting of up to 10 elements.              *
+*                                                                   *
+*********************************************************************
+
+  160 CONTINUE
+      IF ((WHAT(1).GT.ZERO).AND.(WHAT(2).GT.ZERO)
+     &                     .AND.(ABS(WHAT(3)).GT.ZERO)) THEN
+         NCOMPO = NCOMPO+1
+         IF (NCOMPO.GT.NCOMPX) THEN
+            WRITE(LOUT,1600)
+            STOP
+         ENDIF
+         IEMUMA(NCOMPO) = INT(WHAT(1))
+         IEMUCH(NCOMPO) = INT(WHAT(2))
+         EMUFRA(NCOMPO) = WHAT(3)
+         IEMUL = 1
+C        CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
+      ENDIF
+      IF ((WHAT(4).GT.ZERO).AND.(WHAT(5).GT.ZERO)
+     &                     .AND.(ABS(WHAT(6)).GT.ZERO)) THEN
+         NCOMPO = NCOMPO+1
+         IF (NCOMPO.GT.NCOMPX) THEN
+            WRITE(LOUT,1001)
+            STOP
+         ENDIF
+         IEMUMA(NCOMPO) = INT(WHAT(4))
+         IEMUCH(NCOMPO) = INT(WHAT(5))
+         EMUFRA(NCOMPO) = WHAT(6)
+C        CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
+      ENDIF
+ 1600 FORMAT(1X,'too many emulsion components - program stopped')
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = FERMI                       *
+*                                                                   *
+*       what (1) = -1 Fermi-motion of nucleons not treated          *
+*                                                 default: 1        *
+*       what (2) =    scale factor for Fermi-momentum               *
+*                                                 default: 0.75     *
+*       what (3..6), sdum   no meaning                              *
+*                                                                   *
+*********************************************************************
+
+  170 CONTINUE
+      IF (WHAT(1).EQ.-1.0D0) THEN
+         LFERMI = .FALSE.
+      ELSE
+         LFERMI = .TRUE.
+      ENDIF
+      XMOD = WHAT(2)
+      IF (XMOD.GE.ZERO) FERMOD = XMOD
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = TAUFOR                      *
+*                                                                   *
+*          formation time supressed intranuclear cascade            *
+*                                                                   *
+*    what (1)      formation time (in fm/c)                         *
+*                  note: what(1)=10. corresponds roughly to an      *
+*                        average formation time of 1 fm/c           *
+*                                                 default: 5. fm/c  *
+*    what (2)      number of generations followed                   *
+*                                                 default: 25       *
+*    what (3) = 1. p_t-dependent formation zone                     *
+*             = 2. constant formation zone                          *
+*                                                 default: 1        *
+*    what (4)      modus of selection of nucleus where the          *
+*                  cascade if followed first                        *
+*             = 1.  proj./target-nucleus with probab. 1/2           *
+*             = 2.  nucleus with highest mass                       *
+*             = 3.  proj. nucleus if particle is moving in pos. z   *
+*                   targ. nucleus if particle is moving in neg. z   *
+*                                                 default: 1        *
+*    what (5..6), sdum   no meaning                                 *
+*                                                                   *
+*********************************************************************
+
+  180 CONTINUE
+      TAUFOR = WHAT(1)
+      KTAUGE = INT(WHAT(2))
+      INCMOD = 1
+      IF ((WHAT(3).GE.1.0D0).AND.(WHAT(3).LE.2.0D0))
+     &                                    ITAUVE = INT(WHAT(3))
+      IF ((WHAT(4).GE.1.0D0).AND.(WHAT(4).LE.3.0D0))
+     &                                    INCMOD = INT(WHAT(4))
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = PAULI                       *
+*                                                                   *
+*       what (1) =  -1  Pauli's principle for secondary             *
+*                       interactions not treated                    *
+*                                                    default: 1     *
+*       what (2..6), sdum   no meaning                              *
+*                                                                   *
+*********************************************************************
+
+  190 CONTINUE
+      IF (WHAT(1).EQ.-1.0D0) THEN
+         LPAULI = .FALSE.
+      ELSE
+         LPAULI = .TRUE.
+      ENDIF
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = COULOMB                     *
+*                                                                   *
+*       what (1) = -1. Coulomb-energy treatment switched off        *
+*                                                    default: 1     *
+*       what (2..6), sdum   no meaning                              *
+*                                                                   *
+*********************************************************************
+
+  200 CONTINUE
+      ICOUL = 1
+      IF (WHAT(1).EQ.-1.0D0) THEN
+         ICOUL = 0
+      ELSE
+         ICOUL = 1
+      ENDIF
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = HADRIN                      *
+*                                                                   *
+*                       HADRIN module                               *
+*                                                                   *
+*    what (1) = 0. elastic/inelastic interactions with probab.      *
+*                  as defined by cross-sections                     *
+*             = 1. inelastic interactions forced                    *
+*             = 2. elastic interactions forced                      *
+*                                                 default: 1        *
+*    what (2)      upper threshold in total energy (GeV) below      *
+*                  which interactions are sampled by HADRIN         *
+*                                                 default: 5. GeV   *
+*    what (3..6), sdum   no meaning                                 *
+*                                                                   *
+*********************************************************************
+
+  210 CONTINUE
+      IWHAT = INT(WHAT(1))
+      IF ((IWHAT.GE.0).AND.(IWHAT.LE.2)) INTHAD = IWHAT
+      IF ((WHAT(2).GT.ZERO).AND.(WHAT(2).LT.15.0D0)) EHADTH = WHAT(2)
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = EVAP                        *
+*                                                                   *
+*                    evaporation module                             *
+*                                                                   *
+*  what (1) =< -1 ==> evaporation is switched off                   *
+*           >=  1 ==> evaporation is performed                      *
+*                                                                   *
+*         what (1) = i1 + i2*10 + i3*100 + i4*10000                 *
+*                    (i1, i2, i3, i4 >= 0 )                         *
+*                                                                   *
+*   i1 is the flag for selecting the T=0 level density option used  *
+*      =  1: standard EVAP level densities with Cook pairing        *
+*            energies                                               *
+*      =  2: Z,N-dependent Gilbert & Cameron level densities        *
+*                                                        (default)  *
+*      =  3: Julich A-dependent level densities                     *
+*      =  4: Z,N-dependent Brancazio & Cameron level densities      *
+*                                                                   *
+*   i2 >= 1: high energy fission activated                          *
+*            (default high energy fission activated)                *
+*                                                                   *
+*   i3 =  0: No energy dependence for level densities               *
+*      =  1: Standard Ignyatuk (1975, 1st) energy dependence        *
+*            for level densities (default)                          *
+*      =  2: Standard Ignyatuk (1975, 1st) energy dependence        *
+*            for level densities with NOT used set of parameters    *
+*      =  3: Standard Ignyatuk (1975, 1st) energy dependence        *
+*            for level densities with NOT used set of parameters    *
+*      =  4: Second   Ignyatuk (1975, 2nd) energy dependence        *
+*            for level densities                                    *
+*      =  5: Second   Ignyatuk (1975, 2nd) energy dependence        *
+*            for level densities with fit 1 Iljinov & Mebel set of  *
+*            parameters                                             *
+*      =  6: Second   Ignyatuk (1975, 2nd) energy dependence        *
+*            for level densities with fit 2 Iljinov & Mebel set of  *
+*            parameters                                             *
+*      =  7: Second   Ignyatuk (1975, 2nd) energy dependence        *
+*            for level densities with fit 3 Iljinov & Mebel set of  *
+*            parameters                                             *
+*      =  8: Second   Ignyatuk (1975, 2nd) energy dependence        *
+*            for level densities with fit 4 Iljinov & Mebel set of  *
+*            parameters                                             *
+*                                                                   *
+*   i4 >= 1: Original Gilbert and Cameron pairing energies used     *
+*            (default Cook's modified pairing energies)             *
+*                                                                   *
+*  what (2) = ig + 10 * if   (ig and if must have the same sign)    *
+*                                                                   *
+*   ig =< -1 ==> deexcitation gammas are not produced               *
+*                (if the evaporation step is not performed          *
+*                 they are never produced)                          *
+*   if =< -1 ==> Fermi Break Up is not invoked                      *
+*                (if the evaporation step is not performed          *
+*                 it is never invoked)                              *
+*   The default is: deexcitation gamma produced and Fermi break up  *
+*                   activated for the new  preequilibrium, not      *
+*                   activated otherwise.                            *
+*  what (3..6), sdum   no meaning                                   *
+*                                                                   *
+*********************************************************************
+
+ 220  CONTINUE
+      WRITE(LOUT,1009)
+ 1009 FORMAT(1X,/,'Warning!  Evaporation request rejected since',
+     &       ' evaporation modules not available with this version.')
+      LEVPRT = .FALSE.
+      LDEEXG = .FALSE.
+      LHEAVY = .FALSE.
+      LFRMBK = .FALSE.
+      IFISS  = 0
+      IEVFSS = 0
+
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = EMCCHECK                    *
+*                                                                   *
+*    extended energy-momentum / quantum-number conservation check   *
+*                                                                   *
+*       what (1) = -1   extended check not performed                *
+*                                                    default: 1.    *
+*       what (2..6), sdum   no meaning                              *
+*                                                                   *
+*********************************************************************
+
+  230 CONTINUE
+      IF (WHAT(1).EQ.-1) THEN
+         LEMCCK = .FALSE.
+      ELSE
+         LEMCCK = .TRUE.
+      ENDIF
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = MODEL                       *
+*                                                                   *
+*     Model to be used to treat nucleon-nucleon interactions        *
+*                                                                   *
+*       sdum = DTUNUC    two-chain model                            *
+*            = PHOJET    multiple chains including minijets         *
+*            = LEPTO     DIS                                        *
+*            = QNEUTRIN  quasi-elastic neutrino scattering          *
+*                                                  default: PHOJET  *
+*                                                                   *
+*       if sdum = LEPTO:                                            *
+*       what (1)         (variable INTER)                           *
+*                        = 1  gamma exchange                        *
+*                        = 2  W+-   exchange                        *
+*                        = 3  Z0    exchange                        *
+*                        = 4  gamma/Z0 exchange                     *
+*                                                                   *
+*       if sdum = QNEUTRIN:                                         *
+*       what (1)         = 0  elastic scattering on nucleon and     *
+*                             tau does not decay (default)          *
+*                        = 1  decay of tau into mu..                *
+*                        = 2  decay of tau into e..                 *
+*                        = 10 CC events on p and n                  *
+*                        = 11 NC events on p and n                  *
+*                                                                   *
+*       what (2..6)      no meaning                                 *
+*                                                                   *
+*********************************************************************
+
+  240 CONTINUE
+      IF (SDUM.EQ.CMODEL(1)) THEN
+         MCGENE = 1
+      ELSEIF (SDUM.EQ.CMODEL(2)) THEN
+         MCGENE = 2
+      ELSEIF (SDUM.EQ.CMODEL(3)) THEN
+         MCGENE = 3
+         IF ((WHAT(1).GE.1.0D0).AND.(WHAT(1).LE.4.0D0))
+     &      INTER = INT(WHAT(1))
+      ELSEIF (SDUM.EQ.CMODEL(4)) THEN
+         MCGENE = 4
+         IWHAT  = INT(WHAT(1))
+         IF ((IWHAT.EQ.1 ).OR.(IWHAT.EQ.2 ).OR.
+     &       (IWHAT.EQ.10).OR.(IWHAT.EQ.11))
+     &      NEUDEC = IWHAT
+      ELSE
+         STOP ' Unknown model !'
+      ENDIF
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = PHOINPUT                    *
+*                                                                   *
+*       Start of input-section for PHOJET-specific input-cards      *
+*       Note:  This section will not be finished before giving      *
+*              ENDINPUT-card                                        *
+*       what (1..6), sdum   no meaning                              *
+*                                                                   *
+*********************************************************************
+
+  250 CONTINUE
+      IF (LPHOIN) THEN
+         CALL PHO_INIT(LINP,LOUT,IREJ1)
+         IF (IREJ1.NE.0) THEN
+            WRITE(LOUT,'(1X,A)')'INIT:   reading PHOJET-input failed'
+            STOP
+         ENDIF
+         LPHOIN = .FALSE.
+      ENDIF
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = GLAUBERI                    *
+*                                                                   *
+*        Pre-initialization of impact parameter selection           *
+*                                                                   *
+*        what (1..6), sdum   no meaning                             *
+*                                                                   *
+*********************************************************************
+
+  260 CONTINUE
+      IF (IFIRST.NE.99) THEN
+         CALL DT_RNDMST(12,34,56,78)
+         CALL DT_RNDMTE(1)
+         OPEN(40,FILE='outdata0/shm.out',STATUS='UNKNOWN')
+C        OPEN(11,FILE='outdata0/shm.dbg',STATUS='UNKNOWN')
+         IFIRST = 99
+      ENDIF
+
+      IPPN = 8
+      PLOW = 10.0D0
+C     IPPN = 1
+C     PLOW = 100.0D0
+      PHI  = 1.0D5
+      APLOW = LOG10(PLOW)
+      APHI  = LOG10(PHI)
+      ADP   = (APHI-APLOW)/DBLE(IPPN)
+
+      IPLOW = 1
+      IDIP  = 1
+      IIP   = 5
+C     IPLOW = 1
+C     IDIP  = 1
+C     IIP   = 1
+      IPRANG(1) = 1
+      IPRANG(2) = 2
+      IPRANG(3) = 5
+      IPRANG(4) = 10
+      IPRANG(5) = 20
+
+      ITLOW = 30
+      IDIT  = 3
+      IIT   = 60
+C     IDIT  = 10
+C     IIT   = 21
+
+      DO 473 NCIT=1,IIT
+         IT   = ITLOW+(NCIT-1)*IDIT
+C        IPHI = IT
+C        IDIP = 10
+C        IIP  = (IPHI-IPLOW)/IDIP
+C        IF (IIP.EQ.0) IIP = 1
+C        IF (IT.EQ.IPLOW) IIP = 0
+
+         DO 472 NCIP=1,IIP
+            IP = IPRANG(NCIP)
+CC           IF (NCIP.LE.IIP) THEN
+C               IP = IPLOW+(NCIP-1)*IDIP
+CC           ELSE
+CC              IP = IT
+CC           ENDIF
+            IF (IP.GT.IT) GOTO 472
+
+            DO 471 NCP=1,IPPN+1
+               APPN = APLOW+DBLE(NCP-1)*ADP
+               PPN  = 10**APPN
+
+               OPEN(12,FILE='outdata0/shm.sta',STATUS='UNKNOWN')
+               WRITE(12,'(1X,2I5,E15.3)') IP,IT,PPN
+               CLOSE(12)
+
+               XLIM1 = 0.0D0
+               XLIM2 = 50.0D0
+               XLIM3 = ZERO
+               IBIN  = 50
+               CALL DT_NEWHGR(XDUM,XDUM,XDUM,XDUMB,-1,IHDUM)
+               CALL DT_NEWHGR(XLIM1,XLIM2,XLIM3,XDUMB,IBIN,IHSHMA)
+
+               NEVFIT = 5
+C              IF ((IP.GT.10).OR.(IT.GT.10)) THEN
+C                 NEVFIT = 5
+C              ELSE
+C                 NEVFIT = 10
+C              ENDIF
+               SIGAV  = 0.0D0
+
+               DO 478 I=1,NEVFIT
+                  CALL DT_SHMAKI(IP,IDUM1,IT,IDUM1,IJPROJ,PPN,99)
+                  SIGAV = SIGAV+XSPRO(1,1,1)
+                  DO 479 J=1,50
+                     XC = DBLE(J)
+                     CALL DT_FILHGR(XC,BSITE(1,1,1,J),IHSHMA,I)
+  479             CONTINUE
+  478          CONTINUE
+
+               CALL DT_EVTHIS(IDUM)
+               HEADER = ' BSITE'
+C              CALL OUTGEN(IHSHMA,0,0,0,0,0,HEADER,0,NEVFIT,ONE,0,1,-1)
+
+C              CALL GENFIT(XPARA)
+C              WRITE(40,'(2I4,E11.3,F6.0,5E11.3)')
+C    &              IP,IT,PPN,SIGAV/DBLE(NEVFIT),XPARA
+
+  471       CONTINUE
+
+  472    CONTINUE
+
+  473 CONTINUE
+
+      STOP
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = FLUCTUAT                    *
+*                                                                   *
+*           Treatment of cross section fluctuations                 *
+*                                                                   *
+*       what (1) = 1  treat cross section fluctuations              *
+*                                                    default: 0.    *
+*       what (1..6), sdum   no meaning                              *
+*                                                                   *
+*********************************************************************
+
+ 270  CONTINUE
+      IFLUCT = 0
+      IF (WHAT(1).EQ.ONE) THEN
+         IFLUCT = 1
+         CALL DT_FLUINI
+      ENDIF
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = CENTRAL                     *
+*                                                                   *
+*       what (1) = 1.  central production forced     default: 0     *
+*  if what (1) < 0 and > -100                                       *
+*       what (2) = min. impact parameter             default: 0     *
+*       what (3) = max. impact parameter             default: b_max *
+*  if what (1) < -99                                                *
+*       what (2) = fraction of cross section         default: 1     *
+*  if what (1) = -1 : evaporation/fzc suppressed                    *
+*  if what (1) < -1 : evaporation/fzc allowed                       *
+*                                                                   *
+*       what (4..6), sdum   no meaning                              *
+*                                                                   *
+*********************************************************************
+
+  280 CONTINUE
+      ICENTR = INT(WHAT(1))
+      IF (ICENTR.LT.0) THEN
+         IF (ICENTR.GT.-100) THEN
+            BIMIN = WHAT(2)
+            BIMAX = WHAT(3)
+         ELSE
+            XSFRAC = WHAT(2)
+         ENDIF
+      ENDIF
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = RECOMBIN                    *
+*                                                                   *
+*                     Chain recombination                           *
+*        (recombine S-S and V-V chains to V-S chains)               *
+*                                                                   *
+*       what (1) = -1. recombination switched off    default: 1     *
+*       what (2..6), sdum   no meaning                              *
+*                                                                   *
+*********************************************************************
+
+  290 CONTINUE
+      IRECOM = 1
+      IF (WHAT(1).EQ.-1.0D0) IRECOM = 0
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = COMBIJET                    *
+*                                                                   *
+*               chain fusion (2 q-aq --> qq-aqaq)                   *
+*                                                                   *
+*       what (1) = 1   fusion treated                               *
+*                                                    default: 0.    *
+*       what (2)       minimum number of uncombined chains from     *
+*                      single projectile or target nucleons         *
+*                                                    default: 0.    *
+*       what (3..6), sdum   no meaning                              *
+*                                                                   *
+*********************************************************************
+
+  300 CONTINUE
+      LCO2CR = .FALSE.
+      IF (INT(WHAT(1)).EQ.1) LCO2CR = .TRUE.
+      IF (WHAT(2).GE.ZERO) CUTOF = WHAT(2)
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = XCUTS                       *
+*                                                                   *
+*                 thresholds for x-sampling                         *
+*                                                                   *
+*    what (1)    defines lower threshold for val.-q x-value (CVQ)   *
+*                                                 default: 1.       *
+*    what (2)    defines lower threshold for val.-qq x-value (CDQ)  *
+*                                                 default: 2.       *
+*    what (3)    defines lower threshold for sea-q x-value (CSEA)   *
+*                                                 default: 0.2      *
+*    what (4)    sea-q x-values in S-S chains (SSMIMA)              *
+*                                                 default: 0.14     *
+*    what (5)    not used                                           *
+*                                                 default: 2.       *
+*    what (6), sdum   no meaning                                    *
+*                                                                   *
+*    Note: Lower thresholds (what(1..3)) are def. as x_thr=CXXX/ECM *
+*                                                                   *
+*********************************************************************
+
+  310 CONTINUE
+      IF (WHAT(1).GE.0.5D0) CVQ    = WHAT(1)
+      IF (WHAT(2).GE.ONE)   CDQ    = WHAT(2)
+      IF (WHAT(3).GE.0.1D0) CSEA   = WHAT(3)
+      IF (WHAT(4).GE.ZERO) THEN
+         SSMIMA = WHAT(4)
+         SSMIMQ = SSMIMA**2
+      ENDIF
+      IF (WHAT(5).GT.2.0D0) VVMTHR = WHAT(5)
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = INTPT                       *
+*                                                                   *
+*     what (1) = -1   intrinsic transverse momenta of partons       *
+*                     not treated                default: 1         *
+*     what (2..6), sdum   no meaning                                *
+*                                                                   *
+*********************************************************************
+
+  320 CONTINUE
+      IF (WHAT(1).EQ.-1.0D0) THEN
+         LINTPT = .FALSE.
+      ELSE
+         LINTPT = .TRUE.
+      ENDIF
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = CRONINPT                    *
+*                                                                   *
+*    Cronin effect (multiple scattering of partons at chain ends)   *
+*                                                                   *
+*       what (1) = -1  Cronin effect not treated     default: 1     *
+*       what (2) = 0   scattering parameter          default: 0.64  *
+*       what (3..6), sdum   no meaning                              *
+*                                                                   *
+*********************************************************************
+
+  330 CONTINUE
+      IF (WHAT(1).EQ.-1.0D0) THEN
+         MKCRON = 0
+      ELSE
+         MKCRON = 1
+      ENDIF
+      CRONCO = WHAT(2)
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = SEADISTR                    *
+*                                                                   *
+*     what (1)  (XSEACO)  sea(x) prop. 1/x**what (1)   default: 1.  *
+*     what (2)  (UNON)                                 default: 2.  *
+*     what (3)  (UNOM)                                 default: 1.5 *
+*     what (4)  (UNOSEA)                               default: 5.  *
+*                        qdis(x) prop. (1-x)**what (1)  etc.        *
+*     what (5..6), sdum   no meaning                                *
+*                                                                   *
+*********************************************************************
+
+  340 CONTINUE
+      XSEACO = WHAT(1)
+      XSEACU = 1.05D0-XSEACO
+      UNON   = WHAT(2)
+      IF (UNON.LT.0.1D0) UNON = 2.0D0
+      UNOM   = WHAT(3)
+      IF (UNOM.LT.0.1D0) UNOM = 1.5D0
+      UNOSEA = WHAT(4)
+      IF (UNOSEA.LT.0.1D0) UNOSEA = 5.0D0
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = SEASU3                      *
+*                                                                   *
+*          Treatment of strange-quarks at chain ends                *
+*                                                                   *
+*       what (1)   (SEASQ)  strange-quark supression factor         *
+*                  iflav = 1.+rndm*(2.+SEASQ)                       *
+*                                                    default: 1.    *
+*       what (2..6), sdum   no meaning                              *
+*                                                                   *
+*********************************************************************
+
+  350 CONTINUE
+      SEASQ = WHAT(1)
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = DIQUARKS                    *
+*                                                                   *
+*     what (1) = -1.  sea-diquark/antidiquark-pairs not treated     *
+*                                                    default: 1.    *
+*     what (2..6), sdum   no meaning                                *
+*                                                                   *
+*********************************************************************
+
+ 360  CONTINUE
+      IF (WHAT(1).EQ.-1.0D0) THEN
+         LSEADI = .FALSE.
+      ELSE
+         LSEADI = .TRUE.
+      ENDIF
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = RESONANC                    *
+*                                                                   *
+*                 treatment of low mass chains                      *
+*                                                                   *
+*    what (1) = -1 low chain masses are not corrected for resonance *
+*                  masses (obsolete for BAMJET-fragmentation)       *
+*                                       default: 1.                 *
+*    what (2) = -1 massless partons     default: 1. (massive)       *
+*                                       default: 1. (massive)       *
+*    what (3) = -1 chain-system containing chain of too small       *
+*                  mass is rejected (note: this does not fully      *
+*                  apply to S-S chains) default: 0.                 *
+*    what (4..6), sdum   no meaning                                 *
+*                                                                   *
+*********************************************************************
+
+  370 CONTINUE
+      IRESCO = 1
+      IMSHL  = 1
+      IRESRJ = 0
+      IF (WHAT(1).EQ.-ONE) IRESCO = 0
+      IF (WHAT(2).EQ.-ONE) IMSHL  = 0
+      IF (WHAT(3).EQ.-ONE) IRESRJ = 1
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = DIFFRACT                    *
+*                                                                   *
+*                Treatment of diffractive events                    *
+*                                                                   *
+*     what (1) = (ISINGD) 0  no single diffraction                  *
+*                         1  single diffraction included            *
+*                       +-2  single diffractive events only         *
+*                       +-3  projectile single diffraction only     *
+*                       +-4  target single diffraction only         *
+*                        -5  double pomeron exchange only           *
+*                      (neg. sign applies to PHOJET events)         *
+*                                                     default: 0.   *
+*                                                                   *
+*     what (2) = (IDOUBD) 0  no double diffraction                  *
+*                         1  double diffraction included            *
+*                         2  double diffractive events only         *
+*                                                     default: 0.   *
+*     what (3) = 1 projectile diffraction treated (2-channel form.) *
+*                                                     default: 0.   *
+*     what (4) = alpha-parameter in projectile diffraction          *
+*                                                     default: 0.   *
+*     what (5..6), sdum   no meaning                                *
+*                                                                   *
+*********************************************************************
+
+  380 CONTINUE
+      IF (ABS(WHAT(1)).GT.ZERO) ISINGD = INT(WHAT(1))
+      IF (ABS(WHAT(2)).GT.ZERO) IDOUBD = INT(WHAT(2))
+      IF ((ISINGD.GT.1).AND.(IDOUBD.GT.1)) THEN
+         WRITE(LOUT,1380)
+ 1380    FORMAT(1X,'INIT:   inconsistent DIFFRACT - input !',/,
+     &          11X,'IDOUBD is reset to zero')
+         IDOUBD = 0
+      ENDIF
+      IF (WHAT(3).GT.ZERO) DIBETA = WHAT(3)
+      IF (WHAT(4).GT.ZERO) DIALPH = WHAT(4)
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = SINGLECH                    *
+*                                                                   *
+*       what (1) = 1.  Regge contribution (one chain) included      *
+*                                                   default: 0.     *
+*       what (2..6), sdum   no meaning                              *
+*                                                                   *
+*********************************************************************
+
+ 390  CONTINUE
+      ISICHA = 0
+      IF (WHAT(1).EQ.ONE) ISICHA = 1
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = NOFRAGME                    *
+*                                                                   *
+*                 biased chain hadronization                        *
+*                                                                   *
+*       what (1..6) = -1  no of hadronizsation of S-S chains        *
+*                   = -2  no of hadronizsation of D-S chains        *
+*                   = -3  no of hadronizsation of S-D chains        *
+*                   = -4  no of hadronizsation of S-V chains        *
+*                   = -5  no of hadronizsation of D-V chains        *
+*                   = -6  no of hadronizsation of V-S chains        *
+*                   = -7  no of hadronizsation of V-D chains        *
+*                   = -8  no of hadronizsation of V-V chains        *
+*                   = -9  no of hadronizsation of comb. chains      *
+*                                  default:  complete hadronization *
+*       sdum   no meaning                                           *
+*                                                                   *
+*********************************************************************
+
+  400 CONTINUE
+      DO 401 I=1,6
+         ICHAIN = INT(WHAT(I))
+         IF ((ICHAIN.LE.-1).AND.(ICHAIN.GE.-9))
+     &      LHADRO(ABS(ICHAIN)) = .FALSE.
+  401 CONTINUE
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = HADRONIZE                   *
+*                                                                   *
+*           hadronization model and parameter switch                *
+*                                                                   *
+*       what (1) = 1    hadronization via BAMJET                    *
+*                = 2    hadronization via JETSET                    *
+*                                                    default: 2     *
+*       what (2) = 1..3 parameter set to be used                    *
+*                       JETSET: 3 sets available                    *
+*                               ( = 3 default JETSET-parameters)    *
+*                       BAMJET: 1 set available                     *
+*                                                    default: 1     *
+*       what (3..6), sdum   no meaning                              *
+*                                                                   *
+*********************************************************************
+
+  410 CONTINUE
+      IWHAT1 = INT(WHAT(1))
+      IWHAT2 = INT(WHAT(2))
+      IF ((IWHAT1.EQ.1).OR.(IWHAT1.EQ.2)) IFRAG(1) = IWHAT1
+      IF ((IWHAT1.EQ.2).AND.(IWHAT2.GE.1).AND.(IWHAT2.LE.3))
+     &                                    IFRAG(2) = IWHAT2
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = POPCORN                     *
+*                                                                   *
+*  "Popcorn-effect" in fragmentation and diquark breaking diagrams  *
+*                                                                   *
+*   what (1) = (PDB) frac. of diquark fragmenting directly into     *
+*                    baryons (PYTHIA/JETSET fragmentation)          *
+*                    (JETSET: = 0. Popcorn mechanism switched off)  *
+*                                                    default: 0.5   *
+*   what (2) = probability for accepting a diquark breaking         *
+*              diagram involving the generation of a u/d quark-     *
+*              antiquark pair                        default: 0.0   *
+*   what (3) = same a what (2), here for s quark-antiquark pair     *
+*                                                    default: 0.0   *
+*   what (4..6), sdum   no meaning                                  *
+*                                                                   *
+*********************************************************************
+
+  420 CONTINUE
+      IF (WHAT(1).GE.0.0D0) PDB = WHAT(1)
+      IF (WHAT(2).GE.0.0D0) THEN
+         PDBSEA(1) = WHAT(2)
+         PDBSEA(2) = WHAT(2)
+      ENDIF
+      IF (WHAT(3).GE.0.0D0) PDBSEA(3) = WHAT(3)
+      DO 421 I=1,8
+         DBRKA(1,I) = DBRKR(1,I)*PDBSEA(1)/(1.D0-PDBSEA(1))
+         DBRKA(2,I) = DBRKR(2,I)*PDBSEA(2)/(1.D0-PDBSEA(2))
+         DBRKA(3,I) = DBRKR(3,I)*PDBSEA(3)/(1.D0-PDBSEA(3))
+  421 CONTINUE
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = PARDECAY                    *
+*                                                                   *
+*      what (1) = 1.  Sigma0/Asigma0 are decaying within JETSET     *
+*               = 2.  pion^0 decay after intranucl. cascade         *
+*                                                default: no decay  *
+*      what (2..6), sdum   no meaning                               *
+*                                                                   *
+*********************************************************************
+
+ 430  CONTINUE
+      IF (WHAT(1).EQ.ONE)  ISIG0 = 1
+      IF (WHAT(1).EQ.2.0D0) IPI0 = 1
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = BEAM                        *
+*                                                                   *
+*              definition of beam parameters                        *
+*                                                                   *
+*      what (1/2)  > 0 : energy of beam 1/2 (GeV)                   *
+*                  < 0 : abs(what(1/2)) energy per charge of        *
+*                        beam 1/2 (GeV)                             *
+*                  (beam 1 is directed into positive z-direction)   *
+*      what (3)    beam crossing angle, defined as 2x angle between *
+*                  one beam and the z-axis (micro rad)              *
+*      what (4)    angle with x-axis defining the collision plane   *
+*      what (5..6), sdum   no meaning                               *
+*                                                                   *
+*      Note: this card requires previously defined projectile and   *
+*            target identities (PROJPAR, TARPAR)                    *
+*                                                                   *
+*********************************************************************
+
+  440 CONTINUE
+      CALL DT_BEAMPR(WHAT,PPN,1)
+      EPN    = ZERO
+      CMENER = ZERO
+      LEINP  = .TRUE.
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = LUND-MSTU                   *
+*                                                                   *
+*          set parameter MSTU in JETSET-common /LUDAT1/             *
+*                                                                   *
+*       what (1) =  index according to LUND-common block            *
+*       what (2) =  new value of MSTU( int(what(1)) )               *
+*       what (3), what(4) and what (5), what(6) further             *
+*                   parameter in the same way as what (1) and       *
+*                   what (2)                                        *
+*                        default: default-Lund or corresponding to  *
+*                                 the set given in HADRONIZE        *
+*                                                                   *
+*********************************************************************
+
+  450 CONTINUE
+      IF (WHAT(1).GT.ZERO) THEN
+         NMSTU = NMSTU+1
+         IMSTU(NMSTU) = INT(WHAT(1))
+         MSTUX(NMSTU) = INT(WHAT(2))
+      ENDIF
+      IF (WHAT(3).GT.ZERO) THEN
+         NMSTU = NMSTU+1
+         IMSTU(NMSTU) = INT(WHAT(3))
+         MSTUX(NMSTU) = INT(WHAT(4))
+      ENDIF
+      IF (WHAT(5).GT.ZERO) THEN
+         NMSTU = NMSTU+1
+         IMSTU(NMSTU) = INT(WHAT(5))
+         MSTUX(NMSTU) = INT(WHAT(6))
+      ENDIF
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = LUND-MSTJ                   *
+*                                                                   *
+*          set parameter MSTJ in JETSET-common /LUDAT1/             *
+*                                                                   *
+*       what (1) =  index according to LUND-common block            *
+*       what (2) =  new value of MSTJ( int(what(1)) )               *
+*       what (3), what(4) and what (5), what(6) further             *
+*                   parameter in the same way as what (1) and       *
+*                   what (2)                                        *
+*                        default: default-Lund or corresponding to  *
+*                                 the set given in HADRONIZE        *
+*                                                                   *
+*********************************************************************
+
+  451 CONTINUE
+      IF (WHAT(1).GT.ZERO) THEN
+         NMSTJ = NMSTJ+1
+         IMSTJ(NMSTJ) = INT(WHAT(1))
+         MSTJX(NMSTJ) = INT(WHAT(2))
+      ENDIF
+      IF (WHAT(3).GT.ZERO) THEN
+         NMSTJ = NMSTJ+1
+         IMSTJ(NMSTJ) = INT(WHAT(3))
+         MSTJX(NMSTJ) = INT(WHAT(4))
+      ENDIF
+      IF (WHAT(5).GT.ZERO) THEN
+         NMSTJ = NMSTJ+1
+         IMSTJ(NMSTJ) = INT(WHAT(5))
+         MSTJX(NMSTJ) = INT(WHAT(6))
+      ENDIF
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = LUND-MDCY                   *
+*                                                                   *
+*  set parameter MDCY(I,1) for particle decays in JETSET-common     *
+*                                                      /LUDAT3/     *
+*                                                                   *
+*       what (1-6) = PDG particle index of particle which should    *
+*                    not decay                                      *
+*                        default: default-Lund or forced in         *
+*                                 DT_INITJS                         *
+*                                                                   *
+*********************************************************************
+
+  452 CONTINUE
+      DO 4521 I=1,6
+         IF (WHAT(I).NE.ZERO) THEN
+            KC = PYCOMP(INT(WHAT(I)))
+            MDCY(KC,1) = 0
+         ENDIF
+ 4521 CONTINUE
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = LUND-PARJ                   *
+*                                                                   *
+*          set parameter PARJ in JETSET-common /LUDAT1/             *
+*                                                                   *
+*       what (1) =  index according to LUND-common block            *
+*       what (2) =  new value of PARJ( int(what(1)) )               *
+*       what (3), what(4) and what (5), what(6) further             *
+*                   parameter in the same way as what (1) and       *
+*                   what (2)                                        *
+*                        default: default-Lund or corresponding to  *
+*                                 the set given in HADRONIZE        *
+*                                                                   *
+*********************************************************************
+
+  460 CONTINUE
+      IF (WHAT(1).NE.ZERO) THEN
+         NPARJ = NPARJ+1
+         IPARJ(NPARJ) = INT(WHAT(1))
+         PARJX(NPARJ) = WHAT(2)
+      ENDIF
+      IF (WHAT(3).NE.ZERO) THEN
+         NPARJ = NPARJ+1
+         IPARJ(NPARJ) = INT(WHAT(3))
+         PARJX(NPARJ) = WHAT(4)
+      ENDIF
+      IF (WHAT(5).NE.ZERO) THEN
+         NPARJ = NPARJ+1
+         IPARJ(NPARJ) = INT(WHAT(5))
+         PARJX(NPARJ) = WHAT(6)
+      ENDIF
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = LUND-PARU                   *
+*                                                                   *
+*          set parameter PARJ in JETSET-common /LUDAT1/             *
+*                                                                   *
+*       what (1) =  index according to LUND-common block            *
+*       what (2) =  new value of PARU( int(what(1)) )               *
+*       what (3), what(4) and what (5), what(6) further             *
+*                   parameter in the same way as what (1) and       *
+*                   what (2)                                        *
+*                        default: default-Lund or corresponding to  *
+*                                 the set given in HADRONIZE        *
+*                                                                   *
+*********************************************************************
+
+  470 CONTINUE
+      IF (WHAT(1).GT.ZERO) THEN
+         NPARU = NPARU+1
+         IPARU(NPARU) = INT(WHAT(1))
+         PARUX(NPARU) = WHAT(2)
+      ENDIF
+      IF (WHAT(3).GT.ZERO) THEN
+         NPARU = NPARU+1
+         IPARU(NPARU) = INT(WHAT(3))
+         PARUX(NPARU) = WHAT(4)
+      ENDIF
+      IF (WHAT(5).GT.ZERO) THEN
+         NPARU = NPARU+1
+         IPARU(NPARU) = INT(WHAT(5))
+         PARUX(NPARU) = WHAT(6)
+      ENDIF
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = OUTLEVEL                    *
+*                                                                   *
+*                    output control switches                        *
+*                                                                   *
+*       what (1) =  internal rejection informations  default: 0     *
+*       what (2) =  energy-momentum conservation check output       *
+*                                                    default: 0     *
+*       what (3) =  internal warning messages        default: 0     *
+*       what (4..6), sdum    not yet used                           *
+*                                                                   *
+*********************************************************************
+
+  480 CONTINUE
+      DO 481 K=1,6
+         IOULEV(K) = INT(WHAT(K))
+  481 CONTINUE
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = FRAME                       *
+*                                                                   *
+*          frame in which final state is given in DTEVT1            *
+*                                                                   *
+*       what (1) = 1  target rest frame (laboratory)                *
+*                = 2  nucleon-nucleon cms                           *
+*                                                    default: 1     *
+*                                                                   *
+*********************************************************************
+
+  490 CONTINUE
+      KFRAME = INT(WHAT(1))
+      IF ((KFRAME.GE.1).AND.(KFRAME.LE.2)) IFRAME = KFRAME
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = L-TAG                       *
+*                                                                   *
+*                        lepton tagger:                             *
+*   definition of kinematical cuts for radiated photon and          *
+*   outgoing lepton detection in lepton-nucleus interactions        *
+*                                                                   *
+*       what (1) = y_min                                            *
+*       what (2) = y_max                                            *
+*       what (3) = Q^2_min                                          *
+*       what (4) = Q^2_max                                          *
+*       what (5) = theta_min  (Lab)                                 *
+*       what (6) = theta_max  (Lab)                                 *
+*                                       default: no cuts            *
+*       sdum    no meaning                                          *
+*                                                                   *
+*********************************************************************
+
+  500 CONTINUE
+      YMIN  = WHAT(1)
+      YMAX  = WHAT(2)
+      Q2MIN = WHAT(3)
+      Q2MAX = WHAT(4)
+      THMIN = WHAT(5)
+      THMAX = WHAT(6)
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = L-ETAG                      *
+*                                                                   *
+*                        lepton tagger:                             *
+*       what (1) = min. outgoing lepton energy  (in Lab)            *
+*       what (2) = min. photon energy           (in Lab)            *
+*       what (3) = max. photon energy           (in Lab)            *
+*                                       default: no cuts            *
+*       what (2..6), sdum    no meaning                             *
+*                                                                   *
+*********************************************************************
+
+  510 CONTINUE
+      ELMIN = MAX(WHAT(1),ZERO)
+      EGMIN = MAX(WHAT(2),ZERO)
+      EGMAX = MAX(WHAT(3),ZERO)
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = ECMS-CUT                    *
+*                                                                   *
+*     what (1) = min. c.m. energy to be sampled                     *
+*     what (2) = max. c.m. energy to be sampled                     *
+*     what (3) = min x_Bj         to be sampled                     *
+*                                       default: no cuts            *
+*     what (3..6), sdum    no meaning                               *
+*                                                                   *
+*********************************************************************
+
+  520 CONTINUE
+      ECMIN  = WHAT(1)
+      ECMAX  = WHAT(2)
+      IF (ECMIN.GT.ECMAX) ECMIN = ECMAX
+      XBJMIN = MAX(WHAT(3),ZERO)
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = VDM-PAR1                    *
+*                                                                   *
+*      parameters in gamma-nucleus cross section calculation        *
+*                                                                   *
+*       what (1) =  Lambda^2                       default: 2.      *
+*       what (2)    lower limit in M^2 integration                  *
+*                =  1  (3m_pi)^2                                    *
+*                =  2  (m_rho0)^2                                   *
+*                =  3  (m_phi)^2                   default: 1       *
+*       what (3)    upper limit in M^2 integration                  *
+*                =  1   s/2                                         *
+*                =  2   s/4                                         *
+*                =  3   s                          default: 3       *
+*       what (4)    CKMT F_2 structure function                     *
+*                =  2212  proton                                    *
+*                =  100   deuteron                 default: 2212    *
+*       what (5)    calculation of gamma-nucleon xsections          *
+*                =  1  according to CKMT-parametrization of F_2     *
+*                =  2  integrating SIGVP over M^2                   *
+*                =  3  using SIGGA                                  *
+*                =  4  PHOJET cross sections       default:  4      *
+*                                                                   *
+*       what (6), sdum    no meaning                                *
+*                                                                   *
+*********************************************************************
+
+  530 CONTINUE
+      IF (WHAT(1).GE.ZERO) RL2 = WHAT(1)
+      IF ((WHAT(2).GE.1).AND.(WHAT(2).LE.3)) INTRGE(1) = INT(WHAT(2))
+      IF ((WHAT(3).GE.1).AND.(WHAT(3).LE.3)) INTRGE(2) = INT(WHAT(3))
+      IF ((WHAT(4).EQ.2212).OR.(WHAT(4).EQ.100)) IDPDF = INT(WHAT(4))
+      IF ((WHAT(5).GE.1).AND.(WHAT(5).LE.4)) MODEGA = INT(WHAT(5))
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = HISTOGRAM                   *
+*                                                                   *
+*           activate different classes of histograms                *
+*                                                                   *
+*                                default: no histograms             *
+*                                                                   *
+*********************************************************************
+
+  540 CONTINUE
+      DO 541 J=1,6
+         IF ((WHAT(J).GE.100).AND.(WHAT(J).LE.150)) THEN
+            IHISPP(INT(WHAT(J))-100) = 1
+         ELSEIF ((ABS(WHAT(J)).GE.200).AND.(ABS(WHAT(J)).LE.250)) THEN
+            IHISXS(INT(ABS(WHAT(J)))-200) = 1
+            IF (WHAT(J).LT.ZERO) IXSTBL = 1
+         ENDIF
+  541 CONTINUE
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = XS-TABLE                    *
+*                                                                   *
+*    output of cross section table for requested interaction        *
+*              - particle production deactivated ! -                *
+*                                                                   *
+*       what (1)      lower energy limit for tabulation             *
+*                > 0  Lab. frame                                    *
+*                < 0  nucleon-nucleon cms                           *
+*       what (2)      upper energy limit for tabulation             *
+*                > 0  Lab. frame                                    *
+*                < 0  nucleon-nucleon cms                           *
+*       what (3) > 0  # of equidistant lin. bins in E               *
+*                < 0  # of equidistant log. bins in E               *
+*       what (4)      lower limit of particle virtuality (photons)  *
+*       what (5)      upper limit of particle virtuality (photons)  *
+*       what (6) > 0  # of equidistant lin. bins in Q^2             *
+*                < 0  # of equidistant log. bins in Q^2             *
+*                                                                   *
+*********************************************************************
+
+  550 CONTINUE
+      IF (WHAT(1).EQ.99999.0D0) THEN
+         IRATIO = INT(WHAT(2))
+         GOTO 10
+      ENDIF
+      CMENER = ABS(WHAT(2))
+      IF (.NOT.LXSTAB) THEN
+         CALL DT_BERTTP
+         CALL DT_INCINI
+      ENDIF
+      IF ((.NOT.LXSTAB).OR.(CMENER.NE.CMEOLD)) THEN
+         CMEOLD = CMENER
+         IF (WHAT(2).GT.ZERO)
+     &      CMENER = SQRT(2.0D0*AAM(1)**2+2.0D0*WHAT(2)*AAM(1))
+         EPN = ZERO
+         PPN = ZERO
+C        WRITE(LOUT,*) 'CMENER = ',CMENER
+         CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,CMENER,1)
+         CALL DT_PHOINI
+      ENDIF
+      CALL DT_XSTABL(WHAT,IXSQEL,IRATIO)
+      IXSQEL = 0
+      LXSTAB = .TRUE.
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = GLAUB-PAR                   *
+*                                                                   *
+*                parameters in Glauber-formalism                    *
+*                                                                   *
+*    what (1)  # of nucleon configurations sampled in integration   *
+*              over nuclear desity                default: 1000     *
+*    what (2)  # of bins for integration over impact-parameter and  *
+*              for profile-function calculation   default: 49       *
+*    what (3)  = 1 calculation of tot., el. and qel. cross sections *
+*                                                 default: 0        *
+*    what (4)  = 1   read pre-calculated impact-parameter distrib.  *
+*                    from "sdum".glb                                *
+*              =-1   dump pre-calculated impact-parameter distrib.  *
+*                    into "sdum".glb                                *
+*              = 100 read pre-calculated impact-parameter distrib.  *
+*                    for variable projectile/target/energy runs     *
+*                    from "sdum".glb                                *
+*                                                 default: 0        *
+*    what (5..6)   no meaning                                       *
+*    sdum      if |what (4)| = 1 name of in/output-file (sdum.glb)  *
+*                                                                   *
+*********************************************************************
+
+  560 CONTINUE
+      IF (WHAT(1).GT.ZERO) JSTATB = INT(WHAT(1))
+      IF (WHAT(2).GT.ZERO) JBINSB = INT(WHAT(2))
+      IF (WHAT(3).EQ.ONE) LPROD = .FALSE.
+      IF ((ABS(WHAT(4)).EQ.ONE).OR.(WHAT(4).EQ.100)) THEN
+         IOGLB = INT(WHAT(4))
+         CGLB  = SDUM
+      ENDIF
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = GLAUB-INI                   *
+*                                                                   *
+*             pre-initialization of profile function                *
+*                                                                   *
+*       what (1)      lower energy limit for initialization         *
+*                > 0  Lab. frame                                    *
+*                < 0  nucleon-nucleon cms                           *
+*       what (2)      upper energy limit for initialization         *
+*                > 0  Lab. frame                                    *
+*                < 0  nucleon-nucleon cms                           *
+*       what (3) > 0  # of equidistant lin. bins in E               *
+*                < 0  # of equidistant log. bins in E               *
+*       what (4)      maximum projectile mass number for which the  *
+*                     Glauber data are initialized for each         *
+*                     projectile mass number                        *
+*                     (if <= mass given with the PROJPAR-card)      *
+*                                              default: 18          *
+*       what (5)      steps in mass number starting from what (4)   *
+*                     up to mass number defined with PROJPAR-card   *
+*                     for which Glauber data are initialized        *
+*                                              default: 5           *
+*       what (6)      no meaning                                    *
+*       sdum          no meaning                                    *
+*                                                                   *
+*********************************************************************
+
+  565 CONTINUE
+      IOGLB = -100
+      CALL DT_GLBINI(WHAT)
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = VDM-PAR2                    *
+*                                                                   *
+*      parameters in gamma-nucleus cross section calculation        *
+*                                                                   *
+*      what (1) = 0 no suppression of shadowing by direct photon    *
+*                   processes                                       *
+*               = 1 suppression ..                   default: 1     *
+*      what (2) = 0 no suppression of shadowing by anomalous        *
+*                   component if photon-F_2                         *
+*               = 1 suppression ..                   default: 1     *
+*      what (3) = 0 no suppression of shadowing by coherence        *
+*                   length of the photon                            *
+*               = 1 suppression ..                   default: 1     *
+*      what (4) = 1 longitudinal polarized photons are taken into   *
+*                   account                                         *
+*                   eps*R*Q^2/M^2 = what(4)*Q^2/M^2  default: 0     *
+*      what (5..6), sdum    no meaning                              *
+*                                                                   *
+*********************************************************************
+
+  570 CONTINUE
+      IF ((WHAT(1).EQ.ZERO).OR.(WHAT(1).EQ.ONE)) ISHAD(1) = INT(WHAT(1))
+      IF ((WHAT(2).EQ.ZERO).OR.(WHAT(2).EQ.ONE)) ISHAD(2) = INT(WHAT(2))
+      IF ((WHAT(3).EQ.ZERO).OR.(WHAT(3).EQ.ONE)) ISHAD(3) = INT(WHAT(3))
+      EPSPOL  = WHAT(4)
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  XS-QELPRO                            *
+*                                                                   *
+*     what (1..6), sdum    no meaning                               *
+*                                                                   *
+*********************************************************************
+
+  580 CONTINUE
+      IXSQEL = ABS(WHAT(1))
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  RNDMINIT                             *
+*                                                                   *
+*           initialization of random number generator               *
+*                                                                   *
+*     what (1..4)    values for initialization (= 1..168)           *
+*     what (5..6), sdum    no meaning                               *
+*                                                                   *
+*********************************************************************
+
+  590 CONTINUE
+      IF ((WHAT(1).LT.1.0D0).OR.(WHAT(1).GT.168.0D0)) THEN
+         NA1 = 22
+      ELSE
+         NA1 = WHAT(1)
+      ENDIF
+      IF ((WHAT(2).LT.1.0D0).OR.(WHAT(2).GT.168.0D0)) THEN
+         NA2 = 54
+      ELSE
+         NA2 = WHAT(2)
+      ENDIF
+      IF ((WHAT(3).LT.1.0D0).OR.(WHAT(3).GT.168.0D0)) THEN
+         NA3 = 76
+      ELSE
+         NA3 = WHAT(3)
+      ENDIF
+      IF ((WHAT(4).LT.1.0D0).OR.(WHAT(4).GT.168.0D0)) THEN
+         NA4 = 92
+      ELSE
+         NA4 = WHAT(4)
+      ENDIF
+      CALL DT_RNDMST(NA1,NA2,NA3,NA4)
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = LEPTO-CUT                   *
+*                                                                   *
+*          set parameter CUT in LEPTO-common /LEPTOU/               *
+*                                                                   *
+*       what (1) =  index in CUT-array                              *
+*       what (2) =  new value of CUT( int(what(1)) )                *
+*       what (3), what(4) and what (5), what(6) further             *
+*                   parameter in the same way as what (1) and       *
+*                   what (2)                                        *
+*                        default: default-LEPTO parameters          *
+*                                                                   *
+*********************************************************************
+
+  600 CONTINUE
+      IF (WHAT(1).GT.ZERO) CUT(INT(WHAT(1))) = WHAT(2)
+      IF (WHAT(3).GT.ZERO) CUT(INT(WHAT(3))) = WHAT(4)
+      IF (WHAT(5).GT.ZERO) CUT(INT(WHAT(5))) = WHAT(6)
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = LEPTO-LST                   *
+*                                                                   *
+*          set parameter LST in LEPTO-common /LEPTOU/               *
+*                                                                   *
+*       what (1) =  index in LST-array                              *
+*       what (2) =  new value of LST( int(what(1)) )                *
+*       what (3), what(4) and what (5), what(6) further             *
+*                   parameter in the same way as what (1) and       *
+*                   what (2)                                        *
+*                        default: default-LEPTO parameters          *
+*                                                                   *
+*********************************************************************
+
+  610 CONTINUE
+      IF (WHAT(1).GT.ZERO) LST(INT(WHAT(1))) = INT(WHAT(2))
+      IF (WHAT(3).GT.ZERO) LST(INT(WHAT(3))) = INT(WHAT(4))
+      IF (WHAT(5).GT.ZERO) LST(INT(WHAT(5))) = INT(WHAT(6))
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = LEPTO-PARL                  *
+*                                                                   *
+*          set parameter PARL in LEPTO-common /LEPTOU/              *
+*                                                                   *
+*       what (1) =  index in PARL-array                             *
+*       what (2) =  new value of PARL( int(what(1)) )               *
+*       what (3), what(4) and what (5), what(6) further             *
+*                   parameter in the same way as what (1) and       *
+*                   what (2)                                        *
+*                        default: default-LEPTO parameters          *
+*                                                                   *
+*********************************************************************
+
+  620 CONTINUE
+      IF (WHAT(1).GT.ZERO) PARL(INT(WHAT(1))) = WHAT(2)
+      IF (WHAT(3).GT.ZERO) PARL(INT(WHAT(3))) = WHAT(4)
+      IF (WHAT(5).GT.ZERO) PARL(INT(WHAT(5))) = WHAT(6)
+      GOTO 10
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = START                       *
+*                                                                   *
+*       what (1) =   number of events                default: 100.  *
+*       what (2) = 0 Glauber initialization follows                 *
+*                = 1 Glauber initialization supressed, fitted       *
+*                    results are used instead                       *
+*                    (this does not apply if emulsion-treatment     *
+*                     is requested)                                 *
+*                = 2 Glauber initialization is written to           *
+*                    output-file shmakov.out                        *
+*                = 3 Glauber initialization is read from input-file *
+*                    shmakov.out                     default: 0     *
+*       what (3..6)  no meaning                                     *
+*       what (3..6)  no meaning                                     *
+*                                                                   *
+*********************************************************************
+
+  630 CONTINUE
+
+* check for cross-section table output only
+      IF (LXSTAB) STOP
+
+      NCASES = INT(WHAT(1))
+      IF (NCASES.LE.0) NCASES = 100
+      IGLAU = INT(WHAT(2))
+      IF ((IGLAU.NE.1).AND.(IGLAU.NE.2).AND.(IGLAU.NE.3))
+     &                                            IGLAU = 0
+
+      NPMASS = IP
+      NPCHAR = IPZ
+      NTMASS = IT
+      NTCHAR = ITZ
+      IDP    = IJPROJ
+      IDT    = IJTARG
+      IF (IDP.LE.0) IDP = 1
+* muon neutrinos: temporary (missing index)
+* (new patch in projpar: therefore the following this is probably not
+*  necessary anymore..)
+C     IF (IDP.EQ.26) IDP = 5
+C     IF (IDP.EQ.27) IDP = 6
+
+* redefine collision energy
+      IF (LEINP) THEN
+         IF (ABS(VAREHI).GT.ZERO) THEN
+            PDUM = ZERO
+            IF (VARELO.LT.EHADLO) VARELO = EHADLO
+            CALL DT_LTINI(IDP,IDT,VARELO,PDUM,VARCLO,1)
+            PDUM = ZERO
+            CALL DT_LTINI(IDP,IDT,VAREHI,PDUM,VARCHI,1)
+         ENDIF
+         CALL DT_LTINI(IDP,IDT,EPN,PPN,CMENER,1)
+      ELSE
+         WRITE(LOUT,1003)
+ 1003    FORMAT(1X,'INIT:   collision energy not defined!',/,
+     &          1X,'              -program stopped-      ')
+         STOP
+      ENDIF
+
+* switch off evaporation (even if requested) if central coll. requ.
+      IF ((ICENTR.EQ.-1).OR.(ICENTR.GT.0).OR.(XSFRAC.LT.0.5D0)) THEN
+         IF (LEVPRT) THEN
+            WRITE(LOUT,1004)
+ 1004       FORMAT(1X,/,'Warning!  Evaporation request rejected since',
+     &             ' central collisions forced.')
+            LEVPRT = .FALSE.
+            LDEEXG = .FALSE.
+            LHEAVY = .FALSE.
+         ENDIF
+      ENDIF
+
+* initialization of evaporation-module
+
+      WRITE(LOUT,1010)
+ 1010 FORMAT(1X,/,'Warning!  No evaporation performed since',
+     &       ' evaporation modules not available with this version.')
+      LEVPRT = .FALSE.
+      LDEEXG = .FALSE.
+      LHEAVY = .FALSE.
+      LFRMBK = .FALSE.
+      IFISS  = 0
+      IEVFSS = 0
+      CALL DT_BERTTP
+      CALL DT_INCINI
+
+* save the default JETSET-parameter
+      CALL DT_JSPARA(0)
+
+* force use of phojet for g-A
+      IF ((IDP.EQ.7).AND.(MCGENE.NE.3)) MCGENE = 2
+* initialization of nucleon-nucleon event generator
+      IF (MCGENE.EQ.2) CALL DT_PHOINI
+* initialization of LEPTO event generator
+      IF (MCGENE.EQ.3) THEN
+
+         STOP ' This version does not contain LEPTO !'
+
+      ENDIF
+
+* initialization of quasi-elastic neutrino scattering
+      IF (MCGENE.EQ.4) THEN
+         IF (IJPROJ.EQ.5) THEN
+            NEUTYP = 1
+         ELSEIF (IJPROJ.EQ.6) THEN
+            NEUTYP = 2
+         ELSEIF (IJPROJ.EQ.135) THEN
+            NEUTYP = 3
+         ELSEIF (IJPROJ.EQ.136) THEN
+            NEUTYP = 4
+         ELSEIF (IJPROJ.EQ.133) THEN
+            NEUTYP = 5
+         ELSEIF (IJPROJ.EQ.134) THEN
+            NEUTYP = 6
+         ENDIF
+      ENDIF
+
+* normalize fractions of emulsion components
+      IF (NCOMPO.GT.0) THEN
+         SUMFRA = ZERO
+         DO 491 I=1,NCOMPO
+            SUMFRA = SUMFRA+EMUFRA(I)
+  491    CONTINUE
+         IF (SUMFRA.GT.ZERO) THEN
+            DO 492 I=1,NCOMPO
+               EMUFRA(I) = EMUFRA(I)/SUMFRA
+  492       CONTINUE
+         ENDIF
+      ENDIF
+
+* disallow Cronin's multiple scattering for nucleus-nucleus interactions
+      IF ((IP.GT.1).AND.(MKCRON.GT.0)) THEN
+         WRITE(LOUT,1005)
+ 1005    FORMAT(/,1X,'INIT:  multiple scattering disallowed',/)
+         MKCRON = 0
+      ENDIF
+
+* initialization of Glauber-formalism (moved to xAEVT, sr 26.3.96)
+C     IF (NCOMPO.LE.0) THEN
+C        CALL DT_SHMAKI(IP,IPZ,IT,ITZ,IDP,PPN,IGLAU)
+C     ELSE
+C        DO 493 I=1,NCOMPO
+C           CALL DT_SHMAKI(IP,IPZ,IEMUMA(I),IEMUCH(I),IDP,PPN,0)
+C 493    CONTINUE
+C     ENDIF
+
+* pre-tabulation of elastic cross-sections
+      CALL DT_SIGTBL(JDUM,JDUM,DUM,DUM,-1)
+
+      CALL DT_XTIME
+
+      RETURN
+
+*********************************************************************
+*                                                                   *
+*               control card:  codewd = STOP                        *
+*                                                                   *
+*               stop of the event generation                        *
+*                                                                   *
+*       what (1..6)  no meaning                                     *
+*                                                                   *
+*********************************************************************
+
+ 9999 CONTINUE
+      WRITE(LOUT,9000)
+ 9000 FORMAT(1X,'---> unexpected end of input !')
+
+  640 CONTINUE
+      STOP
+
+      END
+
+*$ CREATE DT_KKINC.FOR
+*COPY DT_KKINC
+*
+*===kkinc==============================================================*
+*
+      SUBROUTINE DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,
+     &                                                         IREJ)
+
+************************************************************************
+* Treatment of complete nucleus-nucleus or hadron-nucleus scattering   *
+* This subroutine is an update of the previous version written         *
+* by J. Ranft/ H.-J. Moehring.                                         *
+* This version dated 19.11.95 is written by S. Roesler                 *
+************************************************************************
+
+      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+      SAVE
+      PARAMETER ( LINP = 10 ,
+     &            LOUT = 6 ,
+     &            LDAT = 9 )
+      PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY5=1.0D-5,
+     &           TINY2=1.0D-2,TINY3=1.0D-3)
+
+      LOGICAL LFZC
+
+* event history
+      PARAMETER (NMXHKK=200000)
+      COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+     &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+     &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+* extended event history
+      COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+     &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+     &                IHIST(2,NMXHKK)
+* particle properties (BAMJET index convention)
+      CHARACTER*8  ANAME
+      COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+     &                IICH(210),IIBAR(210),K1(210),K2(210)
+* properties of interacting particles
+      COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+* Lorentz-parameters of the current interaction
+      COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+     &                UMO,PPCM,EPROJ,PPROJ
+* flags for input different options
+      LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+      COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+     &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+* flags for particle decays
+      COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
+     &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
+     &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
+* cuts for variable energy runs
+      COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
+* Glauber formalism: flags and parameters for statistics
+      LOGICAL LPROD
+      CHARACTER*8 CGLB
+      COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
+
+      DIMENSION WHAT(6)
+
+      IREJ  = 0
+      ILOOP = 0
+  100 CONTINUE
+      IF (ILOOP.EQ.4) THEN
+         WRITE(LOUT,1000) NEVHKK
+ 1000    FORMAT(1X,'KKINC: event ',I8,' rejected!')
+         GOTO 9999
+      ENDIF
+      ILOOP = ILOOP+1
+
+* variable energy-runs, recalculate parameters for LT's
+      IF ((ABS(VAREHI).GT.ZERO).OR.(IOGLB.EQ.100)) THEN
+         PDUM = ZERO
+         CDUM = ZERO
+         CALL DT_LTINI(IDP,1,EPN,PDUM,CDUM,1)
+      ENDIF
+      IF (EPN.GT.EPROJ) THEN
+         WRITE(LOUT,'(A,E9.3,2A,E9.3,A)')
+     &      ' Requested energy (',EPN,'GeV) exceeds',
+     &      ' initialization energy (',EPROJ,'GeV) !'
+         STOP
+      ENDIF
+
+* re-initialize /DTPRTA/
+      IP  = NPMASS
+      IPZ = NPCHAR
+      IT  = NTMASS
+      ITZ = NTCHAR
+      IJPROJ = IDP
+      IBPROJ = IIBAR(IJPROJ)
+
+* calculate nuclear potentials (common /DTNPOT/)
+      CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
+
+* initialize treatment for residual nuclei
+      CALL DT_RESNCL(EPN,NLOOP,1)
+
+* sample hadron/nucleus-nucleus interaction
+      CALL DT_KKEVNT(KKMAT,IREJ1)
+      IF (IREJ1.GT.0) THEN
+         IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKINC'
+         GOTO 9999
+      ENDIF
+
+      IF ((NPMASS.GT.1).OR.(NTMASS.GT.1)) THEN
+
+* intranuclear cascade of final state particles for KTAUGE generations
+* of secondaries
+         CALL DT_FOZOCA(LFZC,IREJ1)
+         IF (IREJ1.GT.0) THEN
+            IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKINC'
+            GOTO 9999
+         ENDIF
+
+* baryons unable to escape the nuclear potential are treated as
+* excited nucleons (ISTHKK=15,16)
+         CALL DT_SCN4BA
+
+* decay of resonances produced in intranuclear cascade processes
+**sr 15-11-95 should be obsolete
+C        IF (LFZC) CALL DT_DECAY1
+
+  101    CONTINUE
+* treatment of residual nuclei
+         CALL DT_RESNCL(EPN,NLOOP,2)
+
+* evaporation / fission / fragmentation
+* (if intranuclear cascade was sampled only)
+         IF (LFZC) THEN
+            CALL DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ1)
+            IF (IREJ1.GT.1) GOTO 101
+            IF (IREJ1.EQ.1) GOTO 100
+         ENDIF
+
+      ENDIF
+
+* rejection of unphysical configurations
+      CALL DT_REJUCO(1,IREJ1)
+      IF (IREJ1.GT.0) THEN
+         IF (IOULEV(1).GT.0)
+     &      WRITE(LOUT,*) 'rejected 3 in KKINC: too large x'
+         GOTO 100
+      ENDIF
+
+* transform finale state into Lab.
+      IFLAG = 2
+      CALL DT_BEAMPR(WHAT,DUM,IFLAG)
+      IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB
+
+      IF (IPI0.EQ.1) CALL DT_DECPI0
+
+C     IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4)
+
+      RETURN
+ 9999 CONTINUE
+      IREJ = 1
+      RETURN
+      END
+
+*$ CREATE DT_DEFAUL.FOR
+*COPY DT_DEFAUL
+*
+*===defaul=============================================================*
+*
+      SUBROUTINE DT_DEFAUL(EPN,PPN)
+
+************************************************************************
+* Variables are set to default values.                                 *
+* This version dated 8.5.95 is written by S. Roesler.                  *
+************************************************************************
+
+      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+      SAVE
+      PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
+      PARAMETER (TWOPI  = 6.283185307179586454D+00)
+
+* particle properties (BAMJET index convention)
+      CHARACTER*8  ANAME
+      COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+     &                IICH(210),IIBAR(210),K1(210),K2(210)
+* nuclear potential
+      LOGICAL LFERMI
+      COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
+     &                EBINDP(2),EBINDN(2),EPOT(2,210),
+     &                ETACOU(2),ICOUL,LFERMI
+* interface HADRIN-DPM
+      COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
+* central particle production, impact parameter biasing
+      COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
+* properties of interacting particles
+      COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+* properties of photon/lepton projectiles
+      COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
+      PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+* emulsion treatment
+      COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
+     &                NCOMPO,IEMUL
+* parameter for intranuclear cascade
+      LOGICAL LPAULI
+      COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
+* various options for treatment of partons (DTUNUC 1.x)
+* (chain recombination, Cronin,..)
+      LOGICAL LCO2CR,LINTPT
+      COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
+     &                LCO2CR,LINTPT
+* threshold values for x-sampling (DTUNUC 1.x)
+      COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
+     &                SSMIMQ,VVMTHR
+* flags for input different options
+      LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+      COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+     &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+* n-n cross section fluctuations
+      PARAMETER (NBINS = 1000)
+      COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
+* flags for particle decays
+      COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
+     &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
+     &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
+* diquark-breaking mechanism
+      COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
+* nucleon-nucleon event-generator
+      CHARACTER*8 CMODEL
+      LOGICAL LPHOIN
+      COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+* flags for diffractive interactions (DTUNUC 1.x)
+      COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
+* VDM parameter for photon-nucleus interactions
+      COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
+* Glauber formalism: flags and parameters for statistics
+      LOGICAL LPROD
+      CHARACTER*8 CGLB
+      COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
+* kinematical cuts for lepton-nucleus interactions
+      COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
+     &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
+* flags for activated histograms
+      COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
+* cuts for variable energy runs
+      COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
+* parameters for hA-diffraction
+      COMMON /DTDIHA/ DIBETA,DIALPH
+* LEPTO
+      REAL RPPN
+      COMMON /LEPTOI/ RPPN,LEPIN,INTER
+* steering flags for qel neutrino scattering modules
+      COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
+* event flag
+      COMMON /DTEVNO/ NEVENT,ICASCA
+
+      DATA POTMES /0.002D0/
+
+* common /DTNPOT/
+      DO 10 I=1,2
+         PFERMP(I) = ZERO
+         PFERMN(I) = ZERO
+         EBINDP(I) = ZERO
+         EBINDN(I) = ZERO
+         DO 11 J=1,210
+            EPOT(I,J) = ZERO
+   11    CONTINUE
+* nucleus independent meson potential
+         EPOT(I,13) = POTMES
+         EPOT(I,14) = POTMES
+         EPOT(I,15) = POTMES
+         EPOT(I,16) = POTMES
+         EPOT(I,23) = POTMES
+         EPOT(I,24) = POTMES
+         EPOT(I,25) = POTMES
+   10 CONTINUE
+      FERMOD    = 0.55D0
+      ETACOU(1) = ZERO
+      ETACOU(2) = ZERO
+      ICOUL     = 1
+      LFERMI    = .TRUE.
+
+* common /HNTHRE/
+      EHADTH = -99.0D0
+      EHADLO = 4.06D0
+      EHADHI = 6.0D0
+      INTHAD = 1
+      IDXTA  = 2
+
+* common /DTIMPA/
+      ICENTR = 0
+      BIMIN  = ZERO
+      BIMAX  = 1.0D10
+      XSFRAC = 1.0D0
+
+* common /DTPRTA/
+      IP  = 1
+      IPZ = 1
+      IT  = 1
+      ITZ = 1
+      IJPROJ = 1
+      IBPROJ = 1
+      IJTARG = 1
+      IBTARG = 1
+* common /DTGPRO/
+      VIRT = ZERO
+      DO 14 I=1,4
+         PGAMM(I)  = ZERO
+         PLEPT0(I) = ZERO
+         PLEPT1(I) = ZERO
+         PNUCL(I)  = ZERO
+   14 CONTINUE
+      IDIREC   = 0
+
+* common /DTFOTI/
+**sr 7.4.98: changed after corrected B-sampling
+C     TAUFOR = 4.4D0
+      TAUFOR = 3.5D0
+      KTAUGE = 25
+      ITAUVE = 1
+      INCMOD = 1
+      LPAULI = .TRUE.
+
+* common /DTCHAI/
+      SEASQ  = ONE
+      MKCRON = 1
+      CRONCO = 0.64D0
+      ISICHA = 0
+      CUTOF  = 100.0D0
+      LCO2CR = .FALSE.
+      IRECOM = 1
+      LINTPT = .TRUE.
+
+* common /DTXCUT/
+*  definition of soft quark distributions
+      XSEACU = 0.05D0
+      UNON   = 2.0D0
+      UNOM   = 1.5D0
+      UNOSEA = 5.0D0
+*  cutoff parameters for x-sampling
+      CVQ    = 1.0D0
+      CDQ    = 2.0D0
+C     CSEA   = 0.3D0
+      CSEA   = 0.1D0
+      SSMIMA = 1.2D0
+      SSMIMQ = SSMIMA**2
+      VVMTHR = 2.0D0
+
+* common /DTXSFL/
+      IFLUCT = 0
+
+* common /DTFRPA/
+      PDB = 0.15D0
+      PDBSEA(1) = 0.0D0
+      PDBSEA(2) = 0.0D0
+      PDBSEA(3) = 0.0D0
+      ISIG0 = 0
+      IPI0  = 0
+      NMSTU = 0
+      NPARU = 0
+      NMSTJ = 0
+      NPARJ = 0
+
+* common /DTDIQB/
+      DO 15 I=1,8
+         DBRKR(1,I) = 5.0D0
+         DBRKR(2,I) = 5.0D0
+         DBRKR(3,I) = 10.0D0
+         DBRKA(1,I) = ZERO
+         DBRKA(2,I) = ZERO
+         DBRKA(3,I) = ZERO
+   15 CONTINUE
+      CHAM1 = 0.2D0
+      CHAM3 = 0.5D0
+      CHAB1 = 0.7D0
+      CHAB3 = 1.0D0
+
+* common /DTFLG3/
+      ISINGD = 0
+      IDOUBD = 0
+      IFLAGD = 0
+      IDIFF  = 0
+
+* common /DTMODL/
+      MCGENE    = 2
+      CMODEL(1) = 'DTUNUC  '
+      CMODEL(2) = 'PHOJET  '
+      CMODEL(3) = 'LEPTO   '
+      CMODEL(4) = 'QNEUTRIN'
+      LPHOIN    = .TRUE.
+      ELOJET    = 5.0D0
+
+* common /DTLCUT/
+      ECMIN  = 3.5D0
+      ECMAX  = 1.0D10
+      XBJMIN = ZERO
+      ELMIN = ZERO
+      EGMIN = ZERO
+      EGMAX = 1.0D10
+      YMIN  = TINY10
+      YMAX  = 0.999D0
+      Q2MIN = TINY10
+      Q2MAX = 10.0D0
+      THMIN = ZERO
+      THMAX = TWOPI
+      Q2LI  = ZERO
+      Q2HI  = 1.0D10
+      ECMLI = ZERO
+      ECMHI = 1.0D10
+
+* common /DTVDMP/
+      RL2       = 2.0D0
+      INTRGE(1) = 1
+      INTRGE(2) = 3
+      IDPDF     = 2212
+      MODEGA    = 4
+      ISHAD(1)  = 1
+      ISHAD(2)  = 1
+      ISHAD(3)  = 1
+      EPSPOL    = ZERO
+
+* common /DTGLGP/
+      JSTATB = 1000
+      JBINSB = 49
+      CGLB   = '        '
+      IF (ITRSPT.EQ.1) THEN
+         IOGLB  = 100
+      ELSE
+         IOGLB  = 0
+      ENDIF
+      LPROD  = .TRUE.
+
+* common /DTHIS3/
+      DO 16 I=1,50
+         IHISPP(I) = 0
+         IHISXS(I) = 0
+   16 CONTINUE
+      IXSTBL = 0
+
+* common /DTVARE/
+      VARELO = ZERO
+      VAREHI = ZERO
+      VARCLO = ZERO
+      VARCHI = ZERO
+
+* common /DTDIHA/
+      DIBETA = -1.0D0
+      DIALPH = ZERO
+
+* common /LEPTOI/
+      RPPN  = 0.0
+      LEPIN = 0
+      INTER = 0
+
+* common /QNEUTO/
+      NEUTYP = 1
+      NEUDEC = 0
+
+* common /DTEVNO/
+      NEVENT = 1
+      IF (ITRSPT.EQ.1) THEN
+         ICASCA = 1
+      ELSE
+         ICASCA = 0
+      ENDIF
+
+* default Lab.-energy
+      EPN = 200.0D0
+      PPN = SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ)))
+
+      RETURN
+      END
+
+*$ CREATE DT_AAEVT.FOR
+*COPY DT_AAEVT
+*
+*===aaevt==============================================================*
+*
+      SUBROUTINE DT_AAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
+     &                                             IDP,IGLAU)
+
+************************************************************************
+* This version dated 22.03.96 is written by S. Roesler.                *
+************************************************************************
+
+      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+      SAVE
+      PARAMETER ( LINP = 10 ,
+     &            LOUT = 6 ,
+     &            LDAT = 9 )
+
+      PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+* emulsion treatment
+      COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
+     &                NCOMPO,IEMUL
+* event flag
+      COMMON /DTEVNO/ NEVENT,ICASCA
+
+      CHARACTER*8 DATE,HHMMSS
+      DIMENSION IDMNYR(3)
+
+      KKMAT  = 1
+      NMSG   = MAX(NEVTS/100,1)
+
+* initialization of run-statistics and histograms
+      CALL DT_STATIS(1)
+      CALL PHO_PHIST(1000,DUM)
+
+* initialization of Glauber-formalism
+      IF (NCOMPO.LE.0) THEN
+         CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
+      ELSE
+         DO 1 I=1,NCOMPO
+            CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
+    1    CONTINUE
+      ENDIF
+      CALL DT_SIGEMU
+
+      CALL IDATE(IDMNYR)
+      WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
+     &   IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
+      CALL ITIME(IDMNYR)
+      WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
+     &   IDMNYR(1),IDMNYR(2),IDMNYR(3)
+      WRITE(LOUT,1001) DATE,HHMMSS
+ 1001 FORMAT(/,' DT_AAEVT: Initialisation finished. ( Date: ',A8,
+     &       '   Time: ',A8,' )')
+
+* generate NEVTS events
+      DO 2 IEVT=1,NEVTS
+
+*  print run-status message
+         IF (MOD(IEVT,NMSG).EQ.0) THEN
+            CALL IDATE(IDMNYR)
+            WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
+     &         IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
+            CALL ITIME(IDMNYR)
+            WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
+     &         IDMNYR(1),IDMNYR(2),IDMNYR(3)
+            WRITE(LOUT,1000) IEVT-1,NEVTS,DATE,HHMMSS
+ 1000       FORMAT(/,1X,I8,' out of ',I8,' events sampled ( Date: ',A,
+     &             '   Time: ',A,' )',/)
+C           WRITE(LOUT,1000) IEVT-1
+C1000       FORMAT(1X,I8,' events sampled')
+         ENDIF
+         NEVENT = IEVT
+*  treat nuclear emulsions
+         IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
+*  composite targets only
+         KKMAT = -KKMAT
+*  sample this event
+         CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ)
+
+         CALL PHO_PHIST(2000,DUM)
+
+    2 CONTINUE
+
+* print run-statistics and histograms to output-unit 6
+      CALL PHO_PHIST(3000,DUM)
+      CALL DT_STATIS(2)
+
+      RETURN
+      END
+
+*$ CREATE DT_LAEVT.FOR
+*COPY DT_LAEVT
+*
+*===laevt==============================================================*
+*
+      SUBROUTINE DT_LAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
+     &                                             IDP,IGLAU)
+
+************************************************************************
+* Interface to run DPMJET for lepton-nucleus interactions.             *
+* Kinematics is sampled using the equivalent photon approximation      *
+* Based on GPHERA-routine by R. Engel.                                 *
+* This version dated 23.03.96 is written by S. Roesler.                *
+************************************************************************
+
+      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+      SAVE
+      PARAMETER ( LINP = 10 ,
+     &            LOUT = 6 ,
+     &            LDAT = 9 )
+      PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,
+     &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
+      PARAMETER (TWOPI  = 6.283185307179586454D+00,
+     &           PI     = TWOPI/TWO,
+     &           ALPHEM = ONE/137.0D0)
+
+C     CHARACTER*72 HEADER
+
+* particle properties (BAMJET index convention)
+      CHARACTER*8  ANAME
+      COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+     &                IICH(210),IIBAR(210),K1(210),K2(210)
+* event history
+      PARAMETER (NMXHKK=200000)
+      COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+     &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+     &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+* extended event history
+      COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+     &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+     &                IHIST(2,NMXHKK)
+* kinematical cuts for lepton-nucleus interactions
+      COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
+     &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
+* properties of interacting particles
+      COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+* properties of photon/lepton projectiles
+      COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
+* kinematics at lepton-gamma vertex
+      COMMON /DTLGVX/ PPL0(4),PPL1(4),PPG(4),PPA(4)
+* flags for activated histograms
+      COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
+      PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+* emulsion treatment
+      COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
+     &                NCOMPO,IEMUL
+* Glauber formalism: cross sections
+      COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
+     &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
+     &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
+     &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
+     &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
+     &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
+     &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
+     &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
+     &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
+     &                BSLOPE,NEBINI,NQBINI
+* nucleon-nucleon event-generator
+      CHARACTER*8 CMODEL
+      LOGICAL LPHOIN
+      COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+* flags for input different options
+      LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+      COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+     &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+* event flag
+      COMMON /DTEVNO/ NEVENT,ICASCA
+
+      DIMENSION XDUMB(40),BGTA(4)
+
+* LEPTO
+      IF (MCGENE.EQ.3) THEN
+         STOP ' This version does not contain LEPTO !'
+      ENDIF
+
+      KKMAT  = 1
+      NMSG   = MAX(NEVTS/10,1)
+
+* mass of incident lepton
+      AMLPT  = AAM(IDP)
+      AMLPT2 = AMLPT**2
+      IDPPDG = IDT_IPDGHA(IDP)
+
+* consistency of kinematical limits
+      Q2MIN  = MAX(Q2MIN,TINY10)
+      Q2MAX  = MAX(Q2MAX,TINY10)
+      YMIN   = MIN(MAX(YMIN,TINY10),0.999D0)
+      YMAX   = MIN(MAX(YMAX,TINY10),0.999D0)
+
+* total energy of the lepton-nucleon system
+      PTOTLN = SQRT( (PLEPT0(1)+PNUCL(1))**2+(PLEPT0(2)+PNUCL(2))**2
+     &                                      +(PLEPT0(3)+PNUCL(3))**2 )
+      ETOTLN = PLEPT0(4)+PNUCL(4)
+      ECMLN  = SQRT((ETOTLN-PTOTLN)*(ETOTLN+PTOTLN))
+      ECMAX  = MIN(ECMAX,ECMLN)
+      WRITE(LOUT,1003) ECMIN,ECMAX,YMIN,YMAX,Q2MIN,Q2MAX,EGMIN,
+     &                 THMIN,THMAX,ELMIN
+ 1003 FORMAT(1X,'LAEVT:',16X,'kinematical cuts',/,22X,
+     &       '------------------',/,9X,'W (min)   =',
+     &       F7.1,' GeV    (max) =',F7.1,' GeV',/,9X,'y (min)   =',
+     &       F7.3,8X,'(max) =',F7.3,/,9X,'Q^2 (min) =',F7.1,
+     &       ' GeV^2  (max) =',F7.1,' GeV^2',/,' (Lab)   E_g (min) ='
+     &       ,F7.1,' GeV',/,' (Lab) theta (min) =',F7.4,8X,'(max) =',
+     &       F7.4,'   for E_lpt >',F7.1,' GeV',/)
+
+* Lorentz-parameter for transf. into Lab
+      BGTA(1) = PNUCL(1)/AAM(1)
+      BGTA(2) = PNUCL(2)/AAM(1)
+      BGTA(3) = PNUCL(3)/AAM(1)
+      BGTA(4) = PNUCL(4)/AAM(1)
+* LT of incident lepton into Lab and dump it in DTEVT1
+      CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
+     &            PLEPT0(1),PLEPT0(2),PLEPT0(3),PLEPT0(4),
+     &            PLTOT,PPL0(1),PPL0(2),PPL0(3),PPL0(4))
+      CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
+     &            PNUCL(1),PNUCL(2),PNUCL(3),PNUCL(4),
+     &            PLTOT,PPA(1),PPA(2),PPA(3),PPA(4))
+* maximum energy of photon nucleon system
+      PTOTGN = SQRT((YMAX*PPL0(1)+PPA(1))**2+(YMAX*PPL0(2)+PPA(2))**2
+     &                                      +(YMAX*PPL0(3)+PPA(3))**2)
+      ETOTGN = YMAX*PPL0(4)+PPA(4)
+      EGNMAX = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
+      EGNMAX = MIN(EGNMAX,ECMAX)
+* minimum energy of photon nucleon system
+      PTOTGN = SQRT((YMIN*PPL0(1)+PPA(1))**2+(YMIN*PPL0(2)+PPA(2))**2
+     &                                      +(YMIN*PPL0(3)+PPA(3))**2)
+      ETOTGN = YMIN*PPL0(4)+PPA(4)
+      EGNMIN = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
+      EGNMIN = MAX(EGNMIN,ECMIN)
+
+* limits for Glauber-initialization
+      Q2LI  = Q2MIN
+      Q2HI  = MAX(Q2LI,MIN(Q2HI,Q2MAX))
+      ECMLI = MAX(EGNMIN,THREE)
+      ECMHI = EGNMAX
+      WRITE(LOUT,1004) EGNMIN,EGNMAX,ECMLI,ECMHI,Q2LI,Q2HI
+ 1004 FORMAT(1X,'resulting limits:',/,9X,'W (min)   =',F7.1,
+     &       ' GeV    (max) =',F7.1,' GeV',/,/,' limits for ',
+     &       'Glauber-initialization:',/,9X,'W (min)   =',F7.1,
+     &       ' GeV    (max) =',F7.1,' GeV',/,9X,'Q^2 (min) =',F7.1,
+     &       ' GeV^2  (max) =',F7.1,' GeV^2',/)
+* initialization of Glauber-formalism
+      IF (NCOMPO.LE.0) THEN
+         CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
+      ELSE
+         DO 9 I=1,NCOMPO
+            CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
+    9    CONTINUE
+      ENDIF
+      CALL DT_SIGEMU
+
+* initialization of run-statistics and histograms
+      CALL DT_STATIS(1)
+      CALL PHO_PHIST(1000,DUM)
+
+* maximum photon-nucleus cross section
+      I1  = 1
+      I2  = 1
+      RAT = ONE
+      IF (EGNMAX.GE.ECMNN(NEBINI)) THEN
+         I1  = NEBINI
+         I2  = NEBINI
+         RAT = ONE
+      ELSEIF (EGNMAX.GT.ECMNN(1)) THEN
+         DO 5 I=2,NEBINI
+            IF (EGNMAX.LT.ECMNN(I)) THEN
+               I1  = I-1
+               I2  = I
+               RAT = (EGNMAX-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
+               GOTO 6
+            ENDIF
+    5    CONTINUE
+    6    CONTINUE
+      ENDIF
+      SIGMAX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
+      EGNXX  = EGNMAX
+      I1  = 1
+      I2  = 1
+      RAT = ONE
+      IF (EGNMIN.GE.ECMNN(NEBINI)) THEN
+         I1  = NEBINI
+         I2  = NEBINI
+         RAT = ONE
+      ELSEIF (EGNMIN.GT.ECMNN(1)) THEN
+         DO 7 I=2,NEBINI
+            IF (EGNMIN.LT.ECMNN(I)) THEN
+               I1  = I-1
+               I2  = I
+               RAT = (EGNMIN-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
+               GOTO 8
+            ENDIF
+    7    CONTINUE
+    8    CONTINUE
+      ENDIF
+      SIGXX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
+      IF (SIGXX.GT.SIGMAX) EGNXX = EGNMIN
+      SIGMAX = MAX(SIGMAX,SIGXX)
+      WRITE(LOUT,'(9X,A,F8.3,A)') 'Sigma_tot (max) =',SIGMAX,' mb'
+
+* plot photon flux table
+      AYMIN = LOG(YMIN)
+      AYMAX = LOG(YMAX)
+      AYRGE = AYMAX-AYMIN
+      MAXTAB = 50
+      ADY    = LOG(YMAX/YMIN)/DBLE(MAXTAB-1)
+C     WRITE(LOUT,'(/,1X,A)') 'LAEVT:   photon flux '
+      DO 1 I=1,MAXTAB
+         Y     = EXP(AYMIN+ADY*DBLE(I-1))
+         Q2LOW = MAX(Q2MIN,AMLPT2*Y**2/(ONE-Y))
+         FF1   = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
+     &                           -TWO*AMLPT2*Y*(ONE/Q2LOW-ONE/Q2MAX))
+         FF2   = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
+     &                           -TWO*(ONE-Y)/Y*(ONE-Q2LOW/Q2MAX))
+C        WRITE(LOUT,'(5X,3E15.4)') Y,FF1,FF2
+    1 CONTINUE
+
+* maximum residual weight for flux sampling (dy/y)
+      YY     = YMIN
+      Q2LOW  = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
+      WGHMAX = (ONE+(ONE-YY)**2)*LOG(Q2MAX/Q2LOW)
+     &         -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
+
+      CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY0)
+      CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY1)
+      CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY2)
+      CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ0)
+      CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ1)
+      CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ2)
+      CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE0)
+      CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE1)
+      CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE2)
+      CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU0)
+      CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU1)
+      CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU2)
+      XBLOW = 0.001D0
+      CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX0)
+      CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX1)
+      CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX2)
+
+      ITRY = 0
+      ITRW = 0
+      NC0  = 0
+      NC1  = 0
+
+* generate events
+      DO 2 IEVT=1,NEVTS
+         IF (MOD(IEVT,NMSG).EQ.0) THEN
+C           OPEN(LDAT,FILE='/scrtch3/hr/sroesler/statusd5.out',
+C    &                                         STATUS='UNKNOWN')
+            WRITE(LOUT,'(1X,I8,A)') IEVT-1,' events sampled'
+C           CLOSE(LDAT)
+         ENDIF
+         NEVENT = IEVT
+
+  100    CONTINUE
+         ITRY = ITRY+1
+
+*  sample y
+  101    CONTINUE
+         ITRW  = ITRW+1
+         YY    = EXP(AYRGE*DT_RNDM(RAT)+AYMIN)
+         Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
+         Q2LOG = LOG(Q2MAX/Q2LOW)
+         WGH   = (ONE+(ONE-YY)**2)*Q2LOG
+     &           -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
+         IF (WGHMAX.LT.WGH) WRITE(LOUT,1000) YY,WGHMAX,WGH
+ 1000    FORMAT(1X,'LAEVT:   weight error!',3E12.5)
+         IF (DT_RNDM(YY)*WGHMAX.GT.WGH) GOTO 101
+
+*  sample Q2
+         YEFF = ONE+(ONE-YY)**2
+  102    CONTINUE
+         Q2  = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
+         WGH = (YEFF-TWO*(ONE-YY)*Q2LOW/Q2)/YEFF
+         IF (WGH.LT.DT_RNDM(Q2)) GOTO 102
+
+c        NC0 = NC0+1
+c        CALL DT_FILHGR(YY,ONE,IHFLY0,NC0)
+c        CALL DT_FILHGR(Q2,ONE,IHFLQ0,NC0)
+
+*  kinematics at lepton-photon vertex
+*   scattered electron
+         YQ2 = SQRT((ONE-YY)*Q2)
+         Q2E = Q2/(4.0D0*PLEPT0(4))
+         E1Y = (ONE-YY)*PLEPT0(4)
+         CALL DT_DSFECF(SIF,COF)
+         PLEPT1(1) = YQ2*COF
+         PLEPT1(2) = YQ2*SIF
+         PLEPT1(3) = E1Y-Q2E
+         PLEPT1(4) = E1Y+Q2E
+C        THETA = ACOS( (E1Y-Q2E)/(E1Y+Q2E) )
+*   radiated photon
+         PGAMM(1) = -PLEPT1(1)
+         PGAMM(2) = -PLEPT1(2)
+         PGAMM(3) = PLEPT0(3)-PLEPT1(3)
+         PGAMM(4) = PLEPT0(4)-PLEPT1(4)
+*   E_cm cut
+         PTOTGN = SQRT( (PGAMM(1)+PNUCL(1))**2+(PGAMM(2)+PNUCL(2))**2
+     &                                        +(PGAMM(3)+PNUCL(3))**2 )
+         ETOTGN = PGAMM(4)+PNUCL(4)
+         ECMGN  = (ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)
+         IF (ECMGN.LT.0.1D0) GOTO 101
+         ECMGN  = SQRT(ECMGN)
+         IF ((ECMGN.LT.ECMIN).OR.(ECMGN.GT.ECMAX)) GOTO 101
+
+*  Lorentz-transformation into nucleon-rest system
+         CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
+     &               PGAMM(1),PGAMM(2),PGAMM(3),PGAMM(4),
+     &               PGTOT,PPG(1),PPG(2),PPG(3),PPG(4))
+         CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
+     &               PLEPT1(1),PLEPT1(2),PLEPT1(3),PLEPT1(4),
+     &               PLTOT,PPL1(1),PPL1(2),PPL1(3),PPL1(4))
+*  temporary checks..
+         Q2TMP = ABS(PPG(4)**2-PGTOT**2)
+         IF (ABS(Q2-Q2TMP).GT.0.01D0) WRITE(LOUT,1001) Q2,Q2TMP
+ 1001    FORMAT(1X,'LAEVT:    inconsistent kinematics (Q2,Q2TMP) ',
+     &          2F10.4)
+         ECMTMP = SQRT((PPG(4)+AAM(1)-PGTOT)*(PPG(4)+AAM(1)+PGTOT))
+         IF (ABS(ECMGN-ECMTMP).GT.TINY10) WRITE(LOUT,1002) ECMGN,ECMTMP
+ 1002    FORMAT(1X,'LAEVT:    inconsistent kinematics (ECMGN,ECMTMP) ',
+     &          2F10.2)
+         YYTMP = PPG(4)/PPL0(4)
+         IF (ABS(YY-YYTMP).GT.0.01D0) WRITE(LOUT,1005) YY,YYTMP
+ 1005    FORMAT(1X,'LAEVT:    inconsistent kinematics (YY,YYTMP) ',
+     &          2F10.4)
+
+*  lepton tagger (Lab)
+         THETA = ACOS( PPL1(3)/PLTOT )
+         IF (PPL1(4).GT.ELMIN) THEN
+            IF ((THETA.LT.THMIN).OR.(THETA.GT.THMAX)) GOTO 101
+         ENDIF
+*  photon energy-cut (Lab)
+         IF (PPG(4).LT.EGMIN) GOTO 101
+         IF (PPG(4).GT.EGMAX) GOTO 101
+*   x_Bj cut
+         XBJ = ABS(Q2/(1.876D0*PPG(4)))
+         IF (XBJ.LT.XBJMIN) GOTO 101
+
+         NC0 = NC0+1
+         CALL DT_FILHGR(    Q2,ONE,IHFLQ0,NC0)
+         CALL DT_FILHGR(    YY,ONE,IHFLY0,NC0)
+         CALL DT_FILHGR(   XBJ,ONE,IHFLX0,NC0)
+         CALL DT_FILHGR(PPG(4),ONE,IHFLU0,NC0)
+         CALL DT_FILHGR( ECMGN,ONE,IHFLE0,NC0)
+
+*  rotation angles against z-axis
+         COD = PPG(3)/PGTOT
+C        SID = SQRT((ONE-COD)*(ONE+COD))
+         PPT = SQRT(PPG(1)**2+PPG(2)**2)
+         SID = PPT/PGTOT
+         COF = ONE
+         SIF = ZERO
+         IF (PGTOT*SID.GT.TINY10) THEN
+            COF   = PPG(1)/(SID*PGTOT)
+            SIF   = PPG(2)/(SID*PGTOT)
+            ANORF = SQRT(COF*COF+SIF*SIF)
+            COF   = COF/ANORF
+            SIF   = SIF/ANORF
+         ENDIF
+
+         IF (IXSTBL.EQ.0) THEN
+*  change to photon projectile
+            IJPROJ = 7
+*  set virtuality
+            VIRT = Q2
+*  re-initialize LTs with new kinematics
+*  !!PGAMM ist set in cms (ECMGN) along z
+            EPN = ZERO
+            PPN = ZERO
+            CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,ECMGN,0)
+*  force Lab-system
+            IFRAME = 1
+*  get emulsion component if requested
+            IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
+*  convolute with cross section
+            CALL DT_SIGGAT(Q2LOW,EGNXX,STOTX,KKMAT)
+            CALL DT_SIGGAT(Q2,ECMGN,STOT,KKMAT)
+            IF (STOTX.LT.STOT) WRITE(LOUT,'(1X,A,/,6E12.3)')
+     &         'LAEVT: warning STOTX<STOT ! ',Q2LOW,EGNMAX,STOTX,
+     &                                        Q2,ECMGN,STOT
+            IF (DT_RNDM(Q2)*STOTX.GT.STOT) GOTO 100
+            NC1 = NC1+1
+            CALL DT_FILHGR(    Q2,ONE,IHFLQ1,NC1)
+            CALL DT_FILHGR(    YY,ONE,IHFLY1,NC1)
+            CALL DT_FILHGR(   XBJ,ONE,IHFLX1,NC1)
+            CALL DT_FILHGR(PPG(4),ONE,IHFLU1,NC1)
+            CALL DT_FILHGR( ECMGN,ONE,IHFLE1,NC1)
+*  composite targets only
+            KKMAT = -KKMAT
+*  sample this event
+            CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IJPROJ,EPN,KKMAT,
+     &                                                            IREJ)
+*  rotate momenta of final state particles back in photon-nucleon syst.
+            DO 4 I=NPOINT(4),NHKK
+               IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
+     &                                      (ISTHKK(I).EQ.1001)) THEN
+                  PX = PHKK(1,I)
+                  PY = PHKK(2,I)
+                  PZ = PHKK(3,I)
+                  CALL DT_MYTRAN(1,PX,PY,PZ,COD,SID,COF,SIF,
+     &                        PHKK(1,I),PHKK(2,I),PHKK(3,I))
+               ENDIF
+    4       CONTINUE
+         ENDIF
+
+         CALL DT_FILHGR(    Q2,ONE,IHFLQ2,NC1)
+         CALL DT_FILHGR(    YY,ONE,IHFLY2,NC1)
+         CALL DT_FILHGR(   XBJ,ONE,IHFLX2,NC1)
+         CALL DT_FILHGR(PPG(4),ONE,IHFLU2,NC1)
+         CALL DT_FILHGR( ECMGN,ONE,IHFLE2,NC1)
+
+*  dump this event to histograms
+         CALL PHO_PHIST(2000,DUM)
+
+    2 CONTINUE
+
+      WGY    = ALPHEM/TWOPI*WGHMAX*DBLE(ITRY)/DBLE(ITRW)
+      WGY    = WGY*LOG(YMAX/YMIN)
+      WEIGHT = WGY*SIGMAX*DBLE(NEVTS)/DBLE(ITRY)
+
+C     HEADER = ' LAEVT:  Q^2 distribution 0'
+C     CALL DT_OUTHGR(IHFLQ0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+C     HEADER = ' LAEVT:  Q^2 distribution 1'
+C     CALL DT_OUTHGR(IHFLQ1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+C     HEADER = ' LAEVT:  Q^2 distribution 2'
+C     CALL DT_OUTHGR(IHFLQ2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+C     HEADER = ' LAEVT:  y   distribution 0'
+C     CALL DT_OUTHGR(IHFLY0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+C     HEADER = ' LAEVT:  y   distribution 1'
+C     CALL DT_OUTHGR(IHFLY1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+C     HEADER = ' LAEVT:  y   distribution 2'
+C     CALL DT_OUTHGR(IHFLY2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+C     HEADER = ' LAEVT:  x   distribution 0'
+C     CALL DT_OUTHGR(IHFLX0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+C     HEADER = ' LAEVT:  x   distribution 1'
+C     CALL DT_OUTHGR(IHFLX1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+C     HEADER = ' LAEVT:  x   distribution 2'
+C     CALL DT_OUTHGR(IHFLX2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+C     HEADER = ' LAEVT:  E_g distribution 0'
+C     CALL DT_OUTHGR(IHFLU0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+C     HEADER = ' LAEVT:  E_g distribution 1'
+C     CALL DT_OUTHGR(IHFLU1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+C     HEADER = ' LAEVT:  E_g distribution 2'
+C     CALL DT_OUTHGR(IHFLU2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+C     HEADER = ' LAEVT:  E_c distribution 0'
+C     CALL DT_OUTHGR(IHFLE0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+C     HEADER = ' LAEVT:  E_c distribution 1'
+C     CALL DT_OUTHGR(IHFLE1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+C     HEADER = ' LAEVT:  E_c distribution 2'
+C     CALL DT_OUTHGR(IHFLE2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
+
+* print run-statistics and histograms to output-unit 6
+      CALL PHO_PHIST(3000,DUM)
+      IF (IXSTBL.EQ.0) CALL DT_STATIS(2)
+
+      RETURN
+      END
+
+*$ CREATE DT_DTUINI.FOR
+*COPY DT_DTUINI
+*
+*===dtuini=============================================================*
+*
+      SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
+     &                                               IDP,IEMU)
+
+      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+      SAVE
+
+      PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+* emulsion treatment
+      COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
+     &                NCOMPO,IEMUL
+* Glauber formalism: flags and parameters for statistics
+      LOGICAL LPROD
+      CHARACTER*8 CGLB
+      COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
+
+      CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU)
+      CALL DT_STATIS(1)
+      CALL PHO_PHIST(1000,DUM)
+      IF (NCOMPO.LE.0) THEN
+         CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
+      ELSE
+         DO 1 I=1,NCOMPO
+            CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
+    1    CONTINUE
+      ENDIF
+      IF (IOGLB.NE.100) CALL DT_SIGEMU
+      IEMU = IEMUL
+
+      RETURN
+      END
+
+*$ CREATE DT_DTUOUT.FOR
+*COPY DT_DTUOUT
+*
+*===dtuout=============================================================*
+*
+      SUBROUTINE DT_DTUOUT
+
+      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+      SAVE
+
+      CALL PHO_PHIST(3000,DUM)
+      CALL DT_STATIS(2)
+
+      RETURN
+      END
+
+*$ CREATE DT_BEAMPR.FOR
+*COPY DT_BEAMPR
+*
+*===beampr=============================================================*
+*
+      SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE)
+
+************************************************************************
+* Initialization of event generation                                   *
+* This version dated  7.4.98  is written by S. Roesler.                *
+************************************************************************
+
+      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+      SAVE
+
+      PARAMETER ( LINP = 10 ,
+     &            LOUT = 6 ,
+     &            LDAT = 9 )
+      PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
+      PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
+
+      LOGICAL LBEAM
+
+* event history
+      PARAMETER (NMXHKK=200000)
+      COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+     &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+     &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+* extended event history
+      COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+     &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+     &                IHIST(2,NMXHKK)
+* properties of interacting particles
+      COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+* particle properties (BAMJET index convention)
+      CHARACTER*8  ANAME
+      COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+     &                IICH(210),IIBAR(210),K1(210),K2(210)
+* beam momenta
+      COMMON /DTBEAM/ P1(4),P2(4)
+
+C     DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4)
+      DIMENSION WHAT(6),P1CMS(4),P2CMS(4)
+
+      DATA LBEAM /.FALSE./
+
+      GOTO (1,2) MODE
+
+    1 CONTINUE
+
+      E1  = WHAT(1)
+      IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1))
+      E2  = WHAT(2)
+      IF (E2.LT.ZERO) E2 = DBLE(ITZ)/DBLE(IT)*ABS(WHAT(2))
+      PP1 = SQRT( (E1+AAM(IJPROJ))*(E1-AAM(IJPROJ)) )
+      PP2 = SQRT( (E2+AAM(IJTARG))*(E2-AAM(IJTARG)) )
+      TH  = 1.D-6*WHAT(3)/2.D0
+      PH  = WHAT(4)*BOG
+      P1(1) = PP1*SIN(TH)*COS(PH)
+      P1(2) = PP1*SIN(TH)*SIN(PH)
+      P1(3) = PP1*COS(TH)
+      P1(4) = E1
+      P2(1) = PP2*SIN(TH)*COS(PH)
+      P2(2) = PP2*SIN(TH)*SIN(PH)
+      P2(3) = -PP2*COS(TH)
+      P2(4) = E2
+      ECM  = SQRT( (P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
+     &                                              -(P1(3)+P2(3))**2 )
+      ELAB = (ECM**2-AAM(IJPROJ)**2-AAM(IJTARG)**2)/(2.0D0*AAM(IJTARG))
+      PLAB = SQRT( (ELAB+AAM(IJPROJ))*(ELAB-AAM(IJPROJ)) )
+      BGX  = (P1(1)+P2(1))/ECM
+      BGY  = (P1(2)+P2(2))/ECM
+      BGZ  = (P1(3)+P2(3))/ECM
+      BGE  = (P1(4)+P2(4))/ECM
+      CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P1(1),P1(2),P1(3),P1(4),
+     &            P1TOT,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4))
+      CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P2(1),P2(2),P2(3),P2(4),
+     &            P2TOT,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4))
+      COD = P1CMS(3)/P1TOT
+C     SID = SQRT((ONE-COD)*(ONE+COD))
+      PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2)
+      SID = PPT/P1TOT
+      COF = ONE
+      SIF = ZERO
+      IF (P1TOT*SID.GT.TINY10) THEN
+         COF   = P1CMS(1)/(SID*P1TOT)
+         SIF   = P1CMS(2)/(SID*P1TOT)
+         ANORF = SQRT(COF*COF+SIF*SIF)
+         COF   = COF/ANORF
+         SIF   = SIF/ANORF
+      ENDIF
+**check
+C     WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
+C     WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
+C     WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT
+C     WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT
+C     PAX = ZERO
+C     PAY = ZERO
+C     PAZ = P1TOT
+C     PAE = SQRT(AAM(IJPROJ)**2+PAZ**2)
+C     PBX = ZERO
+C     PBY = ZERO
+C     PBZ = -P2TOT
+C     PBE = SQRT(AAM(IJTARG)**2+PBZ**2)
+C     WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE
+C     WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE
+C     CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF,
+C    &            P1CMS(1),P1CMS(2),P1CMS(3))
+C     CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF,
+C    &            P2CMS(1),P2CMS(2),P2CMS(3))
+C     WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)
+C     WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)
+C     CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),
+C    &            P1TOT,P1(1),P1(2),P1(3),P1(4))
+C     CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),
+C    &            P2TOT,P2(1),P2(2),P2(3),P2(4))
+C     WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
+C     WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
+C     STOP
+**
+
+      LBEAM = .TRUE.
+
+      RETURN
+
+    2 CONTINUE
+
+      IF (LBEAM) THEN
+         IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
+         DO 20 I=NPOINT(4),NHKK
+            IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
+     &                                   (ISTHKK(I).EQ.1001)) THEN
+               CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I),
+     &                     COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS)
+               PECMS = PHKK(4,I)
+               CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS,
+     &                     PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I))
+            ENDIF
+   20    CONTINUE
+      ELSE
+         MODE = -1
+      ENDIF
+
+      RETURN
+      END
+
+*$ CREATE DT_REJUCO.FOR
+*COPY DT_REJUCO
+*
+*===rejuco=============================================================*
+*
+      SUBROUTINE DT_REJUCO(MODE,IREJ)
+
+************************************************************************
+* REJection of Unphysical COnfigurations                               *
+*     MODE = 1  rejection of particles with unphysically large energy  *
+*                                                                      *
+* This version dated 27.12.2006 is written by S. Roesler.              *
+************************************************************************
+
+      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+      SAVE
+
+      PARAMETER ( LINP = 10 ,
+     &            LOUT = 6 ,
+     &            LDAT = 9 )
+      PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
+      PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
+
+* maximum x_cms of final state particle
+      PARAMETER (XCMSMX = 1.4D0)
+
+* event history
+      PARAMETER (NMXHKK=200000)
+      COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+     &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+     &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+* extended event history
+      COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+     &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+     &                IHIST(2,NMXHKK)
+* Lorentz-parameters of the current interaction
+      COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+     &                UMO,PPCM,EPROJ,PPROJ
+
+      IREJ = 0
+
+      IF (MODE.EQ.1) THEN
+         IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
+         ECMHLF = UMO/2.0D0
+         DO 10 I=NPOINT(4),NHKK
+            IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDHKK(I).NE.80000)) THEN
+               XCMS = ABS(PHKK(4,I))/ECMHLF
+               IF (XCMS.GT.XCMSMX) GOTO 9999
+            ENDIF
+   10    CONTINUE
+      ENDIF
+
+      RETURN
+ 9999 CONTINUE
+      IREJ = 1
+      RETURN
+      END
+
+*$ CREATE DT_EVENTB.FOR
+*COPY DT_EVENTB
+*
+*===eventb=============================================================*
+*
+      SUBROUTINE DT_EVENTB(NCSY,IREJ)
+
+************************************************************************
+* Treatment of nucleon-nucleon interactions with full two-component    *
+* Dual Parton Model.                                                   *
+*          NCSY     number of nucleon-nucleon interactions             *
+*          IREJ     rejection flag                                     *
+* This version dated 14.01.2000 is written by S. Roesler               *
+************************************************************************
+
+      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+      SAVE
+      PARAMETER ( LINP = 10 ,
+     &            LOUT = 6 ,
+     &            LDAT = 9 )
+      PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
+
+* event history
+      PARAMETER (NMXHKK=200000)
+      COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+     &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+     &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+* extended event history
+      COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+     &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+     &                IHIST(2,NMXHKK)
+*! uncomment this line for internal phojet-fragmentation
+C #include "dtu_dtevtp.inc"
+* particle properties (BAMJET index convention)
+      CHARACTER*8  ANAME
+      COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+     &                IICH(210),IIBAR(210),K1(210),K2(210)
+* flags for input different options
+      LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+      COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+     &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+* rejection counter
+      COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
+     &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
+     &                IREXCI(3),IRDIFF(2),IRINC
+* properties of interacting particles
+      COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+* properties of photon/lepton projectiles
+      COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
+* various options for treatment of partons (DTUNUC 1.x)
+* (chain recombination, Cronin,..)
+      LOGICAL LCO2CR,LINTPT
+      COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
+     &                LCO2CR,LINTPT
+* statistics
+      COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
+     &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
+     &                ICEVTG(8,0:30)
+* DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
+      COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
+* Glauber formalism: collision properties
+      COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
+     &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
+* flags for diffractive interactions (DTUNUC 1.x)
+      COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
+* statistics: double-Pomeron exchange
+      COMMON /DTFLG2/ INTFLG,IPOPO
+* flags for particle decays
+      COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
+     &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
+     &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
+* nucleon-nucleon event-generator
+      CHARACTER*8 CMODEL
+      LOGICAL LPHOIN
+      COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
+      INTEGER IDEQP,IDEQB,IHFLD,IHFLS
+      DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
+      COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
+     &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
+C  model switches and parameters
+      CHARACTER*8 MDLNA
+      INTEGER ISWMDL,IPAMDL
+      DOUBLE PRECISION PARMDL
+      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C  initial state parton radiation (internal part)
+      INTEGER MXISR3,MXISR4
+      PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
+      INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
+      DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
+      COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
+     &                ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
+     &                IFL1(2,MXISR3),IFL2(2,MXISR3),
+     &                IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
+C  event debugging information
+      INTEGER NMAXD
+      PARAMETER (NMAXD=100)
+      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+C  general process information
+      INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+      COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+
+      DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4),
+     &          PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4),
+     &          PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4),
+     &          KPRON(15),ISINGL(2000)
+
+* initial values for max. number of phojet scatterings and dtunuc chains
+* to be fragmented with one pyexec call
+      DATA MXPHFR,MXDTFR /10,100/
+
+      IREJ      = 0
+* pointer to first parton of the first chain in dtevt common
+      NPOINT(3) = NHKK+1
+* special flag for double-Pomeron statistics
+      IPOPO = 1
+* counter for low-mass (DTUNUC) interactions
+      NDTUSC = 0
+* counter for interactions treated by PHOJET
+      NPHOSC = 0
+
+* scan interactions for single nucleon-nucleon interactions
+* (this has to be checked here because Cronin modifies parton momenta)
+      NC = NPOINT(2)
+      IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! '
+      DO 8 I=1,NCSY
+         ISINGL(I) = 0
+         MOP = JMOHKK(1,NC)
+         MOT = JMOHKK(1,NC+1)
+         DIFF1 = ABS(PHKK(4,MOP)-PHKK(4,  NC)-PHKK(4,NC+2))
+         DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3))
+         IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1
+         NC = NC+4
+    8 CONTINUE
+
+* multiple scattering of chain ends
+      IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
+      IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
+
+* switch to PHOJET-settings for JETSET parameter
+      CALL DT_INITJS(1)
+
+* loop over nucleon-nucleon interaction
+      NC = NPOINT(2)
+      DO 2 I=1,NCSY
+*
+*   pick up one nucleon-nucleon interaction from DTEVT1
+*     ppnn  / ptnn   - momenta of the interacting nucleons (cms)
+*     ptotnn         - total momentum of the interacting nucleons (cms)
+*     pp1,2 / pt1,2  - momenta of the four partons
+*     pp    / pt     - total momenta of the proj / targ partons
+*     ptot           - total momentum of the four partons
+         MOP = JMOHKK(1,NC)
+         MOT = JMOHKK(1,NC+1)
+         DO 3 K=1,4
+            PPNN(K)   = PHKK(K,MOP)
+            PTNN(K)   = PHKK(K,MOT)
+            PTOTNN(K) = PPNN(K)+PTNN(K)
+            PP1(K)    = PHKK(K,NC)
+            PT1(K)    = PHKK(K,NC+1)
+            PP2(K)    = PHKK(K,NC+2)
+            PT2(K)    = PHKK(K,NC+3)
+            PP(K)     = PP1(K)+PP2(K)
+            PT(K)     = PT1(K)+PT2(K)
+            PTOT(K)   = PP(K)+PT(K)
+    3    CONTINUE
+*
+*-----------------------------------------------------------------------
+*   this is a complete nucleon-nucleon interaction
+*
+         IF (ISINGL(I).EQ.1) THEN
+*
+*     initialize PHOJET-variables for remnant/valence-partons
+            IHFLD(1,1) = 0
+            IHFLD(1,2) = 0
+            IHFLD(2,1) = 0
+            IHFLD(2,2) = 0
+            IHFLS(1) = 1
+            IHFLS(2) = 1
+*     save current settings of PHOJET process and min. bias flags
+            DO 9 K=1,11
+               KPRON(K) = IPRON(K,1)
+    9       CONTINUE
+            ISWSAV   = ISWMDL(2)
+*
+*     check if forced sampling of diffractive interaction requested
+            IF (ISINGD.LT.-1) THEN
+               DO 90 K=1,11
+                  IPRON(K,1) = 0
+   90          CONTINUE
+               IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1
+               IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1
+               IF (ISINGD.EQ.-5) IPRON(4,1) = 1
+            ENDIF
+*
+*     for photons: a direct/anomalous interaction is not sampled
+*     in PHOJET but already in Glauber-formalism. Here we check if such
+*     an interaction is requested
+            IF (IJPROJ.EQ.7) THEN
+*       first switch off direct interactions
+               IPRON(8,1) = 0
+*       this is a direct interactions
+               IF (IDIREC.EQ.1) THEN
+                  DO 12 K=1,11
+                     IPRON(K,1) = 0
+   12             CONTINUE
+                  IPRON(8,1) = 1
+*       this is an anomalous interactions
+*         (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) )
+               ELSEIF (IDIREC.EQ.2) THEN
+                  ISWMDL(2) = 0
+               ENDIF
+            ELSE
+               IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! '
+            ENDIF
+*
+*     make sure that total momenta of partons, pp and pt, are on mass
+*     shell (Cronin may have srewed this up..)
+            CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1)
+            IF (IR1.NE.0) THEN
+               IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)')
+     &              'EVENTB:  mass shell correction rejected'
+               GOTO 9999
+            ENDIF
+*
+*     initialize the incoming particles in PHOJET
+            IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
+               CALL PHO_SETPAR(1,22,0,VIRT)
+            ELSE
+               CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO)
+            ENDIF
+            CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO)
+*
+*     initialize rejection loop counter for anomalous processes
+            IRJANO = 0
+  800       CONTINUE
+            IRJANO = IRJANO+1
+*
+*     temporary fix for ifano problem
+            IFANO(1) = 0
+            IFANO(2) = 0
+*
+*     generate complete hadron/nucleon/photon-nucleon event with PHOJET
+            CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1)
+*
+*     for photons: special consistency check for anomalous interactions
+            IF (IJPROJ.EQ.7) THEN
+               IF (IRJANO.LT.30) THEN
+                  IF (IFANO(1).NE.0) THEN
+*       here, an anomalous interaction was generated. Check if it
+*       was also requested. Otherwise reject this event.
+                     IF (IDIREC.EQ.0) GOTO 800
+                  ELSE
+*       here, an anomalous interaction was not generated. Check if it
+*       was requested in which case we need to reject this event.
+                     IF (IDIREC.EQ.2) GOTO 800
+                  ENDIF
+               ELSE
+                  WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ',
+     &                          IRJANO,IDIREC,NEVHKK
+               ENDIF
+            ENDIF
+*
+*     copy back original settings of PHOJET process and min. bias flags
+            DO 10 K=1,11
+               IPRON(K,1) = KPRON(K)
+   10       CONTINUE
+            ISWMDL(2) = ISWSAV
+*
+*     check if PHOJET has rejected this event
+            IF (IREJ1.NE.0) THEN
+C              IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
+               WRITE(LOUT,'(1X,A,I4)')
+     &            'EVENTB:  chain system rejected',IDIREC
+               CALL PHO_PREVNT(0)
+               GOTO 9999
+            ENDIF
+*
+*     copy partons and strings from PHOJET common back into DTEVT for
+*     external fragmentation
+            MO1 = NC
+            MO2 = NC+3
+*!      uncomment this line for internal phojet-fragmentation
+C           CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1)
+            NPHOSC = NPHOSC+1
+            CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1)
+            IF (IREJ1.NE.0) THEN
+               IF (IOULEV(1).GT.0)
+     &         WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1'
+               GOTO 9999
+            ENDIF
+*
+*     update statistics counter
+            ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1
+*
+*-----------------------------------------------------------------------
+*   this interaction involves "remnants"
+*
+         ELSE
+*
+*     total mass of this system
+            PPTOT  = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2)
+            AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT)
+            IF (AMTOT2.LT.ZERO) THEN
+               AMTOT = ZERO
+            ELSE
+               AMTOT = SQRT(AMTOT2)
+            ENDIF
+*
+*     systems with masses larger than elojet are treated with PHOJET
+            IF (AMTOT.GT.ELOJET) THEN
+*
+*     initialize PHOJET-variables for remnant/valence-partons
+*       projectile parton flavors and valence flag
+               IHFLD(1,1) = IDHKK(NC)
+               IHFLD(1,2) = IDHKK(NC+2)
+               IHFLS(1)   = 0
+               IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7)
+     &                            .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1
+*       target parton flavors and valence flag
+               IHFLD(2,1) = IDHKK(NC+1)
+               IHFLD(2,2) = IDHKK(NC+3)
+               IHFLS(2)   = 0
+               IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5)
+     &                            .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1
+*       flag signalizing PHOJET how to treat the remnant:
+*         iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld
+*         iremn > -1 valence remnant: PHOJET assumes flavors according
+*                    to mother particle
+               IREMN1 = IHFLS(1)-1
+               IREMN2 = IHFLS(2)-1
+*
+*     initialize the incoming particles in PHOJET
+               IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
+                  CALL PHO_SETPAR(1,22,IREMN1,VIRT)
+               ELSE
+                  CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO)
+               ENDIF
+               CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO)
+*
+*     calculate Lorentz parameter of the nucleon-nucleon cm-system
+               PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2)
+               AMNN   = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) )
+               BGX    = PTOTNN(1)/AMNN
+               BGY    = PTOTNN(2)/AMNN
+               BGZ    = PTOTNN(3)/AMNN
+               GAM    = PTOTNN(4)/AMNN
+*     transform interacting nucleons into nucleon-nucleon cm-system
+               CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
+     &                     PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS,
+     &                     PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4))
+               CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
+     &                     PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS,
+     &                     PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4))
+*     transform (total) momenta of the proj and targ partons into
+*     nucleon-nucleon cm-system
+               CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
+     &                     PP(1),PP(2),PP(3),PP(4),
+     &                     PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4))
+               CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
+     &                     PT(1),PT(2),PT(3),PT(4),
+     &                     PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4))
+*     energy fractions of the proj and targ partons
+               XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE)
+               XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE)
+***
+* testprint
+c              PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
+c    &                        (PPTCMS(2)+PTTCMS(2))**2 +
+c    &                        (PPTCMS(3)+PTTCMS(3))**2 )
+c              EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
+c    &                        (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
+c              PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
+c    &                        (PPSUB(2)+PTSUB(2))**2 +
+c    &                        (PPSUB(3)+PTSUB(3))**2 )
+c              EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
+c    &                        (PPSUB(4)+PTSUB(4)+PTOTSU) )
+***
+*
+*     save current settings of PHOJET process and min. bias flags
+               DO 7 K=1,11
+                  KPRON(K) = IPRON(K,1)
+    7          CONTINUE
+*     disallow direct photon int. (does not make sense here anyway)
+               IPRON(8,1) = 0
+*     disallow double pomeron processes (due to technical problems
+*     in PHOJET, needs to be solved sometime)
+               IPRON(4,1) = 0
+*     disallow diffraction for sea-diquarks
+               IF ((IABS(IHFLD(1,1)).GT.1100).AND.
+     &             (IABS(IHFLD(1,2)).GT.1100)) THEN
+                  IPRON(3,1) = 0
+                  IPRON(6,1) = 0
+               ENDIF
+               IF ((IABS(IHFLD(2,1)).GT.1100).AND.
+     &             (IABS(IHFLD(2,2)).GT.1100)) THEN
+                  IPRON(3,1) = 0
+                  IPRON(5,1) = 0
+               ENDIF
+*
+*     we need massless partons: transform them on mass shell
+               XMP = ZERO
+               XMT = ZERO
+               DO 6 K=1,4
+                  PPTMP(K) = PPSUB(K)
+                  PTTMP(K) = PTSUB(K)
+    6          CONTINUE
+               CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1)
+               PPSUTO  = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2)
+               PTSUTO  = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2)
+               PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+
+     &                  (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2)
+*     total energy of the subsysten after mass transformation
+*      (should be the same as before..)
+               SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)*
+     &                      (PPSUB(4)+PTSUB(4)+PSUTOT) )
+*
+*     after mass shell transformation the x_sub - relation has to be
+*     corrected. We therefore create "pseudo-momenta" of mother-nucleons.
+*
+*     The old version was to scale based on the original x_sub and the
+*     4-momenta of the subsystem. At very high energy this could lead to
+*     "pseudo-cm energies" of the parent system considerably exceeding
+*     the true cm energy. Now we keep the true cm energy and calculate
+*     new x_sub instead.
+C old version  PPTCMS(4) = PPSUB(4)/XPSUB
+               PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4))
+               XPSUB = PPSUB(4)/PPTCMS(4)
+               IF (IJPROJ.EQ.7) THEN
+                  AMP2  = PHKK(5,MOT)**2
+                  PTOT1 = SQRT(PPTCMS(4)**2-AMP2)
+               ELSE
+*???????
+                  PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP))
+     &                        *(PPTCMS(4)+PHKK(5,MOP)))
+C                 PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT))
+C    &                        *(PPTCMS(4)+PHKK(5,MOT)))
+               ENDIF
+C old version  PTTCMS(4) = PTSUB(4)/XTSUB
+               PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4))
+               XTSUB = PTSUB(4)/PTTCMS(4)
+               PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT))
+     &                     *(PTTCMS(4)+PHKK(5,MOT)))
+               DO 4 K=1,3
+                  PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO
+                  PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO
+    4          CONTINUE
+***
+* testprint
+*
+*     ppnn  / ptnn   - momenta of the int. nucleons (cms, negl. Fermi)
+*     ptotnn         - total momentum of the int. nucleons (cms, negl. Fermi)
+*     pptcms/ pttcms - momenta of the interacting nucleons (cms)
+*     pp1,2 / pt1,2  - momenta of the four partons
+*
+*     pp    / pt     - total momenta of the pr/ta partons (cms, negl. Fermi)
+*     ptot           - total momentum of the four partons (cms, negl. Fermi)
+*     ppsub / ptsub  - total momenta of the proj / targ partons (cms)
+*
+c              PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
+c    &                        (PPTCMS(2)+PTTCMS(2))**2 +
+c    &                        (PPTCMS(3)+PTTCMS(3))**2 )
+c              ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
+c    &                        (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
+c              PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
+c    &                        (PPSUB(2)+PTSUB(2))**2 +
+c    &                        (PPSUB(3)+PTSUB(3))**2 )
+c              ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
+c    &                        (PPSUB(4)+PTSUB(4)+PTOTSU) )
+c              IF (ENEWCM/EOLDCM.GT.1.1D0) THEN
+c                 WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM
+c                 WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU
+c                 WRITE(*,*) ' XPSUB,  XTSUB  : ',XPSUB,XTSUB
+c              ENDIF
+c              BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM
+c              BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM
+c              BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM
+c              BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM
+*     transform interacting nucleons into nucleon-nucleon cm-system
+c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
+c    &                    PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT,
+c    &                     PPNEW1,PPNEW2,PPNEW3,PPNEW4)
+c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
+c    &                    PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT,
+c    &                     PTNEW1,PTNEW2,PTNEW3,PTNEW4)
+c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
+c    &                     PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT,
+c    &                     PPSUB1,PPSUB2,PPSUB3,PPSUB4)
+c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
+c    &                     PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT,
+c    &                     PTSUB1,PTSUB2,PTSUB3,PTSUB4)
+c              PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 +
+c    &                        (PPNEW2+PTNEW2)**2 +
+c    &                        (PPNEW3+PTNEW3)**2 )
+c              ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) *
+c    &                        (PPNEW4+PTNEW4+PTSTCM) )
+c              PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 +
+c    &                        (PPSUB2+PTSUB2)**2 +
+c    &                        (PPSUB3+PTSUB3)**2 )
+c              ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) *
+c    &                        (PPSUB4+PTSUB4+PTSTSU) )
+C              WRITE(*,*) ' mother cmE :'
+C              WRITE(*,*) ETSTCM,ENEWCM
+C              WRITE(*,*) ' subsystem cmE :'
+C              WRITE(*,*) ETSTSU,ENEWSU
+C              WRITE(*,*) ' projectile mother :'
+C              WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4
+C              WRITE(*,*) ' target mother :'
+C              WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4
+C              WRITE(*,*) ' projectile subsystem:'
+C              WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4
+C              WRITE(*,*) ' target subsystem:'
+C              WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4
+C              WRITE(*,*) ' projectile subsystem should be:'
+C              WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0,
+C    &                    XPSUB*ETSTCM/2.0D0
+C              WRITE(*,*) ' target subsystem should be:'
+C              WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0,
+C    &                    XTSUB*ETSTCM/2.0D0
+C              WRITE(*,*) ' subsystem cmE should be: '
+C              WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB
+***
+*
+*     generate complete remnant - nucleon/remnant event with PHOJET
+               CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1)
+*
+*     copy back original settings of PHOJET process flags
+               DO 11 K=1,11
+                  IPRON(K,1) = KPRON(K)
+   11          CONTINUE
+*
+*     check if PHOJET has rejected this event
+               IF (IREJ1.NE.0) THEN
+                  IF (IOULEV(1).GT.0)
+     &            WRITE(LOUT,'(1X,A)') 'EVENTB:  chain system rejected'
+                  WRITE(LOUT,*)
+     &                 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT
+                  CALL PHO_PREVNT(0)
+                  GOTO 9999
+               ENDIF
+*
+*     copy partons and strings from PHOJET common back into DTEVT for
+*     external fragmentation
+               MO1 = NC
+               MO2 = NC+3
+*!      uncomment this line for internal phojet-fragmentation
+C              CALL DT_GETFSP(MO1,MO2,PP,PT,1)
+               NPHOSC = NPHOSC+1
+               CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1)
+               IF (IREJ1.NE.0) THEN
+                  IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
+     &               'EVENTB: chain system rejected 2'
+                  GOTO 9999
+               ENDIF
+*
+*     update statistics counter
+               ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1
+*
+*-----------------------------------------------------------------------
+* two-chain approx. for smaller systems
+*
+            ELSE
+*
+               NDTUSC = NDTUSC+1
+*   special flag for double-Pomeron statistics
+               IPOPO = 0
+*
+*   pick up flavors at the ends of the two chains
+               IFP1 = IDHKK(NC)
+               IFT1 = IDHKK(NC+1)
+               IFP2 = IDHKK(NC+2)
+               IFT2 = IDHKK(NC+3)
+*   ..and the indices of the mothers
+               MOP1 = NC
+               MOT1 = NC+1
+               MOP2 = NC+2
+               MOT2 = NC+3
+               CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
+     &                     IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
+*
+*   check if this chain system was rejected
+               IF (IREJ1.GT.0) THEN
+                  IF (IOULEV(1).GT.0) THEN
+                     WRITE(LOUT,*) 'rejected 1 in EVENTB'
+                     WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)')
+     &                  IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT
+                  ENDIF
+                  IRHHA = IRHHA+1
+                  GOTO 9999
+               ENDIF
+*   the following lines are for sea-sea chains rejected in GETCSY
+               IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1
+               ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1
+            ENDIF
+*
+         ENDIF
+*
+*     update statistics counter
+         ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1
+*
+         NC = NC+4
+*
+    2 CONTINUE
+*
+*-----------------------------------------------------------------------
+* treatment of low-mass chains (if there are any)
+*
+      IF (NDTUSC.GT.0) THEN
+*
+*   correct chains of very low masses for possible resonances
+         IF (IRESCO.EQ.1) THEN
+            CALL DT_EVTRES(IREJ1)
+            IF (IREJ1.GT.0) THEN
+               IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB'
+               IRRES(1) = IRRES(1)+1
+               GOTO 9999
+            ENDIF
+         ENDIF
+*   fragmentation of low-mass chains
+*!  uncomment this line for internal phojet-fragmentation
+*   (of course it will still be fragmented by DPMJET-routines but it
+*    has to be done here instead of further below)
+C        CALL DT_EVTFRA(IREJ1)
+C        IF (IREJ1.GT.0) THEN
+C           IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB'
+C           IRFRAG = IRFRAG+1
+C           GOTO 9999
+C        ENDIF
+      ELSE
+*! uncomment this line for internal phojet-fragmentation
+C        NPOINT(4) = NHKK+1
+         IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
+      ENDIF
+*
+*-----------------------------------------------------------------------
+* new di-quark breaking mechanisms
+*
+      MXLEFT = 2
+      CALL DT_CHASTA(0)
+      IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
+     &                        .OR.(PDBSEA(3).GT.0.0D0)) THEN
+         CALL DT_DIQBRK
+         MXLEFT = 4
+      ENDIF
+*
+*-----------------------------------------------------------------------
+* hadronize this event
+*
+*   hadronize PHOJET chain systems
+      NPYMAX = 0
+      NPJE   = NPHOSC/MXPHFR
+      IF (MXPHFR.LT.MXLEFT) MXLEFT = 2
+      IF (NPJE.GT.1) THEN
+         NLEFT = NPHOSC-NPJE*MXPHFR
+         DO 20 JFRG=1,NPJE
+            NFRG = JFRG*MXPHFR
+            IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN
+               CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
+               IF (IREJ1.GT.0) GOTO 22
+               NLEFT = 0
+            ELSE
+               CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1)
+               IF (IREJ1.GT.0) GOTO 22
+            ENDIF
+            IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
+   20    CONTINUE
+         IF (NLEFT.GT.0) THEN
+            CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
+            IF (IREJ1.GT.0) GOTO 22
+            IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
+         ENDIF
+      ELSE
+         CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
+         IF (IREJ1.GT.0) GOTO 22
+         IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
+      ENDIF
+*
+*   check max. filling level of jetset common and
+*   reduce mxphfr if necessary
+      IF (NPYMAX.GT.3000) THEN
+         IF (NPYMAX.GT.3500) THEN
+            MXPHFR = MAX(1,MXPHFR-2)
+         ELSE
+            MXPHFR = MAX(1,MXPHFR-1)
+         ENDIF
+C        WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR
+      ENDIF
+*
+*   hadronize DTUNUC chain systems
+   23 CONTINUE
+      IBACK = MXDTFR
+      CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2)
+      IF (IREJ2.GT.0) GOTO 22
+*
+*   check max. filling level of jetset common and
+*   reduce mxdtfr if necessary
+      IF (NPYMEM.GT.3000) THEN
+         IF (NPYMEM.GT.3500) THEN
+            MXDTFR = MAX(1,MXDTFR-20)
+         ELSE
+            MXDTFR = MAX(1,MXDTFR-10)
+         ENDIF
+C        WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
+      ENDIF
+*
+      IF (IBACK.EQ.-1) GOTO 23
+*
+   22 CONTINUE
+C     CALL DT_EVTFRG(1,IREJ1)
+C     CALL DT_EVTFRG(2,IREJ2)
+      IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN
+         IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB'
+         IRFRAG = IRFRAG+1
+         GOTO 9999
+      ENDIF
+*
+* get final state particles from /DTEVTP/
+*! uncomment this line for internal phojet-fragmentation
+C     CALL DT_GETFSP(IDUM,IDUM,PP,PT,2)
+
+      IF (IJPROJ.NE.7)
+     &   CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3)
+C     IF (IREJ3.NE.0) GOTO 9999
+
+      RETURN
+
+ 9999 CONTINUE
+      IREVT = IREVT+1
+      IREJ  = 1
+      RETURN
+      END
+
+*$ CREATE DT_GETPJE.FOR
+*COPY DT_GETPJE
+*
+*===getpje=============================================================*
+*
+      SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ)
+
+************************************************************************
+* This subroutine copies PHOJET partons and strings from POEVT1 into   *
+* DTEVT1.                                                              *
+*      MO1,MO2   indices of first and last mother-parton in DTEVT1     *
+*      PP,PT     4-momenta of projectile/target being handled by       *
+*                PHOJET                                                *
+* This version dated 11.12.99 is written by S. Roesler                 *
+************************************************************************
+
+      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+      SAVE
+      PARAMETER ( LINP = 10 ,
+     &            LOUT = 6 ,
+     &            LDAT = 9 )
+      PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1,
+     &           ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0)
+
+      LOGICAL LFLIP
+
+* event history
+      PARAMETER (NMXHKK=200000)
+      COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+     &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+     &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+* extended event history
+      COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+     &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+     &                IHIST(2,NMXHKK)
+* Lorentz-parameters of the current interaction
+      COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+     &                UMO,PPCM,EPROJ,PPROJ
+* DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
+      COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
+* flags for input different options
+      LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+      COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+     &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+* statistics: double-Pomeron exchange
+      COMMON /DTFLG2/ INTFLG,IPOPO
+* statistics
+      COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
+     &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
+     &                ICEVTG(8,0:30)
+* rejection counter
+      COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
+     &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
+     &                IREXCI(3),IRDIFF(2),IRINC
+C  standard particle data interface
+      INTEGER NMXHEP
+      PARAMETER (NMXHEP=4000)
+      INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
+      DOUBLE PRECISION PHEP,VHEP
+      COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
+     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
+     &                VHEP(4,NMXHEP)
+C  extension to standard particle data interface (PHOJET specific)
+      INTEGER IMPART,IPHIST,ICOLOR
+      COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
+C  color string configurations including collapsed strings and hadrons
+      INTEGER MSTR
+      PARAMETER (MSTR=500)
+      INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
+      COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
+     &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
+     &                NNCH(MSTR),IBHAD(MSTR),ISTR
+C  general process information
+      INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+      COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+C  model switches and parameters
+      CHARACTER*8 MDLNA
+      INTEGER ISWMDL,IPAMDL
+      DOUBLE PRECISION PARMDL
+      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C  event debugging information
+      INTEGER NMAXD
+      PARAMETER (NMAXD=100)
+      INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
+     &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+      COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
+     &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
+
+      DIMENSION PP(4),PT(4)
+      DATA MAXLOP /10000/
+
+      INHKK = NHKK
+      LFLIP = .TRUE.
+    1 CONTINUE
+      NPVAL = 0
+      NTVAL = 0
+      IREJ  = 0
+
+*   store initial momenta for energy-momentum conservation check
+      IF (LEMCCK) THEN
+         CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2)
+         CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2)
+      ENDIF
+* copy partons and strings from POEVT1 into DTEVT1
+      DO 11 I=1,ISTR
+C        IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN
+         IF (NCODE(I).EQ.-99) THEN
+            IDXSTG = NPOS(1,I)
+            IDSTG  = IDHEP(IDXSTG)
+            PX = PHEP(1,IDXSTG)
+            PY = PHEP(2,IDXSTG)
+            PZ = PHEP(3,IDXSTG)
+            PE = PHEP(4,IDXSTG)
+            IF (MODE.LT.0) THEN
+               ISTAT = 70000+IPJE
+               CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE,
+     &                        11,IDSTG,0)
+               IF (LEMCCK) THEN
+                  PX = -PX
+                  PY = -PY
+                  PZ = -PZ
+                  PE = -PE
+                  CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
+               ENDIF
+            ELSE
+               CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
+     &                        PPX,PPY,PPZ,PPE)
+               ISTAT = 70000+IPJE
+               CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE,
+     &                        11,IDSTG,0)
+               IF (LEMCCK) THEN
+                  PX = -PPX
+                  PY = -PPY
+                  PZ = -PPZ
+                  PE = -PPE
+                  CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
+               ENDIF
+            ENDIF
+            NOBAM(NHKK)   = 0
+            IHIST(1,NHKK) = IPHIST(1,IDXSTG)
+            IHIST(2,NHKK) = 0
+         ELSEIF (NCODE(I).GE.0) THEN
+*   indices of partons and string in POEVT1
+            IDX1 = ABS(JMOHEP(1,NPOS(1,I)))
+            IDX2 = ABS(JMOHEP(2,NPOS(1,I)))
+            IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN
+               WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2,
+     &         ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! '
+               STOP ' GETPJE 1'
+            ENDIF
+            IDXSTG = NPOS(1,I)
+*   find "mother" string of the string
+            IDXMS1 = ABS(JMOHEP(1,IDX1))
+            IDXMS2 = ABS(JMOHEP(1,IDX2))
+            IF (IDXMS1.NE.IDXMS2) THEN
+               IDXMS1 = IDXSTG
+               IDXMS2 = IDXSTG
+C              STOP ' GETPJE: IDXMS1.NE.IDXMS2 !'
+            ENDIF
+*   search POEVT1 for the original hadron of the parton
+            ILOOP = 0
+            IPOM1 = 0
+   14       CONTINUE
+            ILOOP = ILOOP+1
+            IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1
+            IDXMS1 = ABS(JMOHEP(1,IDXMS1))
+            IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND.
+     &          (ILOOP.LT.MAXLOP)) GOTO 14
+            IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! '
+            IPOM2 = 0
+            ILOOP = 0
+   15       CONTINUE
+            ILOOP = ILOOP+1
+            IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1
+            IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN
+               IDXMS2 = ABS(JMOHEP(2,IDXMS2))
+            ELSE
+               IDXMS2 = ABS(JMOHEP(1,IDXMS2))
+            ENDIF
+            IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND.
+     &          (ILOOP.LT.MAXLOP)) GOTO 15
+            IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! '
+*   parton 1
+            IF (IDXMS1.EQ.1) THEN
+               ISPTN1 = ISTHKK(MO1)
+               M1PTN1 = MO1
+               M2PTN1 = MO1+2
+            ELSE
+               ISPTN1 = ISTHKK(MO2)
+               M1PTN1 = MO2-2
+               M2PTN1 = MO2
+            ENDIF
+*   parton 2
+            IF (IDXMS2.EQ.1) THEN
+               ISPTN2 = ISTHKK(MO1)
+               M1PTN2 = MO1
+               M2PTN2 = MO1+2
+            ELSE
+               ISPTN2 = ISTHKK(MO2)
+               M1PTN2 = MO2-2
+               M2PTN2 = MO2
+            ENDIF
+*   check for mis-identified mothers and switch mother indices if necessary
+            IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6)
+     &          .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND.
+     &          (LFLIP)) THEN
+               IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN
+                  ISPTN1 = ISTHKK(MO1)
+                  M1PTN1 = MO1
+                  M2PTN1 = MO1+2
+                  ISPTN2 = ISTHKK(MO2)
+                  M1PTN2 = MO2-2
+                  M2PTN2 = MO2
+               ELSE
+                  ISPTN1 = ISTHKK(MO2)
+                  M1PTN1 = MO2-2
+                  M2PTN1 = MO2
+                  ISPTN2 = ISTHKK(MO1)
+                  M1PTN2 = MO1
+                  M2PTN2 = MO1+2
+               ENDIF
+            ENDIF
+*   register partons in temporary common
+*     parton at chain end
+            PX = PHEP(1,IDX1)
+            PY = PHEP(2,IDX1)
+            PZ = PHEP(3,IDX1)
+            PE = PHEP(4,IDX1)
+* flag only partons coming from Pomeron with 41/42
+C           IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN
+            IF (IPOM1.NE.0) THEN
+               ISTX = ABS(ISPTN1)/10
+               IMO  = ABS(ISPTN1)-10*ISTX
+               ISPTN1 = -(40+IMO)
+            ELSE
+               IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN
+                  ISTX = ABS(ISPTN1)/10
+                  IMO  = ABS(ISPTN1)-10*ISTX
+                  IF ((IDHEP(IDX1).EQ.21).OR.
+     &                (ABS(IPHIST(1,IDX1)).GE.100)) THEN
+                     ISPTN1 = -(60+IMO)
+                  ELSE
+                     ISPTN1 = -(50+IMO)
+                  ENDIF
+               ENDIF
+            ENDIF
+            IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1
+            IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1
+            IF (MODE.LT.0) THEN
+               CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY,
+     &                        PZ,PE,0,0,0)
+            ELSE
+               CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
+     &                        PPX,PPY,PPZ,PPE)
+               CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY,
+     &                        PPZ,PPE,0,0,0)
+            ENDIF
+            IHIST(1,NHKK) = IPHIST(1,IDX1)
+            IHIST(2,NHKK) = 0
+            DO 19 KK=1,4
+               VHKK(KK,NHKK) = VHKK(KK,M2PTN1)
+               WHKK(KK,NHKK) = WHKK(KK,M1PTN1)
+   19       CONTINUE
+            VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB
+            WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB
+            M1STRG = NHKK
+*     gluon kinks
+            NGLUON = IDX2-IDX1-1
+            IF (NGLUON.GT.0) THEN
+               DO 17 IGLUON=1,NGLUON
+                  IDX   = IDX1+IGLUON
+                  IDXMS = ABS(JMOHEP(1,IDX))
+                  IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN
+                     ILOOP = 0
+   16                CONTINUE
+                     ILOOP = ILOOP+1
+                     IDXMS = ABS(JMOHEP(1,IDXMS))
+                     IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND.
+     &                   (ILOOP.LT.MAXLOP)) GOTO 16
+                     IF (ILOOP.EQ.MAXLOP)
+     &                  WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! '
+                  ENDIF
+                  IF (IDXMS.EQ.1) THEN
+                     ISPTN = ISTHKK(MO1)
+                     M1PTN = MO1
+                     M2PTN = MO1+2
+                  ELSE
+                     ISPTN = ISTHKK(MO2)
+                     M1PTN = MO2-2
+                     M2PTN = MO2
+                  ENDIF
+                  PX = PHEP(1,IDX)
+                  PY = PHEP(2,IDX)
+                  PZ = PHEP(3,IDX)
+                  PE = PHEP(4,IDX)
+                  IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN
+                     ISTX = ABS(ISPTN)/10
+                     IMO  = ABS(ISPTN)-10*ISTX
+                     IF ((IDHEP(IDX).EQ.21).OR.
+     &                   (ABS(IPHIST(1,IDX)).GE.100)) THEN
+                        ISPTN = -(60+IMO)
+                     ELSE
+                        ISPTN = -(50+IMO)
+                     ENDIF
+                  ENDIF
+                  IF (ISPTN.EQ.-21) NPVAL = NPVAL+1
+                  IF (ISPTN.EQ.-22) NTVAL = NTVAL+1
+                  IF (MODE.LT.0) THEN
+                     CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
+     &                              PX,PY,PZ,PE,0,0,0)
+                  ELSE
+                     CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
+     &                              PPX,PPY,PPZ,PPE)
+                     CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
+     &                              PPX,PPY,PPZ,PPE,0,0,0)
+                  ENDIF
+                  IHIST(1,NHKK) = IPHIST(1,IDX)
+                  IHIST(2,NHKK) = 0
+                  DO 20 KK=1,4
+                     VHKK(KK,NHKK) = VHKK(KK,M2PTN)
+                     WHKK(KK,NHKK) = WHKK(KK,M1PTN)
+   20             CONTINUE
+                  VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB
+                  WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB
+   17          CONTINUE
+            ENDIF
+*     parton at chain end
+            PX = PHEP(1,IDX2)
+            PY = PHEP(2,IDX2)
+            PZ = PHEP(3,IDX2)
+            PE = PHEP(4,IDX2)
+* flag only partons coming from Pomeron with 41/42
+C           IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN
+            IF (IPOM2.NE.0) THEN
+               ISTX = ABS(ISPTN2)/10
+               IMO  = ABS(ISPTN2)-10*ISTX
+               ISPTN2 = -(40+IMO)
+            ELSE
+               IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN
+                  ISTX = ABS(ISPTN2)/10
+                  IMO  = ABS(ISPTN2)-10*ISTX
+                  IF ((IDHEP(IDX2).EQ.21).OR.
+     &                (ABS(IPHIST(1,IDX2)).GE.100)) THEN
+                     ISPTN2 = -(60+IMO)
+                  ELSE
+                     ISPTN2 = -(50+IMO)
+                  ENDIF
+               ENDIF
+            ENDIF
+            IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1
+            IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1
+            IF (MODE.LT.0) THEN
+               CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
+     &                        PX,PY,PZ,PE,0,0,0)
+            ELSE
+               CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
+     &                        PPX,PPY,PPZ,PPE)
+               CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
+     &                        PPX,PPY,PPZ,PPE,0,0,0)
+            ENDIF
+            IHIST(1,NHKK) = IPHIST(1,IDX2)
+            IHIST(2,NHKK) = 0
+            DO 21 KK=1,4
+               VHKK(KK,NHKK) = VHKK(KK,M2PTN2)
+               WHKK(KK,NHKK) = WHKK(KK,M1PTN2)
+   21       CONTINUE
+            VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB
+            WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB
+            M2STRG = NHKK
+*   register string
+            JSTRG = 100*IPROCE+NCODE(I)
+            PX = PHEP(1,IDXSTG)
+            PY = PHEP(2,IDXSTG)
+            PZ = PHEP(3,IDXSTG)
+            PE = PHEP(4,IDXSTG)
+            IF (MODE.LT.0) THEN
+               ISTAT = 70000+IPJE
+               CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
+     &                        PX,PY,PZ,PE,0,0,0)
+               IF (LEMCCK) THEN
+                  PX = -PX
+                  PY = -PY
+                  PZ = -PZ
+                  PE = -PE
+                  CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
+               ENDIF
+            ELSE
+               CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
+     &                        PPX,PPY,PPZ,PPE)
+               ISTAT = 70000+IPJE
+               CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
+     &                        PPX,PPY,PPZ,PPE,0,0,0)
+               IF (LEMCCK) THEN
+                  PX = -PPX
+                  PY = -PPY
+                  PZ = -PPZ
+                  PE = -PPE
+                  CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
+               ENDIF
+            ENDIF
+            NOBAM(NHKK)   = 0
+            IHIST(1,NHKK) = 0
+            IHIST(2,NHKK) = 0
+            DO 18 KK=1,4
+               VHKK(KK,NHKK) = VHKK(KK,MO2)
+               WHKK(KK,NHKK) = WHKK(KK,MO1)
+   18       CONTINUE
+            VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
+            WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
+         ENDIF
+   11 CONTINUE
+
+      IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN
+         NHKK  = INHKK
+         LFLIP = .FALSE.
+         GOTO 1
+      ENDIF
+
+      IF (LEMCCK) THEN
+         IF (UMO.GT.1.0D5) THEN
+            CHKLEV = 1.0D0
+         ELSE
+            CHKLEV = TINY1
+         ENDIF
+         CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2)
+         IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0)
+      ENDIF
+
+* internal statistics
+*   dble-Po statistics.
+      IF (IPROCE.NE.4) IPOPO = 0
+
+      INTFLG = IPROCE
+      IDCHSY = IDCH(MO1)
+      IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN
+         ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1
+      ELSE
+         WRITE(LOUT,1000) IPROCE,NEVHKK,MO1
+ 1000    FORMAT(1X,'GETFSP:   warning! incons. process id. (',I2,
+     &          ') at evt(chain) ',I6,'(',I2,')')
+      ENDIF
+      IF (IPROCE.EQ.5) THEN
+         IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN
+            ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1
+         ELSE
+C           WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
+ 1001       FORMAT(1X,'GETFSP:   warning! incons. diffrac. id. ',
+     &             '(IPROCE,IDIFR1,IDIFR2=',3I3,')')
+         ENDIF
+      ELSEIF (IPROCE.EQ.6) THEN
+         IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
+            ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1
+         ELSE
+C           WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
+         ENDIF
+      ELSEIF (IPROCE.EQ.7) THEN
+         IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND.
+     &       (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
+            IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1))
+     &         ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1
+            IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2))
+     &         ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1
+            IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2))
+     &         ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1
+            IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1))
+     &         ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1
+         ELSE
+            WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
+         ENDIF
+      ENDIF
+      IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3))
+     &                                                       THEN
+         ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
+         ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
+         ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
+      ENDIF
+      ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM
+      ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM
+      ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG
+      ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG)
+      ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO)
+
+      RETURN
+
+ 9999 CONTINUE
+      IREJ = 1
+      RETURN
+      END
+
+*$ CREATE DT_PHOINI.FOR
+*COPY DT_PHOINI
+*
+*===phoini=============================================================*
+*
+      SUBROUTINE DT_PHOINI
+
+************************************************************************
+* Initialization PHOJET-event generator for nucleon-nucleon interact.  *
+* This version dated 16.11.95 is written by S. Roesler                 *
+*                                                                      *
+* Last change 27.12.2006 by S. Roesler.                                *
+************************************************************************
+
+      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+      SAVE
+      PARAMETER ( LINP = 10 ,
+     &            LOUT = 6 ,
+     &            LDAT = 9 )
+      PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
+
+* nucleon-nucleon event-generator
+      CHARACTER*8 CMODEL
+      LOGICAL LPHOIN
+      COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+* particle properties (BAMJET index convention)
+      CHARACTER*8  ANAME
+      COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+     &                IICH(210),IIBAR(210),K1(210),K2(210)
+* Lorentz-parameters of the current interaction
+      COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+     &                UMO,PPCM,EPROJ,PPROJ
+* properties of interacting particles
+      COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+* properties of photon/lepton projectiles
+      COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
+      PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
+* emulsion treatment
+      COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
+     &                NCOMPO,IEMUL
+* VDM parameter for photon-nucleus interactions
+      COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
+* nuclear potential
+      LOGICAL LFERMI
+      COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
+     &                EBINDP(2),EBINDN(2),EPOT(2,210),
+     &                ETACOU(2),ICOUL,LFERMI
+* Glauber formalism: flags and parameters for statistics
+      LOGICAL LPROD
+      CHARACTER*8 CGLB
+      COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
+*
+* parameters for cascade calculations:
+* maximum mumber of PDF's which can be defined in phojet (limited
+* by the dimension of ipdfs in pho_setpdf)
+      PARAMETER (MAXPDF = 20)
+* PDF parametrization and number of set for the first 30 hadrons in
+* the bamjet-code list
+*   negative numbers mean that the PDF is set in phojet,
+*   zero stands for "not a hadron"
+      DIMENSION IPARPD(30),ISETPD(30)
+* PDF parametrization
+      DATA IPARPD /
+     &  -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5,
+     &   5, 5,-5, 5, 5, 0, 0, 0, 0, 0/
+* number of set
+      DATA ISETPD /
+     &  -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6,
+     &   6, 6,-2, 2, 2, 0, 0, 0, 0, 0/
+
+**PHOJET105a
+C     COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+C     PARAMETER ( MAXPRO = 16 )
+C     PARAMETER ( MAXTAB = 20 )
+C     COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO),
+C    &                MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB
+C     CHARACTER*8 MDLNA
+C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
+C     COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15)
+**PHOJET110
+C  global event kinematics and particle IDs
+      INTEGER IFPAP,IFPAB
+      DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
+      COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
+C  hard cross sections and MC selection weights
+      INTEGER Max_pro_2
+      PARAMETER ( Max_pro_2 = 16 )
+      INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
+     &  MH_acc_1,MH_acc_2
+      DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
+      COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
+     &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
+     &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
+     &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
+     &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
+C  model switches and parameters
+      CHARACTER*8 MDLNA
+      INTEGER ISWMDL,IPAMDL
+      DOUBLE PRECISION PARMDL
+      COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
+C  general process information
+      INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
+      COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
+**
+      DIMENSION PP(4),PT(4)
+
+      LOGICAL LSTART
+      DATA LSTART /.TRUE./
+
+      IJP = IJPROJ
+      IJT = IJTARG
+      Q2  = VIRT
+* lepton-projectiles: initialize real photon instead
+      IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN
+         IJP = 7
+         Q2  = ZERO
+      ENDIF
+      IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IDUM)
+* switch Reggeon off
+C     IPAMDL(3)= 0
+      IF (IP.EQ.1) THEN
+         IFPAP(1) = IDT_IPDGHA(IJP)
+         IFPAB(1) = IJP
+      ELSE
+         IFPAP(1) = 2212
+         IFPAB(1) = IDT_ICIHAD(IFPAP(1))
+      ENDIF
+      PMASS(1) = AAM(IFPAB(1))-SQRT(Q2)
+      PVIRT(1) = PMASS(1)**2
+      IF (IT.EQ.1) THEN
+         IFPAP(2) = IDT_IPDGHA(IJT)
+         IFPAB(2) = IJT
+      ELSE
+         IFPAP(2) = 2212
+         IFPAB(2) = IDT_ICIHAD(IFPAP(2))
+      ENDIF
+      PMASS(2) = AAM(IFPAB(2))
+      PVIRT(2) = ZERO
+      DO 1 K=1,4
+         PP(K) = ZERO
+         PT(K) = ZERO
+    1 CONTINUE
+* get max. possible momenta of incoming particles to be used for PHOJET ini.
+      PPF = ZERO
+      PTF = ZERO
+      SCPF= 1.5D0
+      IF (UMO.GE.1.E5) THEN
+         SCPF= 5.0D0
+      ENDIF
+      IF (NCOMPO.GT.0) THEN
+         DO 2 I=1,NCOMPO
+            IF (IT.GT.1) THEN
+               CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0)
+            ELSE
+               CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0)
+            ENDIF
+            PPFTMP = MAX(PFERMP(1),PFERMN(1))
+            PTFTMP = MAX(PFERMP(2),PFERMN(2))
+            IF (PPFTMP.GT.PPF) PPF = PPFTMP
+            IF (PTFTMP.GT.PTF) PTF = PTFTMP
+    2    CONTINUE
+      ELSE
+         CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
+         PPF = MAX(PFERMP(1),PFERMN(1))
+         PTF = MAX(PFERMP(2),PFERMN(2))
+      ENDIF
+      PTF = -PTF
+      PPF = SCPF*PPF
+      PTF = SCPF*PTF
+      IF (IJP.EQ.7) THEN
+         AMP2  = SIGN(PMASS(1)**2,PMASS(1))
+         PP(3) = PPCM
+         PP(4) = SQRT(AMP2+PP(3)**2)
+      ELSE
+         EPF = SQRT(PPF**2+PMASS(1)**2)
+         CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2)
+      ENDIF
+      ETF = SQRT(PTF**2+PMASS(2)**2)
+      CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3)
+      ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
+     &              (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
+      IF (LSTART) THEN
+         WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP
+ 1001    FORMAT(
+     &      ' DT_PHOINI:    PHOJET initialized for projectile A,Z = ',
+     &      I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
+         IF (NCOMPO.GT.0) THEN
+            WRITE(LOUT,1002) SCPF,PTF,PT
+         ELSE
+            WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT
+         ENDIF
+ 1002    FORMAT(
+     &      ' DT_PHOINI:    PHOJET initialized for target emulsion  ',
+     &          /,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
+ 1003    FORMAT(
+     &      ' DT_PHOINI:    PHOJET initialized for target     A,Z = ',
+     &      I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
+         WRITE(LOUT,1004) ECMINI
+ 1004    FORMAT(' E_cm = ',E10.3)
+         IF (IJP.EQ.8) WRITE(LOUT,1005)
+ 1005    FORMAT(
+     &      ' DT_PHOINI: warning! proton parameters used for neutron',
+     &          ' projectile')
+         LSTART = .FALSE.
+      ENDIF
+* switch off new diffractive cross sections at low energies for nuclei
+* (temporary solution)
+      IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN
+         WRITE(LOUT,'(1X,A)')
+     &      ' DT_PHOINI: model-switch 30 for nuclei re-set !'
+         CALL PHO_SETMDL(30,0,1)
+      ENDIF
+*
+C     IF (IJP.EQ.7) THEN
+C        AMP2  = SIGN(PMASS(1)**2,PMASS(1))
+C        PP(3) = PPCM
+C        PP(4) = SQRT(AMP2+PP(3)**2)
+C     ELSE
+C        PFERMX = ZERO
+C        IF (IP.GT.1) PFERMX = 0.5D0
+C        EFERMX = SQRT(PFERMX**2+PMASS(1)**2)
+C        CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2)
+C     ENDIF
+C     PFERMX = ZERO
+C     IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0
+C     EFERMX = SQRT(PFERMX**2+PMASS(2)**2)
+C     CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3)
+**sr 26.10.96
+      ISAV = IPAMDL(13)
+      IF ((ISHAD(2).EQ.1).AND.
+     &   ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR.
+     &    (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1
+**
+      CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1)
+**sr 26.10.96
+      IPAMDL(13) = ISAV
+**
+*
+* patch for cascade calculations:
+* define parton distribution functions for other hadrons, i.e. other
+* then defined already in phojet
+      IF (IOGLB.EQ.100) THEN
+         WRITE(LOUT,1006)
+ 1006    FORMAT(/,1X,'PHOINI: additional parton distribution functions',
+     &          ' assiged (ID,IPAR,ISET)',/)
+         NPDF = 0
+         DO 3 I=1,30
+            IF (IPARPD(I).NE.0) THEN
+               NPDF = NPDF+1
+               IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !'
+               IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN
+                  IDPDG = IDT_IPDGHA(I)
+                  IPAR  = IPARPD(I)
+                  ISET  = ISETPD(I)
+                  WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET
+                  CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1)
+               ENDIF
+            ENDIF
+    3    CONTINUE
+      ENDIF
+
+C     CALL PHO_PHIST(-1,SIGMAX)
+      IF (IREJ1.NE.0) THEN
+         WRITE(LOUT,1000)
+ 1000    FORMAT(1X,'PHOINI:   PHOJET event-initialization failed!')
+         STOP
+      ENDIF
+
+      RETURN
+      END
+
+*$ CREATE DT_EVENTD.FOR
+*COPY DT_EVENTD
+*
+*===eventd=============================================================*
+*
+      SUBROUTINE DT_EVENTD(IREJ)
+
+************************************************************************
+* Quasi-elastic neutrino nucleus scattering.                           *
+* This version dated 29.04.00 is written by S. Roesler.                *
+************************************************************************
+
+      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+      SAVE
+      PARAMETER ( LINP = 10 ,
+     &            LOUT = 6 ,
+     &            LDAT = 9 )
+      PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5)
+      PARAMETER (SQTINF=1.0D+15)
+
+      LOGICAL LFIRST
+
+* event history
+      PARAMETER (NMXHKK=200000)
+      COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+     &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+     &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+* extended event history
+      COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+     &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+     &                IHIST(2,NMXHKK)
+* flags for input different options
+      LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+      COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+     &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+      PARAMETER (MAXLND=4000)
+      COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
+* properties of interacting particles
+      COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+* Lorentz-parameters of the current interaction
+      COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+     &                UMO,PPCM,EPROJ,PPROJ
+* nuclear potential
+      LOGICAL LFERMI
+      COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
+     &                EBINDP(2),EBINDN(2),EPOT(2,210),
+     &                ETACOU(2),ICOUL,LFERMI
+* steering flags for qel neutrino scattering modules
+      COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
+      COMMON /QNPOL/ POLARX(4),PMODUL
+      INTEGER PYK
+
+      DATA LFIRST /.TRUE./
+
+      IREJ = 0
+
+      IF (LFIRST) THEN
+         LFIRST = .FALSE.
+         CALL DT_MASS_INI
+      ENDIF
+
+* JETSET parameter
+      CALL DT_INITJS(0)
+
+* interacting target nucleon
+      LTYP = NEUTYP
+      IF (NEUDEC.LE.9) THEN
+         IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN
+            NUCTYP = 2112
+            NUCTOP = 2
+         ELSE
+            NUCTYP = 2212
+            NUCTOP = 1
+         ENDIF
+      ELSE
+         RTYP  = DT_RNDM(RTYP)
+         ZFRAC = DBLE(ITZ)/DBLE(IT)
+         IF (RTYP.LE.ZFRAC) THEN
+            NUCTYP = 2212
+            NUCTOP = 1
+         ELSE
+            NUCTYP = 2112
+            NUCTOP = 2
+         ENDIF
+      ENDIF
+
+* select first nucleon in list with matching id and reset all other
+* nucleons which have been marked as "wounded" by ININUC
+      IFOUND = 0
+      DO 1 I=1,NHKK
+         IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN
+            ISTHKK(I) = 12
+            IFOUND    = 1
+            IDX = I
+         ELSE
+            IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14
+         ENDIF
+    1 CONTINUE
+      IF (IFOUND.EQ.0)
+     &   STOP ' EVENTD: interacting target nucleon not found! '
+
+* correct position of proj. lepton: assume position of target nucleon
+      DO 3 I=1,4
+         VHKK(I,1) = VHKK(I,IDX)
+         WHKK(I,1) = WHKK(I,IDX)
+    3 CONTINUE
+
+* load initial momenta for conservation check
+      IF (LEMCCK) THEN
+         CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM)
+         CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX),
+     &                                                      2,IDUM,IDUM)
+      ENDIF
+
+* quasi-elastic scattering
+      IF (NEUDEC.LT.9) THEN
+         CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),
+     &                                          PHKK(4,IDX),PHKK(5,IDX))
+*  CC event on p or n
+      ELSEIF (NEUDEC.EQ.10) THEN
+         CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX),
+     &                     PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
+*  NC event on p or n
+      ELSEIF (NEUDEC.EQ.11) THEN
+         CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX),
+     &                     PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
+      ENDIF
+
+* get final state particles from Lund-common and write them into HKKEVT
+      NPOINT(1) = NHKK+1
+      NPOINT(4) = NHKK+1
+      NLINES = PYK(0,1)
+      NHKK0  = NHKK+1
+      DO 4 I=4,NLINES
+         IF (K(I,1).EQ.1) THEN
+            ID = K(I,2)
+            PX = P(I,1)
+            PY = P(I,2)
+            PZ = P(I,3)
+            PE = P(I,4)
+            CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0)
+            IDBJ = IDT_ICIHAD(ID)
+            EKIN = PHKK(4,NHKK)-PHKK(5,NHKK)
+            IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN
+               IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16
+            ENDIF
+            VHKK(1,NHKK) = VHKK(1,IDX)
+            VHKK(2,NHKK) = VHKK(2,IDX)
+            VHKK(3,NHKK) = VHKK(3,IDX)
+            VHKK(4,NHKK) = VHKK(4,IDX)
+C           IF (I.EQ.4) THEN
+C              WHKK(1,NHKK) = POLARX(1)
+C              WHKK(2,NHKK) = POLARX(2)
+C              WHKK(3,NHKK) = POLARX(3)
+C              WHKK(4,NHKK) = POLARX(4)
+C           ELSE
+               WHKK(1,NHKK) = WHKK(1,IDX)
+               WHKK(2,NHKK) = WHKK(2,IDX)
+               WHKK(3,NHKK) = WHKK(3,IDX)
+               WHKK(4,NHKK) = WHKK(4,IDX)
+C           ENDIF
+            IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
+         ENDIF
+    4 CONTINUE
+
+      IF (LEMCCK) THEN
+         CHKLEV = TINY5
+         CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1)
+         IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
+      ENDIF
+
+* transform momenta into cms (as required for inc etc.)
+      DO 5 I=NHKK0,NHKK
+         IF (ISTHKK(I).EQ.1) THEN
+            CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3)
+            PHKK(3,I) = PZ
+            PHKK(4,I) = PE
+         ENDIF
+    5 CONTINUE
+
+      RETURN
+      END
+
+*$ CREATE DT_KKEVNT.FOR
+*COPY DT_KKEVNT
+*
+*===kkevnt=============================================================*
+*
+      SUBROUTINE DT_KKEVNT(KKMAT,IREJ)
+
+************************************************************************
+* Treatment of complete nucleus-nucleus or hadron-nucleus scattering   *
+* without nuclear effects (one event).                                 *
+* This subroutine is an update of the previous version (KKEVT) written *
+* by J. Ranft/ H.-J. Moehring.                                         *
+* This version dated 20.04.95 is written by S. Roesler                 *
+************************************************************************
+
+      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+      SAVE
+      PARAMETER ( LINP = 10 ,
+     &            LOUT = 6 ,
+     &            LDAT = 9 )
+      PARAMETER (ZERO=0.0D0,TINY10=1.0D-10)
+
+      PARAMETER ( MAXNCL = 260,
+     &            MAXVQU = MAXNCL,
+     &            MAXSQU = 20*MAXVQU,
+     &            MAXINT = MAXVQU+MAXSQU)
+* event history
+      PARAMETER (NMXHKK=200000)
+      COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+     &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+     &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+* extended event history
+      COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+     &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+     &                IHIST(2,NMXHKK)
+* flags for input different options
+      LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+      COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+     &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+* rejection counter
+      COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
+     &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
+     &                IREXCI(3),IRDIFF(2),IRINC
+* statistics
+      COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
+     &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
+     &                ICEVTG(8,0:30)
+* properties of interacting particles
+      COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
+* Lorentz-parameters of the current interaction
+      COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+     &                UMO,PPCM,EPROJ,PPROJ
+* flags for diffractive interactions (DTUNUC 1.x)
+      COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
+* interface HADRIN-DPM
+      COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
+* nucleon-nucleon event-generator
+      CHARACTER*8 CMODEL
+      LOGICAL LPHOIN
+      COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
+* coordinates of nucleons
+      COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
+* interface between Glauber formalism and DPM
+      COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
+     &                INTER1(MAXINT),INTER2(MAXINT)
+* Glauber formalism: collision properties
+      COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
+     &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
+* central particle production, impact parameter biasing
+      COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
+**temporary
+* statistics: Glauber-formalism
+      COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
+**
+
+      DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/
+
+      IREJ   = 0
+      ICREQU = ICREQU+1
+      NC     = 0
+
+    1 CONTINUE
+      ICSAMP = ICSAMP+1
+      NC     = NC+1
+      IF (MOD(NC,10).EQ.0) THEN
+         WRITE(LOUT,1000) NEVHKK
+ 1000    FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
+         GOTO 9999
+      ENDIF
+
+* initialize DTEVT1/DTEVT2
+      CALL DT_EVTINI
+
+* We need the following only in order to sample nucleon coordinates.
+* However we don't have parameters (cross sections, slope etc.)
+* for neutrinos available. Therefore switch projectile to proton
+* in this case.
+      IF (MCGENE.EQ.4) THEN
+         JJPROJ = 1
+      ELSE
+         JJPROJ = IJPROJ
+      ENDIF
+
+   10 CONTINUE
+      IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
+* make sure that Glauber-formalism is called each time the interaction
+* configuration changed
+     &     (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
+     &     (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
+* sample number of nucleon-nucleon coll. according to Glauber-form.
+         CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
+         NWTSAM = NN
+         NWASAM = NP
+         NWBSAM = NT
+         NEVOLD = NEVHKK
+         IPOLD  = IP
+         ITOLD  = IT
+         JJPOLD = JJPROJ
+         EPROLD = EPROJ
+      ENDIF
+
+* force diffractive particle production in h-K interactions
+      IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
+     &    (IP.EQ.1).AND.(NN.NE.1)) THEN
+         NEVOLD = 0
+         GOTO 10
+      ENDIF
+
+* check number of involved proj. nucl. (NP) if central prod.is requested
+      IF (ICENTR.GT.0) THEN
+         CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
+         IF (IBACK.GT.0) GOTO 10
+      ENDIF
+
+* get initial nucleon-configuration in projectile and target
+* rest-system (including Fermi-momenta if requested)
+      CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
+      MODE = 2
+      IF (EPROJ.LE.EHADTH) MODE = 3
+      CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
+
+      IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
+
+* activate HADRIN at low energies (implemented for h-N scattering only)
+         IF (EPROJ.LE.EHADHI) THEN
+            IF (EHADTH.LT.ZERO) THEN
+*   smooth transition btwn. DPM and HADRIN
+               FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
+               RR   = DT_RNDM(FRAC)
+               IF (RR.GT.FRAC) THEN
+                  IF (IP.EQ.1) THEN
+                     CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
+                     IF (IREJ1.GT.0) GOTO 1
+                     RETURN
+                  ELSE
+                     WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
+                  ENDIF
+               ENDIF
+            ELSE
+*   fixed threshold for onset of production via HADRIN
+               IF (EPROJ.LE.EHADTH) THEN
+                  IF (IP.EQ.1) THEN
+                     CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
+                     IF (IREJ1.GT.0) GOTO 1
+                     RETURN
+                  ELSE
+                     WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
+                  ENDIF
+               ENDIF
+            ENDIF
+         ENDIF
+ 1001    FORMAT(1X,'KKEVNT:   warning! interaction of proj. (m=',
+     &          I3,') with target (m=',I3,')',/,11X,
+     &          'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
+     &          'GeV) cannot be handled')
+
+* sampling of momentum-x fractions & flavors of chain ends
+         CALL DT_SPLPTN(NN)
+
+* Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
+         CALL DT_NUC2CM
+
+* collect momenta of chain ends and put them into DTEVT1
+         CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
+         IF (IREJ1.NE.0) GOTO 1
+
+      ENDIF
+
+* handle chains including fragmentation (two-chain approximation)
+      IF (MCGENE.EQ.1) THEN
+*  two-chain approximation
+         CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
+         IF (IREJ1.NE.0) THEN
+            IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
+            GOTO 1
+         ENDIF
+      ELSEIF (MCGENE.EQ.2) THEN
+*  multiple-Po exchange including minijets
+         CALL DT_EVENTB(NCSY,IREJ1)
+         IF (IREJ1.NE.0) THEN
+            IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
+            GOTO 1
+         ENDIF
+      ELSEIF (MCGENE.EQ.3) THEN
+         STOP ' This version does not contain LEPTO !'
+      ELSEIF (MCGENE.EQ.4) THEN
+*  quasi-elastic neutrino scattering
+         CALL DT_EVENTD(IREJ1)
+         IF (IREJ1.NE.0) THEN
+            IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
+            GOTO 1
+         ENDIF
+      ELSE
+         WRITE(LOUT,1002) MCGENE
+ 1002    FORMAT(1X,'KKEVNT:   warning! event-generator',I4,
+     &         ' not available - program stopped')
+         STOP
+      ENDIF
+
+      RETURN
+
+ 9999 CONTINUE
+      IREJ = 1
+      RETURN
+      END
+
+*$ CREATE DT_CHKCEN.FOR
+*COPY DT_CHKCEN
+*
+*===chkcen=============================================================*
+*
+      SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
+
+************************************************************************
+* Check of number of involved projectile nucleons if central production*
+* is requested.                                                        *
+* Adopted from a part of the old KKEVT routine which was written by    *
+* J. Ranft/H.-J.Moehring.                                              *
+* This version dated 13.01.95 is written by S. Roesler                 *
+************************************************************************
+
+      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+      SAVE
+      PARAMETER ( LINP = 10 ,
+     &            LOUT = 6 ,
+     &            LDAT = 9 )
+
+* statistics
+      COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
+     &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
+     &                ICEVTG(8,0:30)
+* central particle production, impact parameter biasing
+      COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
+
+      IBACK = 0
+
+* old version
+      IF (ICENTR.EQ.2) THEN
+         IF (IP.LT.IT) THEN
+            IF (IP.LE.8) THEN
+               IF (NP.LT.IP-1) IBACK = 1
+            ELSEIF (IP.LE.16) THEN
+               IF (NP.LT.IP-2) IBACK = 1
+            ELSEIF (IP.LE.32) THEN
+               IF (NP.LT.IP-3) IBACK = 1
+            ELSEIF (IP.GE.33) THEN
+               IF (NP.LT.IP-5) IBACK = 1
+            ENDIF
+         ELSEIF (IP.EQ.IT) THEN
+            IF (IP.EQ.32) THEN
+               IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
+            ELSE
+               IF (NP.LT.IP-IP/8) IBACK = 1
+            ENDIF
+         ELSEIF (ABS(IP-IT).LT.3) THEN
+            IF (NP.LT.IP-IP/8) IBACK = 1
+         ENDIF
+      ELSE
+* new version (DPMJET, 5.6.99)
+         IF (IP.LT.IT) THEN
+            IF (IP.LE.8) THEN
+               IF (NP.LT.IP-1) IBACK = 1
+            ELSEIF (IP.LE.16) THEN
+               IF (NP.LT.IP-2) IBACK = 1
+            ELSEIF (IP.LT.32) THEN
+               IF (NP.LT.IP-3) IBACK = 1
+            ELSEIF (IP.GE.32) THEN
+               IF (IT.LE.150) THEN
+*   Example: S-Ag
+                  IF (NP.LT.IP-1) IBACK = 1
+               ELSE
+*   Example: S-Au
+                  IF (NP.LT.IP) IBACK = 1
+               ENDIF
+            ENDIF
+         ELSEIF (IP.EQ.IT) THEN
+*   Example: S-S
+           IF (IP.EQ.32) THEN
+              IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
+*   Example: Pb-Pb
+           ELSE
+              IF (NP.LT.IP-IP/4) IBACK = 1
+           ENDIF
+         ELSEIF (ABS(IP-IT).LT.3) THEN
+            IF (NP.LT.IP-IP/8) IBACK = 1
+         ENDIF
+      ENDIF
+
+      ICCPRO = ICCPRO+1
+
+      RETURN
+      END
+
+*$ CREATE DT_ININUC.FOR
+*COPY DT_ININUC
+*
+*===ininuc=============================================================*
+*
+      SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
+
+************************************************************************
+* Samples initial configuration of nucleons in nucleus with mass NMASS *
+* including Fermi-momenta (if reqested).                               *
+*          ID             BAMJET-code for hadrons (instead of nuclei)  *
+*          NMASS          mass number of nucleus (number of nucleons)  *
+*          NCH            charge of nucleus                            *
+*          COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
+*          JS(NMASS) > 0  nucleon undergoes nucleon-nucleon interact.  *
+*          IMODE = 1      projectile nucleus                           *
+*                = 2      target     nucleus                           *
+*                = 3      target     nucleus (E_lab<E_thr for HADRIN)  *
+* Adopted from a part of the old KKEVT routine which was written by    *
+* J. Ranft/H.-J.Moehring.                                              *
+* This version dated 13.01.95 is written by S. Roesler                 *
+************************************************************************
+
+      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+      SAVE
+      PARAMETER ( LINP = 10 ,
+     &            LOUT = 6 ,
+     &            LDAT = 9 )
+      PARAMETER (FM2MM=1.0D-12)
+
+      PARAMETER ( MAXNCL = 260,
+     &            MAXVQU = MAXNCL,
+     &            MAXSQU = 20*MAXVQU,
+     &            MAXINT = MAXVQU+MAXSQU)
+* event history
+      PARAMETER (NMXHKK=200000)
+      COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+     &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+     &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+* extended event history
+      COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+     &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+     &                IHIST(2,NMXHKK)
+* flags for input different options
+      LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+      COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+     &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+* auxiliary common for chain system storage (DTUNUC 1.x)
+      COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
+* nuclear potential
+      LOGICAL LFERMI
+      COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
+     &                EBINDP(2),EBINDN(2),EPOT(2,210),
+     &                ETACOU(2),ICOUL,LFERMI
+* properties of photon/lepton projectiles
+      COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
+* particle properties (BAMJET index convention)
+      CHARACTER*8  ANAME
+      COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+     &                IICH(210),IIBAR(210),K1(210),K2(210)
+* Glauber formalism: collision properties
+      COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
+     &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
+* flavors of partons (DTUNUC 1.x)
+      COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
+     &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
+     &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
+     &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
+     &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
+     &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
+     &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
+* interface HADRIN-DPM
+      COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
+
+      DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
+
+* number of neutrons
+      NNEU = NMASS-NCH
+* initializations
+      NP = 0
+      NN = 0
+      DO 1 K=1,4
+         PFTOT(K) = 0.0D0
+    1 CONTINUE
+      MODE   = IMODE
+      IF (IMODE.GT.2) MODE = 2
+**sr 29.5. new NPOINT(1)-definition
+C     IF (IMODE.GE.2) NPOINT(1) = NHKK+1
+**
+      NHADRI = 0
+      NC     = NHKK
+
+* get initial configuration
+      DO 2 I=1,NMASS
+         NHKK = NHKK+1
+         IF (JS(I).GT.0) THEN
+            ISTHKK(NHKK) = 10+MODE
+            IF (IMODE.EQ.3) THEN
+*   additional treatment if HADRIN-generator is requested
+               NHADRI = NHADRI+1
+               IF (NHADRI.EQ.1) IDXTA  = NHKK
+               IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
+            ENDIF
+         ELSE
+            ISTHKK(NHKK) = 12+MODE
+         ENDIF
+         IF (NMASS.GE.2) THEN
+*   treatment for nuclei
+            FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
+            RR   = DT_RNDM(FRAC)
+            IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
+               IDX = 8
+               NN  = NN+1
+            ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
+               IDX = 1
+               NP  = NP+1
+            ELSEIF (NN.LT.NNEU) THEN
+               IDX = 8
+               NN  = NN+1
+            ELSEIF (NP.LT.NCH)  THEN
+               IDX = 1
+               NP  = NP+1
+            ENDIF
+            IDHKK(NHKK) = IDT_IPDGHA(IDX)
+            IDBAM(NHKK) = IDX
+            IF (MODE.EQ.1) THEN
+               IPOSP(I)  = NHKK
+               KKPROJ(I) = IDX
+            ELSE
+               IPOST(I)  = NHKK
+               KKTARG(I) = IDX
+            ENDIF
+            IF (IDX.EQ.1) THEN
+               PFER = PFERMP(MODE)
+               PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
+            ELSE
+               PFER = PFERMN(MODE)
+               PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
+            ENDIF
+            CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
+            DO 3 K=1,4
+               PFTOT(K) = PFTOT(K)+PF(K)
+               PHKK(K,NHKK) = PF(K)
+    3       CONTINUE
+            PHKK(5,NHKK) = AAM(IDX)
+         ELSE
+*   treatment for hadrons
+            IDHKK(NHKK)  = IDT_IPDGHA(ID)
+            IDBAM(NHKK)  = ID
+            PHKK(4,NHKK) = AAM(ID)
+            PHKK(5,NHKK) = AAM(ID)
+C* VDM assumption
+C            IF (IDHKK(NHKK).EQ.22) THEN
+C               PHKK(4,NHKK) = AAM(33)
+C               PHKK(5,NHKK) = AAM(33)
+C            ENDIF
+            IF (MODE.EQ.1) THEN
+               IPOSP(I)  = NHKK
+               KKPROJ(I) = ID
+               PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
+            ELSE
+               IPOST(I)  = NHKK
+               KKTARG(I) = ID
+            ENDIF
+         ENDIF
+         DO 4 K=1,3
+            VHKK(K,NHKK) = COORD(K,I)*FM2MM
+            WHKK(K,NHKK) = COORD(K,I)*FM2MM
+    4    CONTINUE
+         IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
+         IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
+         VHKK(4,NHKK) = 0.0D0
+         WHKK(4,NHKK) = 0.0D0
+    2 CONTINUE
+
+* balance Fermi-momenta
+      IF (NMASS.GE.2) THEN
+         DO 5 I=1,NMASS
+            NC = NC+1
+            DO 6 K=1,3
+               PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
+    6       CONTINUE
+            PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
+     &                        PHKK(2,NC)**2+PHKK(3,NC)**2)
+    5    CONTINUE
+      ENDIF
+
+      RETURN
+      END
+
+*$ CREATE DT_FER4M.FOR
+*COPY DT_FER4M
+*
+*===fer4m==============================================================*
+*
+      SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
+
+************************************************************************
+* Sampling of nucleon Fermi-momenta from distributions at T=0.         *
+*                                   processed by S. Roesler, 17.10.95  *
+************************************************************************
+
+      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+      SAVE
+      PARAMETER ( LINP = 10 ,
+     &            LOUT = 6 ,
+     &            LDAT = 9 )
+
+      LOGICAL LSTART
+
+* particle properties (BAMJET index convention)
+      CHARACTER*8  ANAME
+      COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+     &                IICH(210),IIBAR(210),K1(210),K2(210)
+* nuclear potential
+      LOGICAL LFERMI
+      COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
+     &                EBINDP(2),EBINDN(2),EPOT(2,210),
+     &                ETACOU(2),ICOUL,LFERMI
+
+      DATA LSTART /.TRUE./
+
+      ILOOP = 0
+      IF (LFERMI) THEN
+         IF (LSTART) THEN
+            WRITE(LOUT,1000)
+ 1000       FORMAT(/,1X,'FER4M:   sampling of Fermi-momenta activated')
+            LSTART = .FALSE.
+         ENDIF
+    1    CONTINUE
+         CALL DT_DFERMI(PABS)
+         PABS = PFERM*PABS
+C        IF (PABS.GE.PBIND) THEN
+C           ILOOP = ILOOP+1
+C           IF (MOD(ILOOP,500).EQ.0) THEN
+C              WRITE(LOUT,1001) PABS,PBIND,ILOOP
+C1001          FORMAT(1X,'FER4M:    Fermi-mom. corr. for binding',
+C    &                ' energy ',2E12.3,I6)
+C           ENDIF
+C           GOTO 1
+C        ENDIF
+         CALL DT_DPOLI(POLC,POLS)
+         CALL DT_DSFECF(SFE,CFE)
+         CXTA = POLS*CFE
+         CYTA = POLS*SFE
+         CZTA = POLC
+         ET   = SQRT(PABS*PABS+AAM(KT)**2)
+         PXT  = CXTA*PABS
+         PYT  = CYTA*PABS
+         PZT  = CZTA*PABS
+      ELSE
+         ET   = AAM(KT)
+         PXT  = 0.0D0
+         PYT  = 0.0D0
+         PZT  = 0.0D0
+      ENDIF
+
+      RETURN
+      END
+
+*$ CREATE DT_NUC2CM.FOR
+*COPY DT_NUC2CM
+*
+*===nuc2cm=============================================================*
+*
+      SUBROUTINE DT_NUC2CM
+
+************************************************************************
+* Lorentz-transformation of all wounded nucleons from Lab. to nucl.-   *
+* nucl. cms. (This subroutine replaces NUCMOM.)                        *
+* This version dated 15.01.95 is written by S. Roesler                 *
+************************************************************************
+
+      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+      SAVE
+      PARAMETER ( LINP = 10 ,
+     &            LOUT = 6 ,
+     &            LDAT = 9 )
+      PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
+
+* event history
+      PARAMETER (NMXHKK=200000)
+      COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+     &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+     &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+* extended event history
+      COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+     &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+     &                IHIST(2,NMXHKK)
+* statistics
+      COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
+     &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
+     &                ICEVTG(8,0:30)
+* properties of photon/lepton projectiles
+      COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
+* particle properties (BAMJET index convention)
+      CHARACTER*8  ANAME
+      COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+     &                IICH(210),IIBAR(210),K1(210),K2(210)
+* Glauber formalism: collision properties
+      COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
+     &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
+**temporary
+* statistics: Glauber-formalism
+      COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
+**
+
+      ICWP = 0
+      ICWT = 0
+      NWTACC = 0
+      NWAACC = 0
+      NWBACC = 0
+
+      NPOINT(1) = NHKK+1
+      NEND      = NHKK
+      DO 1 I=1,NEND
+         IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
+            IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
+            IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
+            MODE = ISTHKK(I)-9
+C            IF (IDHKK(I).EQ.22) THEN
+C* VDM assumption
+C               PEIN = AAM(33)
+C               IDB  = 33
+C            ELSE
+C               PEIN = PHKK(4,I)
+C               IDB  = IDBAM(I)
+C            ENDIF
+C            CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
+C     &           PX,PY,PZ,PE,IDB,MODE)
+            IF (PHKK(5,I).GT.ZERO) THEN
+               CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
+     &              PX,PY,PZ,PE,IDBAM(I),MODE)
+            ELSE
+               PX = PGAMM(1)
+               PY = PGAMM(2)
+               PZ = PGAMM(3)
+               PE = PGAMM(4)
+            ENDIF
+            IST = ISTHKK(I)-2
+            ID  = IDHKK(I)
+C* VDM assumption
+C            IF (ID.EQ.22) ID = 113
+            CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
+            IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
+            IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
+         ENDIF
+    1 CONTINUE
+
+      NWTACC = MAX(NWAACC,NWBACC)
+      ICDPR  = ICDPR+ICWP
+      ICDTA  = ICDTA+ICWT
+**temporary
+      IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
+         CALL DT_EVTOUT(4)
+         STOP
+      ENDIF
+
+      RETURN
+      END
+
+*$ CREATE DT_SPLPTN.FOR
+*COPY DT_SPLPTN
+*
+*===splptn=============================================================*
+*
+      SUBROUTINE DT_SPLPTN(NN)
+
+************************************************************************
+* SamPLing of ParToN momenta and flavors.                              *
+* This version dated 15.01.95 is written by S. Roesler                 *
+************************************************************************
+
+      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+      SAVE
+      PARAMETER ( LINP = 10 ,
+     &            LOUT = 6 ,
+     &            LDAT = 9 )
+
+* Lorentz-parameters of the current interaction
+      COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
+     &                UMO,PPCM,EPROJ,PPROJ
+
+* sample flavors of sea-quarks
+      CALL DT_SPLFLA(NN,1)
+
+* sample x-values of partons at chain ends
+      ECM = UMO
+      CALL DT_XKSAMP(NN,ECM)
+
+* samle flavors
+      CALL DT_SPLFLA(NN,2)
+
+      RETURN
+      END
+
+*$ CREATE DT_SPLFLA.FOR
+*COPY DT_SPLFLA
+*
+*===splfla=============================================================*
+*
+      SUBROUTINE DT_SPLFLA(NN,MODE)
+
+************************************************************************
+* SamPLing of FLAvors of partons at chain ends.                        *
+* This subroutine replaces FLKSAA/FLKSAM.                              *
+*            NN            number of nucleon-nucleon interactions      *
+*            MODE = 1      sea-flavors                                 *
+*                 = 2      valence-flavors                             *
+* Based on the original version written by J. Ranft/H.-J. Moehring.    *
+* This version dated 16.01.95 is written by S. Roesler                 *
+************************************************************************
+
+      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+      SAVE
+      PARAMETER ( LINP = 10 ,
+     &            LOUT = 6 ,
+     &            LDAT = 9 )
+
+      PARAMETER ( MAXNCL = 260,
+     &            MAXVQU = MAXNCL,
+     &            MAXSQU = 20*MAXVQU,
+     &            MAXINT = MAXVQU+MAXSQU)
+* flavors of partons (DTUNUC 1.x)
+      COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
+     &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
+     &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
+     &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
+     &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
+     &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
+     &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
+* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
+      COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
+     &                IXPV,IXPS,IXTV,IXTS,
+     &                INTVV1(MAXVQU),INTVV2(MAXVQU),
+     &                INTSV1(MAXVQU),INTSV2(MAXVQU),
+     &                INTVS1(MAXVQU),INTVS2(MAXVQU),
+     &                INTSS1(MAXSQU),INTSS2(MAXSQU),
+     &                INTDV1(MAXVQU),INTDV2(MAXVQU),
+     &                INTVD1(MAXVQU),INTVD2(MAXVQU),
+     &                INTDS1(MAXSQU),INTDS2(MAXSQU),
+     &                INTSD1(MAXSQU),INTSD2(MAXSQU)
+* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
+      COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
+     &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
+* particle properties (BAMJET index convention)
+      CHARACTER*8  ANAME
+      COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+     &                IICH(210),IIBAR(210),K1(210),K2(210)
+* various options for treatment of partons (DTUNUC 1.x)
+* (chain recombination, Cronin,..)
+      LOGICAL LCO2CR,LINTPT
+      COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
+     &                LCO2CR,LINTPT
+
+      IF (MODE.EQ.1) THEN
+* sea-flavors
+         DO 1 I=1,NN
+            IPSQ(I)  = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
+            IPSAQ(I) = -IPSQ(I)
+    1    CONTINUE
+         DO 2 I=1,NN
+            ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
+            ITSAQ(I)= -ITSQ(I)
+    2    CONTINUE
+      ELSEIF (MODE.EQ.2) THEN
+* valence flavors
+         DO 3 I=1,IXPV
+            CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
+    3    CONTINUE
+         DO 4 I=1,IXTV
+            CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
+    4    CONTINUE
+      ENDIF
+
+      RETURN
+      END
+
+*$ CREATE DT_GETPTN.FOR
+*COPY DT_GETPTN
+*
+*===getptn=============================================================*
+*
+      SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
+
+************************************************************************
+* This subroutine collects partons at chain ends from temporary        *
+* commons and puts them into DTEVT1.                                   *
+* This version dated 15.01.95 is written by S. Roesler                 *
+************************************************************************
+
+      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+      SAVE
+      PARAMETER ( LINP = 10 ,
+     &            LOUT = 6 ,
+     &            LDAT = 9 )
+      PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
+
+      LOGICAL LCHK
+
+      PARAMETER ( MAXNCL = 260,
+     &            MAXVQU = MAXNCL,
+     &            MAXSQU = 20*MAXVQU,
+     &            MAXINT = MAXVQU+MAXSQU)
+* event history
+      PARAMETER (NMXHKK=200000)
+      COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+     &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+     &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+* extended event history
+      COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+     &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+     &                IHIST(2,NMXHKK)
+* flags for input different options
+      LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+      COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+     &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+* auxiliary common for chain system storage (DTUNUC 1.x)
+      COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
+* statistics
+      COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
+     &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
+     &                ICEVTG(8,0:30)
+* flags for diffractive interactions (DTUNUC 1.x)
+      COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
+* x-values of partons (DTUNUC 1.x)
+      COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
+     &                XTVQ(MAXVQU),XTVD(MAXVQU),
+     &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
+     &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
+* flavors of partons (DTUNUC 1.x)
+      COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
+     &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
+     &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
+     &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
+     &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
+     &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
+     &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
+* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
+      COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
+     &                IXPV,IXPS,IXTV,IXTS,
+     &                INTVV1(MAXVQU),INTVV2(MAXVQU),
+     &                INTSV1(MAXVQU),INTSV2(MAXVQU),
+     &                INTVS1(MAXVQU),INTVS2(MAXVQU),
+     &                INTSS1(MAXSQU),INTSS2(MAXSQU),
+     &                INTDV1(MAXVQU),INTDV2(MAXVQU),
+     &                INTVD1(MAXVQU),INTVD2(MAXVQU),
+     &                INTDS1(MAXSQU),INTDS2(MAXSQU),
+     &                INTSD1(MAXSQU),INTSD2(MAXSQU)
+* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
+      COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
+     &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
+
+      DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
+
+      DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
+
+      IREJ      = 0
+      NCSY      = 0
+      NPOINT(2) = NHKK+1
+
+* sea-sea chains
+      DO 10 I=1,NSS
+         IF (ISKPCH(1,I).EQ.99) GOTO 10
+         ICCHAI(1,1) = ICCHAI(1,1)+2
+         IDXP = INTSS1(I)
+         IDXT = INTSS2(I)
+         MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
+         MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
+         DO 11 K=1,4
+            PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
+            PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
+            PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
+            PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
+   11    CONTINUE
+         PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
+     &                                  +(PP1(3)+PT1(3))**2)
+         ECH   = PP1(4)+PT1(4)
+         AM1   = (ECH+PTOCH)*(ECH-PTOCH)
+         PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
+     &                                  +(PP2(3)+PT2(3))**2)
+         ECH   = PP2(4)+PT2(4)
+         AM2   = (ECH+PTOCH)*(ECH-PTOCH)
+         IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
+            AM1 = SQRT(AM1)
+            AM2 = SQRT(AM2)
+            IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
+C              WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
+ 5000          FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
+            ENDIF
+         ELSE
+            WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
+         ENDIF
+         IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
+         IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
+         IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
+         IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
+         CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
+     &                                                    0,0,1)
+         CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
+     &                                                    0,0,1)
+         CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
+     &                                                    0,0,1)
+         CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
+     &                                                    0,0,1)
+         NCSY = NCSY+1
+   10 CONTINUE
+
+* disea-sea chains
+      DO 20 I=1,NDS
+         IF (ISKPCH(2,I).EQ.99) GOTO 20
+         ICCHAI(1,2) = ICCHAI(1,2)+2
+         IDXP = INTDS1(I)
+         IDXT = INTDS2(I)
+         MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
+         MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
+         DO 21 K=1,4
+            PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
+            PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
+            PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
+            PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
+   21    CONTINUE
+         PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
+     &                                  +(PP1(3)+PT1(3))**2)
+         ECH   = PP1(4)+PT1(4)
+         AM1   = (ECH+PTOCH)*(ECH-PTOCH)
+         PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
+     &                                  +(PP2(3)+PT2(3))**2)
+         ECH   = PP2(4)+PT2(4)
+         AM2   = (ECH+PTOCH)*(ECH-PTOCH)
+         IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
+            AM1 = SQRT(AM1)
+            AM2 = SQRT(AM2)
+            IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
+C              WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
+ 5001          FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
+            ENDIF
+         ELSE
+            WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
+         ENDIF
+         IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
+         IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
+         IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
+         IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
+         CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
+     &                                                    0,0,2)
+         CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
+     &                                                    0,0,2)
+         CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
+     &                                                    0,0,2)
+         CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
+     &                                                    0,0,2)
+         NCSY = NCSY+1
+   20 CONTINUE
+
+* sea-disea chains
+      DO 30 I=1,NSD
+         IF (ISKPCH(3,I).EQ.99) GOTO 30
+         ICCHAI(1,3) = ICCHAI(1,3)+2
+         IDXP = INTSD1(I)
+         IDXT = INTSD2(I)
+         MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
+         MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
+         DO 31 K=1,4
+            PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
+            PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
+            PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
+            PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
+   31    CONTINUE
+         PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
+     &                                  +(PP1(3)+PT1(3))**2)
+         ECH   = PP1(4)+PT1(4)
+         AM1   = (ECH+PTOCH)*(ECH-PTOCH)
+         PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
+     &                                  +(PP2(3)+PT2(3))**2)
+         ECH   = PP2(4)+PT2(4)
+         AM2   = (ECH+PTOCH)*(ECH-PTOCH)
+         IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
+            AM1 = SQRT(AM1)
+            AM2 = SQRT(AM2)
+            IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
+C              WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
+ 5002          FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
+            ENDIF
+         ELSE
+            WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
+         ENDIF
+         IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
+         IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
+         IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
+         IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
+         CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
+     &                                                    0,0,3)
+         CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
+     &                                                    0,0,3)
+         CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
+     &                                                    0,0,3)
+         CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
+     &                                                    0,0,3)
+         NCSY = NCSY+1
+   30 CONTINUE
+
+* disea-valence chains
+      DO 50 I=1,NDV
+         IF (ISKPCH(5,I).EQ.99) GOTO 50
+         ICCHAI(1,5) = ICCHAI(1,5)+2
+         IDXP = INTDV1(I)
+         IDXT = INTDV2(I)
+         MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
+         MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
+         DO 51 K=1,4
+            PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
+            PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
+            PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
+            PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
+   51    CONTINUE
+         PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
+     &                                  +(PP1(3)+PT1(3))**2)
+         ECH   = PP1(4)+PT1(4)
+         AM1   = (ECH+PTOCH)*(ECH-PTOCH)
+         PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
+     &                                  +(PP2(3)+PT2(3))**2)
+         ECH   = PP2(4)+PT2(4)
+         AM2   = (ECH+PTOCH)*(ECH-PTOCH)
+         IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
+            AM1 = SQRT(AM1)
+            AM2 = SQRT(AM2)
+            IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
+C              WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
+ 5003          FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
+            ENDIF
+         ELSE
+            WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
+         ENDIF
+         IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
+         IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
+         IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
+         IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
+         CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
+     &                                                    0,0,5)
+         CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
+     &                                                    0,0,5)
+         CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
+     &                                                    0,0,5)
+         CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
+     &                                                    0,0,5)
+         NCSY = NCSY+1
+   50 CONTINUE
+
+* valence-sea chains
+      DO 60 I=1,NVS
+         IF (ISKPCH(6,I).EQ.99) GOTO 60
+         ICCHAI(1,6) = ICCHAI(1,6)+2
+         IDXP = INTVS1(I)
+         IDXT = INTVS2(I)
+         MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
+         MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
+         DO 61 K=1,4
+            PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
+            PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
+            PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
+            PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
+   61    CONTINUE
+         IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
+         IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
+         IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
+         IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
+         CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
+         IF (LCHK) THEN
+            CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
+     &                                                       0,0,6)
+            CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
+     &                                                       0,0,6)
+            CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
+     &                                                       0,0,6)
+            CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
+     &                                                       0,0,6)
+            PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
+     &                                     +(PP1(3)+PT1(3))**2)
+            ECH   = PP1(4)+PT1(4)
+            AM1   = (ECH+PTOCH)*(ECH-PTOCH)
+            PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
+     &                                     +(PP2(3)+PT2(3))**2)
+            ECH   = PP2(4)+PT2(4)
+            AM2   = (ECH+PTOCH)*(ECH-PTOCH)
+         ELSE
+            CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
+     &                                                       0,0,6)
+            CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
+     &                                                       0,0,6)
+            CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
+     &                                                       0,0,6)
+            CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
+     &                                                       0,0,6)
+            PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
+     &                                     +(PP1(3)+PT2(3))**2)
+            ECH   = PP1(4)+PT2(4)
+            AM2   = (ECH+PTOCH)*(ECH-PTOCH)
+            PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
+     &                                     +(PP2(3)+PT1(3))**2)
+            ECH   = PP2(4)+PT1(4)
+            AM1   = (ECH+PTOCH)*(ECH-PTOCH)
+         ENDIF
+         IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
+            AM1 = SQRT(AM1)
+            AM2 = SQRT(AM2)
+            IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
+C              WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
+ 5004          FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
+            ENDIF
+         ELSE
+            WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
+         ENDIF
+         NCSY = NCSY+1
+   60 CONTINUE
+
+* sea-valence chains
+      DO 40 I=1,NSV
+         IF (ISKPCH(4,I).EQ.99) GOTO 40
+         ICCHAI(1,4) = ICCHAI(1,4)+2
+         IDXP = INTSV1(I)
+         IDXT = INTSV2(I)
+         MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
+         MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
+         DO 41 K=1,4
+            PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
+            PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
+            PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
+            PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
+   41    CONTINUE
+         PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
+     &                                  +(PP1(3)+PT1(3))**2)
+         ECH   = PP1(4)+PT1(4)
+         AM1   = (ECH+PTOCH)*(ECH-PTOCH)
+         PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
+     &                                  +(PP2(3)+PT2(3))**2)
+         ECH   = PP2(4)+PT2(4)
+         AM2   = (ECH+PTOCH)*(ECH-PTOCH)
+         IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
+            AM1 = SQRT(AM1)
+            AM2 = SQRT(AM2)
+            IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
+C              WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
+ 5005          FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
+            ENDIF
+         ELSE
+            WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
+         ENDIF
+         IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
+         IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
+         IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
+         IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
+         CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
+     &                                                    0,0,4)
+         CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
+     &                                                    0,0,4)
+         CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
+     &                                                    0,0,4)
+         CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
+     &                                                    0,0,4)
+         NCSY = NCSY+1
+   40 CONTINUE
+
+* valence-disea chains
+      DO 70 I=1,NVD
+         IF (ISKPCH(7,I).EQ.99) GOTO 70
+         ICCHAI(1,7) = ICCHAI(1,7)+2
+         IDXP = INTVD1(I)
+         IDXT = INTVD2(I)
+         MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
+         MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
+         DO 71 K=1,4
+            PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
+            PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
+            PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
+            PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
+   71    CONTINUE
+         IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
+         IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
+         IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
+         IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
+         CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
+         IF (LCHK) THEN
+            CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
+     &                                                       0,0,7)
+            CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
+     &                                                       0,0,7)
+            CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
+     &                                                       0,0,7)
+            CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
+     &                                                       0,0,7)
+            PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
+     &                                     +(PP1(3)+PT1(3))**2)
+            ECH   = PP1(4)+PT1(4)
+            AM1   = (ECH+PTOCH)*(ECH-PTOCH)
+            PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
+     &                                     +(PP2(3)+PT2(3))**2)
+            ECH   = PP2(4)+PT2(4)
+            AM2   = (ECH+PTOCH)*(ECH-PTOCH)
+         ELSE
+            CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
+     &                                                       0,0,7)
+            CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
+     &                                                       0,0,7)
+            CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
+     &                                                       0,0,7)
+            CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
+     &                                                       0,0,7)
+            PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
+     &                                     +(PP1(3)+PT2(3))**2)
+            ECH   = PP1(4)+PT2(4)
+            AM1   = (ECH+PTOCH)*(ECH-PTOCH)
+            PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
+     &                                     +(PP2(3)+PT1(3))**2)
+            ECH   = PP2(4)+PT1(4)
+            AM2   = (ECH+PTOCH)*(ECH-PTOCH)
+         ENDIF
+         IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
+            AM1 = SQRT(AM1)
+            AM2 = SQRT(AM2)
+            IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
+C              WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
+ 5006          FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
+            ENDIF
+         ELSE
+            WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
+         ENDIF
+         NCSY = NCSY+1
+   70 CONTINUE
+
+* valence-valence chains
+      DO 80 I=1,NVV
+         IF (ISKPCH(8,I).EQ.99) GOTO 80
+         ICCHAI(1,8) = ICCHAI(1,8)+2
+         IDXP = INTVV1(I)
+         IDXT = INTVV2(I)
+         MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
+         MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
+         DO 81 K=1,4
+            PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
+            PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
+            PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
+            PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
+   81    CONTINUE
+         IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
+         IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
+         IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
+         IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
+
+* check for diffractive event
+         IDIFF = 0
+         IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
+     &        (IP.EQ.1).AND.(NN.EQ.1)) THEN
+            DO 800 K=1,4
+               PP(K) = PP1(K)+PP2(K)
+               PT(K) = PT1(K)+PT2(K)
+  800       CONTINUE
+            ISTCK = NHKK
+            CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
+     &                  IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
+C           IF (IREJ1.NE.0) GOTO 9999
+            IF (IREJ1.NE.0) THEN
+               IDIFF = 0
+               NHKK  = ISTCK
+            ENDIF
+         ELSE
+            IDIFF = 0
+         ENDIF
+
+         IF (IDIFF.EQ.0) THEN
+*   valence-valence chain system
+            CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
+            IF (LCHK) THEN
+*    baryon-baryon
+               CALL DT_EVTPUT(-21,IFP1,MOP,0,
+     &                     PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
+               CALL DT_EVTPUT(-22,IFT1,MOT,0,
+     &                     PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
+               CALL DT_EVTPUT(-21,IFP2,MOP,0,
+     &                     PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
+               CALL DT_EVTPUT(-22,IFT2,MOT,0,
+     &                     PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
+               PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
+     &                                        +(PP1(3)+PT1(3))**2)
+               ECH   = PP1(4)+PT1(4)
+               AM1   = (ECH+PTOCH)*(ECH-PTOCH)
+               PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
+     &                                        +(PP2(3)+PT2(3))**2)
+               ECH   = PP2(4)+PT2(4)
+               AM2   = (ECH+PTOCH)*(ECH-PTOCH)
+            ELSE
+*    antibaryon-baryon
+               CALL DT_EVTPUT(-21,IFP1,MOP,0,
+     &                     PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
+               CALL DT_EVTPUT(-22,IFT2,MOT,0,
+     &                     PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
+               CALL DT_EVTPUT(-21,IFP2,MOP,0,
+     &                     PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
+               CALL DT_EVTPUT(-22,IFT1,MOT,0,
+     &                     PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
+               PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
+     &                                        +(PP1(3)+PT2(3))**2)
+               ECH   = PP1(4)+PT2(4)
+               AM1   = (ECH+PTOCH)*(ECH-PTOCH)
+               PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
+     &                                        +(PP2(3)+PT1(3))**2)
+               ECH   = PP2(4)+PT1(4)
+               AM2   = (ECH+PTOCH)*(ECH-PTOCH)
+            ENDIF
+            IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
+               AM1 = SQRT(AM1)
+               AM2 = SQRT(AM2)
+               IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
+C                 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
+ 5007             FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
+               ENDIF
+            ELSE
+               WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
+            ENDIF
+            NCSY = NCSY+1
+         ENDIF
+   80 CONTINUE
+      IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
+
+* energy-momentum & flavor conservation check
+      IF (ABS(IDIFF).NE.1) THEN
+         IF (IDIFF.NE.0) THEN
+            IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
+     &                                              1,3,10,IREJ)
+         ELSE
+            IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
+     &                                              1,3,10,IREJ)
+         ENDIF
+         IF (IREJ.NE.0) THEN
+            CALL DT_EVTOUT(4)
+            STOP
+         ENDIF
+      ENDIF
+
+      RETURN
+
+ 9999 CONTINUE
+      IREJ  = 1
+      RETURN
+      END
+
+*$ CREATE DT_CHKCSY.FOR
+*COPY DT_CHKCSY
+*
+*===chkcsy=============================================================*
+*
+      SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
+
+************************************************************************
+* CHeCk Chain SYstem for consistency of partons at chain ends.         *
+*            ID1,ID2        PDG-numbers of partons at chain ends       *
+*            LCHK = .true.  consistent chain                           *
+*                 = .false. inconsistent chain                         *
+* This version dated 18.01.95 is written by S. Roesler                 *
+************************************************************************
+
+      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+      SAVE
+      PARAMETER ( LINP = 10 ,
+     &            LOUT = 6 ,
+     &            LDAT = 9 )
+
+      LOGICAL LCHK
+
+      LCHK = .TRUE.
+
+* q-aq chain
+      IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
+         IF (ID1*ID2.GT.0) LCHK = .FALSE.
+* q-qq, aq-aqaq chain
+      ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
+     &        ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
+         IF (ID1*ID2.LT.0) LCHK = .FALSE.
+* qq-aqaq chain
+      ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
+         IF (ID1*ID2.GT.0) LCHK = .FALSE.
+      ENDIF
+
+      RETURN
+      END
+
+*$ CREATE DT_EVENTA.FOR
+*COPY DT_EVENTA
+*
+*===eventa=============================================================*
+*
+      SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
+
+************************************************************************
+* Treatment of nucleon-nucleon interactions in a two-chain             *
+* approximation.                                                       *
+*  (input) ID       BAMJET-index of projectile hadron (in case of      *
+*                   h-K scattering)                                    *
+*          IP/IT    mass number of projectile/target nucleus           *
+*          NCSY     number of two chain systems                        *
+*          IREJ     rejection flag                                     *
+* This version dated 15.01.95 is written by S. Roesler                 *
+************************************************************************
+
+      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+      SAVE
+      PARAMETER ( LINP = 10 ,
+     &            LOUT = 6 ,
+     &            LDAT = 9 )
+      PARAMETER (TINY10=1.0D-10)
+
+* event history
+      PARAMETER (NMXHKK=200000)
+      COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+     &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+     &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+* extended event history
+      COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+     &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+     &                IHIST(2,NMXHKK)
+* rejection counter
+      COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
+     &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
+     &                IREXCI(3),IRDIFF(2),IRINC
+* flags for diffractive interactions (DTUNUC 1.x)
+      COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
+* particle properties (BAMJET index convention)
+      CHARACTER*8  ANAME
+      COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+     &                IICH(210),IIBAR(210),K1(210),K2(210)
+* flags for input different options
+      LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+      COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+     &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+* various options for treatment of partons (DTUNUC 1.x)
+* (chain recombination, Cronin,..)
+      LOGICAL LCO2CR,LINTPT
+      COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
+     &                LCO2CR,LINTPT
+
+      DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
+
+      IREJ      = 0
+      NPOINT(3) = NHKK+1
+
+* skip following treatment for low-mass diffraction
+      IF (ABS(IFLAGD).EQ.1) THEN
+         NPOINT(3) = NPOINT(2)
+         GOTO 5
+      ENDIF
+
+* multiple scattering of chain ends
+      IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
+      IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
+
+      NC = NPOINT(2)
+* get a two-chain system from DTEVT1
+      DO 3 I=1,NCSY
+         IFP1 = IDHKK(NC)
+         IFT1 = IDHKK(NC+1)
+         IFP2 = IDHKK(NC+2)
+         IFT2 = IDHKK(NC+3)
+         DO 4 K=1,4
+            PP1(K) = PHKK(K,NC)
+            PT1(K) = PHKK(K,NC+1)
+            PP2(K) = PHKK(K,NC+2)
+            PT2(K) = PHKK(K,NC+3)
+    4    CONTINUE
+         MOP1 = NC
+         MOT1 = NC+1
+         MOP2 = NC+2
+         MOT2 = NC+3
+         CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
+     &               IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
+         IF (IREJ1.GT.0) THEN
+            IRHHA = IRHHA+1
+            IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
+            GOTO 9999
+         ENDIF
+         NC = NC+4
+    3 CONTINUE
+
+* meson/antibaryon projectile:
+* sample single-chain valence-valence systems (Reggeon contrib.)
+      IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
+         IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
+      ENDIF
+
+      IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
+* check DTEVT1 for remaining resonance mass corrections
+         CALL DT_EVTRES(IREJ1)
+         IF (IREJ1.GT.0) THEN
+            IRRES(1) = IRRES(1)+1
+            IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
+            GOTO 9999
+         ENDIF
+      ENDIF
+
+* assign p_t to two-"chain" systems consisting of two resonances only
+* since only entries for chains will be affected, this is obsolete
+* in case of JETSET-fragmetation
+      CALL DT_RESPT
+
+* combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
+      IF (LCO2CR) CALL DT_COM2CR
+
+    5 CONTINUE
+
+* fragmentation of the complete event
+**uncomment for internal phojet-fragmentation
+C     CALL DT_EVTFRA(IREJ1)
+      CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
+      IF (IREJ1.GT.0) THEN
+         IRFRAG = IRFRAG+1
+         IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
+         GOTO 9999
+      ENDIF
+
+* decay of possible resonances (should be obsolete)
+      CALL DT_DECAY1
+
+      RETURN
+
+ 9999 CONTINUE
+      IREVT = IREVT+1
+      IREJ  = 1
+      RETURN
+      END
+
+*$ CREATE DT_GETCSY.FOR
+*COPY DT_GETCSY
+*
+*===getcsy=============================================================*
+*
+      SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
+     &                  IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
+
+************************************************************************
+* This version dated 15.01.95 is written by S. Roesler                 *
+************************************************************************
+
+      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+      SAVE
+      PARAMETER ( LINP = 10 ,
+     &            LOUT = 6 ,
+     &            LDAT = 9 )
+      PARAMETER (TINY10=1.0D-10)
+
+* event history
+      PARAMETER (NMXHKK=200000)
+      COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+     &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+     &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+* extended event history
+      COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+     &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+     &                IHIST(2,NMXHKK)
+* rejection counter
+      COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
+     &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
+     &                IREXCI(3),IRDIFF(2),IRINC
+* flags for input different options
+      LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+      COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+     &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+* flags for diffractive interactions (DTUNUC 1.x)
+      COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
+
+      DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
+     &          IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
+
+      IREJ  = 0
+
+* get quark content of partons
+      DO 1 I=1,2
+         IFP1(I) = 0
+         IFP2(I) = 0
+         IFT1(I) = 0
+         IFT2(I) = 0
+    1 CONTINUE
+      IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
+      IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
+      IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
+      IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
+      IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
+      IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
+      IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
+      IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
+
+* get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
+      IDCH1 = 2
+      IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
+      IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
+      IDCH2 = 2
+      IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
+      IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
+
+* store initial configuration for energy-momentum cons. check
+      IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
+
+* sample intrinsic p_t at chain-ends
+      CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
+     &            PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
+     &            AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
+      IF (IREJ1.NE.0) THEN
+         IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
+         IRPT = IRPT+1
+         GOTO 9999
+      ENDIF
+
+C      IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
+C         IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
+C* check second chain for resonance
+C            CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
+C     &                  AMCH2,AMCH2N,IDCH2,IREJ1)
+C            IF (IREJ1.NE.0) GOTO 9999
+C            IF (IDR2.NE.0) THEN
+C               CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
+C     &                     AMCH2,AMCH2N,AMCH1,IREJ1)
+C               IF (IREJ1.NE.0) GOTO 9999
+C            ENDIF
+C* check first chain for resonance
+C            CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
+C     &                  AMCH1,AMCH1N,IDCH1,IREJ1)
+C            IF (IREJ1.NE.0) GOTO 9999
+C            IF (IDR1.NE.0) IDR1 = 100*IDR1
+C         ELSE
+C* check first chain for resonance
+C            CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
+C     &                  AMCH1,AMCH1N,IDCH1,IREJ1)
+C            IF (IREJ1.NE.0) GOTO 9999
+C            IF (IDR1.NE.0) THEN
+C               CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
+C     &                     AMCH1,AMCH1N,AMCH2,IREJ1)
+C               IF (IREJ1.NE.0) GOTO 9999
+C            ENDIF
+C* check second chain for resonance
+C            CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
+C     &                  AMCH2,AMCH2N,IDCH2,IREJ1)
+C            IF (IREJ1.NE.0) GOTO 9999
+C            IF (IDR2.NE.0) IDR2 = 100*IDR2
+C         ENDIF
+C      ENDIF
+
+      IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
+* check chains for resonances
+         CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
+     &               AMCH1,AMCH1N,IDCH1,IREJ1)
+         IF (IREJ1.NE.0) GOTO 9999
+         CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
+     &               AMCH2,AMCH2N,IDCH2,IREJ1)
+         IF (IREJ1.NE.0) GOTO 9999
+* change kinematics corresponding to resonance-masses
+         IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
+            CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
+     &                                 AMCH1,AMCH1N,AMCH2,IREJ1)
+            IF (IREJ1.GT.0) GOTO 9999
+            IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
+            CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
+     &                  AMCH2,AMCH2N,IDCH2,IREJ1)
+            IF (IREJ1.NE.0) GOTO 9999
+            IF (IDR2.NE.0) IDR2 = 100*IDR2
+         ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
+            CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
+     &                                 AMCH2,AMCH2N,AMCH1,IREJ1)
+            IF (IREJ1.GT.0) GOTO 9999
+            IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
+            CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
+     &                  AMCH1,AMCH1N,IDCH1,IREJ1)
+            IF (IREJ1.NE.0) GOTO 9999
+            IF (IDR1.NE.0) IDR1 = 100*IDR1
+         ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
+            AMDIF1 = ABS(AMCH1-AMCH1N)
+            AMDIF2 = ABS(AMCH2-AMCH2N)
+            IF (AMDIF2.LT.AMDIF1) THEN
+               CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
+     &                                    AMCH2,AMCH2N,AMCH1,IREJ1)
+               IF (IREJ1.GT.0) GOTO 9999
+               IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
+               CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
+     &                     IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
+               IF (IREJ1.NE.0) GOTO 9999
+               IF (IDR1.NE.0) IDR1 = 100*IDR1
+            ELSE
+               CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
+     &                                    AMCH1,AMCH1N,AMCH2,IREJ1)
+               IF (IREJ1.GT.0) GOTO 9999
+               IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
+               CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
+     &                     IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
+               IF (IREJ1.NE.0) GOTO 9999
+               IF (IDR2.NE.0) IDR2 = 100*IDR2
+            ENDIF
+         ENDIF
+      ENDIF
+
+* store final configuration for energy-momentum cons. check
+      IF (LEMCCK) THEN
+         CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
+         CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
+         IF (IREJ1.NE.0) GOTO 9999
+      ENDIF
+
+* put partons and chains into DTEVT1
+      DO 10 I=1,4
+         PCH1(I) = PP1(I)+PT1(I)
+         PCH2(I) = PP2(I)+PT2(I)
+   10 CONTINUE
+      CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
+     &                                      PP1(3),PP1(4),0,0,0)
+      CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
+     &                                      PT1(3),PT1(4),0,0,0)
+      KCH = 100+IDCH(MOP1)*10+1
+      CALL DT_EVTPUT(KCH,88888,-2,-1,
+     &           PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
+      CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
+     &                                      PP2(3),PP2(4),0,0,0)
+      CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
+     &                                      PT2(3),PT2(4),0,0,0)
+      KCH = KCH+1
+      CALL DT_EVTPUT(KCH,88888,-2,-1,
+     &           PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
+
+      RETURN
+
+ 9999 CONTINUE
+      IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
+* "cancel" sea-sea chains
+         CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
+         IF (IREJ1.NE.0) GOTO 9998
+**sr 16.5. flag for EVENTB
+         IREJ = -1
+         RETURN
+      ENDIF
+ 9998 CONTINUE
+      IREJ = 1
+      RETURN
+      END
+
+*$ CREATE DT_CHKINE.FOR
+*COPY DT_CHKINE
+*
+*===chkine=============================================================*
+*
+      SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
+     &                  AMCH1,AMCH1N,AMCH2,IREJ)
+
+************************************************************************
+* This subroutine replaces CORMOM.                                     *
+* This version dated 05.01.95 is written by S. Roesler                 *
+************************************************************************
+
+      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+      SAVE
+      PARAMETER ( LINP = 10 ,
+     &            LOUT = 6 ,
+     &            LDAT = 9 )
+      PARAMETER (TINY10=1.0D-10)
+
+* flags for input different options
+      LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+      COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+     &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+* rejection counter
+      COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
+     &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
+     &                IREXCI(3),IRDIFF(2),IRINC
+
+      DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
+     &          PP1I(4),PP2I(4),PT1I(4),PT2I(4)
+
+      IREJ  = 0
+      JMSHL = IMSHL
+
+      SCALE  = AMCH1N/MAX(AMCH1,TINY10)
+      DO 10 I=1,4
+         PP1(I) = PP1I(I)
+         PP2(I) = PP2I(I)
+         PT1(I) = PT1I(I)
+         PT2(I) = PT2I(I)
+         PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
+         PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
+         PP1(I) = SCALE*PP1(I)
+         PT1(I) = SCALE*PT1(I)
+   10 CONTINUE
+      IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
+     &    (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
+
+      ECH = PP2(4)+PT2(4)
+      PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
+     &                               (PP2(3)+PT2(3))**2 )
+      AMCH22 = (ECH-PCH)*(ECH+PCH)
+      IF (AMCH22.LT.0.0D0) THEN
+         IF (IOULEV(1).GT.0)
+     &      WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
+         GOTO 9997
+      ENDIF
+
+      AMCH1 = AMCH1N
+      AMCH2 = SQRT(AMCH22)
+
+* put partons again on mass shell
+   13 CONTINUE
+      XM1 = 0.0D0
+      XM2 = 0.0D0
+      IF (JMSHL.EQ.1) THEN
+         XM1 = PYMASS(IFP1)
+         XM2 = PYMASS(IFT1)
+      ENDIF
+      CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
+      IF (IREJ1.NE.0) THEN
+         IF (JMSHL.EQ.0) GOTO 9998
+         JMSHL = 0
+         GOTO 13
+      ENDIF
+      JMSHL = IMSHL
+      DO 11 I=1,4
+         PP1(I) = P1(I)
+         PT1(I) = P2(I)
+   11 CONTINUE
+   14 CONTINUE
+      XM1 = 0.0D0
+      XM2 = 0.0D0
+      IF (JMSHL.EQ.1) THEN
+         XM1 = PYMASS(IFP2)
+         XM2 = PYMASS(IFT2)
+      ENDIF
+      CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
+      IF (IREJ1.NE.0) THEN
+         IF (JMSHL.EQ.0) GOTO 9998
+         JMSHL = 0
+         GOTO 14
+      ENDIF
+      DO 12 I=1,4
+         PP2(I) = P1(I)
+         PT2(I) = P2(I)
+   12 CONTINUE
+      DO 15 I=1,4
+         PP1I(I) = PP1(I)
+         PP2I(I) = PP2(I)
+         PT1I(I) = PT1(I)
+         PT2I(I) = PT2(I)
+   15 CONTINUE
+      RETURN
+
+ 9997 IRCHKI(1) = IRCHKI(1)+1
+**sr
+C     GOTO 9999
+      IREJ = -1
+      RETURN
+**
+ 9998 IRCHKI(2) = IRCHKI(2)+1
+
+ 9999 CONTINUE
+      IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
+      IREJ = 1
+      RETURN
+      END
+
+*$ CREATE DT_CH2RES.FOR
+*COPY DT_CH2RES
+*
+*===ch2res=============================================================*
+*
+      SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
+     &                  AM,AMN,IMODE,IREJ)
+
+************************************************************************
+* Check chains for resonance production.                               *
+* This subroutine replaces COMCMA/COBCMA/COMCM2                        *
+*    input:                                                            *
+*          IF1,2,3,4    input flavors (q,aq in any order)              *
+*          AM           chain mass                                     *
+*          MODE = 1     check q-aq chain for meson-resonance           *
+*               = 2     check q-qq, aq-aqaq chain for baryon-resonance *
+*               = 3     check qq-aqaq chain for lower mass cut         *
+*    output:                                                           *
+*          IDR = 0      no resonances found                            *
+*              = -1     pseudoscalar meson/octet baryon                *
+*              = 1      vector-meson/decuplet baryon                   *
+*          IDXR         BAMJET-index of corresponding resonance        *
+*          AMN          mass of corresponding resonance                *
+*                                                                      *
+*          IREJ         rejection flag                                 *
+* This version dated 06.01.95 is written by S. Roesler                 *
+************************************************************************
+
+      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+      SAVE
+      PARAMETER ( LINP = 10 ,
+     &            LOUT = 6 ,
+     &            LDAT = 9 )
+
+* particle properties (BAMJET index convention)
+      CHARACTER*8  ANAME
+      COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
+     &                IICH(210),IIBAR(210),K1(210),K2(210)
+* quark-content to particle index conversion (DTUNUC 1.x)
+      COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
+     &                IA08(6,21),IA10(6,21)
+* rejection counter
+      COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
+     &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
+     &                IREXCI(3),IRDIFF(2),IRINC
+* flags for input different options
+      LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+      COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+     &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+
+      DIMENSION IF(4),JF(4)
+
+**sr 4.7. test
+C     DATA AMLOM,AMLOB /0.08D0,0.2D0/
+      DATA AMLOM,AMLOB /0.1D0,0.7D0/
+**
+C     DATA AMLOM,AMLOB /0.001D0,0.001D0/
+
+      MODE = ABS(IMODE)
+
+      IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
+         WRITE(LOUT,1000) MODE
+ 1000    FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
+     &          1X,'        program stopped')
+         STOP
+      ENDIF
+
+      AMX  = AM
+      IREJ = 0
+      IDR  = 0
+      IDXR = 0
+      AMN  = AMX
+      IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
+      IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
+
+      IF(1) = IF1
+      IF(2) = IF2
+      IF(3) = IF3
+      IF(4) = IF4
+      NF = 0
+      DO 100 I=1,4
+         IF (IF(I).NE.0) THEN
+            NF = NF+1
+            JF(NF) = IF(I)
+         ENDIF
+  100 CONTINUE
+      IF (NF.LE.MODE) THEN
+         WRITE(LOUT,1001) MODE,IF
+ 1001    FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
+     &   I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
+         GOTO 9999
+      ENDIF
+
+      GOTO (1,2,3) MODE
+
+* check for meson resonance
+    1 CONTINUE
+      IFQ  = JF(1)
+      IFAQ = ABS(JF(2))
+      IF (JF(2).GT.0) THEN
+         IFQ  = JF(2)
+         IFAQ = ABS(JF(1))
+      ENDIF
+      IFPS = IMPS(IFAQ,IFQ)
+      IFV  = IMVE(IFAQ,IFQ)
+      AMPS = AAM(IFPS)
+      AMV  = AAM(IFV)
+      AMHI = AMV+0.3D0
+      IF (AMX.LT.AMV) THEN
+         IF (AMX.LT.AMPS) THEN
+            IF (IMODE.GT.0) THEN
+               IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
+            ELSE
+               IF (AMX.LT.0.8D0*AMPS) GOTO 9999
+            ENDIF
+            LOMRES = LOMRES+1
+         ENDIF
+*    replace chain by pseudoscalar meson
+         IDR  = -1
+         IDXR = IFPS
+         AMN  = AMPS
+      ELSEIF (AMX.LT.AMHI) THEN
+*    replace chain by vector-meson
+         IDR  = 1
+         IDXR = IFV
+         AMN  = AMV
+      ENDIF
+      RETURN
+
+* check for baryon resonance
+    2 CONTINUE
+      CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
+      AM8  = AAM(JB8)
+      AM10 = AAM(JB10)
+      AMHI = AM10+0.3D0
+      IF (AMX.LT.AM10) THEN
+         IF (AMX.LT.AM8) THEN
+            IF (IMODE.GT.0) THEN
+               IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
+            ELSE
+               IF (AMX.LT.0.8D0*AM8) GOTO 9999
+            ENDIF
+            LOBRES = LOBRES+1
+         ENDIF
+*    replace chain by oktet baryon
+         IDR  = -1
+         IDXR = JB8
+         AMN  = AM8
+      ELSEIF (AMX.LT.AMHI) THEN
+         IDR  = 1
+         IDXR = JB10
+         AMN  = AM10
+      ENDIF
+      RETURN
+
+* check qq-aqaq for lower mass cut
+    3 CONTINUE
+*   empirical definition of AMHI to allow for (b-antib)-pair prod.
+      AMHI = 2.5D0
+      IF (AMX.LT.AMHI) GOTO 9999
+      RETURN
+
+ 9999 CONTINUE
+      IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
+     &    WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
+      IREJ = 1
+      IRRES(2) = IRRES(2)+1
+      RETURN
+      END
+
+*$ CREATE DT_RJSEAC.FOR
+*COPY DT_RJSEAC
+*
+*===rjseac=============================================================*
+*
+      SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
+
+************************************************************************
+* ReJection of SEA-sea Chains.                                         *
+*         MOP1/2       entries of projectile sea-partons in DTEVT1     *
+*         MOT1/2       entries of projectile sea-partons in DTEVT1     *
+* This version dated 16.01.95 is written by S. Roesler                 *
+************************************************************************
+
+      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+      SAVE
+      PARAMETER ( LINP = 10 ,
+     &            LOUT = 6 ,
+     &            LDAT = 9 )
+      PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
+
+* event history
+      PARAMETER (NMXHKK=200000)
+      COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+     &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+     &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+* extended event history
+      COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+     &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+     &                IHIST(2,NMXHKK)
+* statistics
+      COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
+     &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
+     &                ICEVTG(8,0:30)
+
+      DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
+
+      IREJ = 0
+
+* projectile sea q-aq-pair
+*    indices of sea-pair
+      IDXSEA(1,1) = MOP1
+      IDXSEA(1,2) = MOP2
+*    index of mother-nucleon
+      IDXNUC(1)   = JMOHKK(1,MOP1)
+*    status of valence quarks to be corrected
+      ISTVAL(1)   = -21
+
+* target sea q-aq-pair
+*    indices of sea-pair
+      IDXSEA(2,1) = MOT1
+      IDXSEA(2,2) = MOT2
+*    index of mother-nucleon
+      IDXNUC(2)   = JMOHKK(1,MOT1)
+*    status of valence quarks to be corrected
+      ISTVAL(2)   = -22
+
+      DO 1 N=1,2
+         IDONE = 0
+         DO 2 I=NPOINT(2),NHKK
+            IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
+     &          (JMOHKK(1,I).EQ.IDXNUC(N)))   THEN
+* valence parton found
+*    inrease 4-momentum by sea 4-momentum
+               DO 3 K=1,4
+                  PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
+     &                                  PHKK(K,IDXSEA(N,2))
+    3          CONTINUE
+               PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
+     &                              PHKK(2,I)**2-PHKK(3,I)**2))
+*    "cancel" sea-pair
+               DO 4 J=1,2
+                  ISTHKK(IDXSEA(N,J))   = 100
+                  IDHKK(IDXSEA(N,J))    = 0
+                  JMOHKK(1,IDXSEA(N,J)) = 0
+                  JMOHKK(2,IDXSEA(N,J)) = 0
+                  JDAHKK(1,IDXSEA(N,J)) = 0
+                  JDAHKK(2,IDXSEA(N,J)) = 0
+                  DO 5 K=1,4
+                     PHKK(K,IDXSEA(N,J)) = ZERO
+                     VHKK(K,IDXSEA(N,J)) = ZERO
+                     WHKK(K,IDXSEA(N,J)) = ZERO
+    5             CONTINUE
+                  PHKK(5,IDXSEA(N,J)) = ZERO
+    4          CONTINUE
+               IDONE = 1
+            ENDIF
+    2    CONTINUE
+         IF (IDONE.NE.1) THEN
+            WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
+ 1000       FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
+     &                '-record!',/,1X,'        sea-quark pairs   ',
+     &                2I5,4X,2I5,'   could not be canceled!')
+            GOTO 9999
+         ENDIF
+    1 CONTINUE
+      ICRJSS = ICRJSS+1
+      RETURN
+
+ 9999 CONTINUE
+      IREJ = 1
+      RETURN
+      END
+
+*$ CREATE DT_VV2SCH.FOR
+*COPY DT_VV2SCH
+*
+*===vv2sch=============================================================*
+*
+      SUBROUTINE DT_VV2SCH
+
+************************************************************************
+* Change Valence-Valence chain systems to Single CHain systems for     *
+* hadron-nucleus collisions with meson or antibaryon projectile.       *
+* (Reggeon contribution)                                               *
+* The single chain system is approximately treated as one chain and a  *
+* meson at rest.                                                       *
+* This version dated 18.01.95 is written by S. Roesler                 *
+************************************************************************
+
+      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+      SAVE
+      PARAMETER ( LINP = 10 ,
+     &            LOUT = 6 ,
+     &            LDAT = 9 )
+      PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
+
+      LOGICAL LSTART
+
+* event history
+      PARAMETER (NMXHKK=200000)
+      COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
+     &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
+     &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
+* extended event history
+      COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
+     &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
+     &                IHIST(2,NMXHKK)
+* flags for input different options
+      LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
+      COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
+     &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
+* statistics
+      COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
+     &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
+     &                ICEVTG(8,0:30)
+
+      DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
+     &          PCH2(4)
+
+      DATA LSTART /.TRUE./
+
+      IFSC  = 0
+      IF (LSTART) THEN
+         WRITE(LOUT,1000)
+ 1000    FORMAT(/,1X,'VV2SCH:  Reggeon contribution to valance-',
+     &          'valence chains treated')
+         LSTART = .FALSE.
+      ENDIF
+
+      NSTOP = NHKK
+
+* get index of first chain
+      DO 1 I=NPOINT(3),NHKK
+         IF (IDHKK(I).EQ.88888) THEN
+            NC = I
+            GOTO 2
+         ENDIF
+    1 CONTINUE
+
+    2 CONTINUE
+      IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
+     &                        .AND.(NC.LT.NSTOP)) THEN
+* get valence-valence chains
+         IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
+*   get "mother"-hadron indices
+            MO1   = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
+            MO2   = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
+            KPROJ = IDT_ICIHAD(IDHKK(MO1))
+            KTARG = IDT_ICIHAD(IDHKK(MO2))
+*   Lab momentum of projectile hadron
+            CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
+            PTOT  = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
+     &                                  PHKK(3,MO1)**2)
+
+            SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
+            IF (DT_RNDM(PTOT).LE.SICHAP) THEN
+               ICVV2S = ICVV2S+1
+*   single chain requested
+*      get flavors of chain-end partons
+               MO(1) = JMOHKK(1,NC)
+               MO(2) = JMOHKK(2,NC)
+               MO(3) = JMOHKK(1,NC+3)
+               MO(4) = JMOHKK(2,NC+3)
+               DO 3 I=1,4
+                  IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
+                  IF(I,2) = 0
+                  IF (ABS(IDHKK(MO(I))).GE.1000)
+     &               IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
+    3          CONTINUE
+*      which one is the q-aq chain?
+*        N1,N1+1 - DTEVT1-entries for q-aq system
+*        N2,N2+1 -