Obsolete.
authormorsch <morsch@f7af4fe6-9843-0410-8265-dc069ae4e863>
Tue, 18 Mar 2008 12:06:20 +0000 (12:06 +0000)
committermorsch <morsch@f7af4fe6-9843-0410-8265-dc069ae4e863>
Tue, 18 Mar 2008 12:06:20 +0000 (12:06 +0000)
DPMJET/dpmjet3.0-4.f [deleted file]
DPMJET/phojet1.12-35c.f [deleted file]
DPMJET/pythia6115.f [deleted file]

diff --git a/DPMJET/dpmjet3.0-4.f b/DPMJET/dpmjet3.0-4.f
deleted file mode 100644 (file)
index d98f765..0000000
+++ /dev/null
@@ -1,37141 +0,0 @@
-*
-*    +-------------------------------------------------------------+
-*    |                                                             |
-*    |                                                             |
-*    |                        DPMJET 3.0                           |
-*    |                                                             |
-*    |                                                             |
-*    |         S. Roesler+), R. Engel#), J. Ranft*)                |
-*    |                                                             |
-*    |         +) CERN, TIS-RP                                     |
-*    |            CH-1211 Geneva 23, Switzerland                   |
-*    |            Email: Stefan.Roesler@cern.ch                    |
-*    |                                                             |
-*    |         #) University of Delaware, BRI                      |
-*    |            Newark, DE 19716, USA                            |
-*    |                                                             |
-*    |         *) 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===============================================================*
-*
-CDECK  ID>, DT_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.                *
-************************************************************************
-
-      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
-      SAVE
-
-      PARAMETER ( LINP = 5 ,
-     &            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)
-
-      INCLUDE '(DIMPAR)'
-      INCLUDE '(PAREVT)'
-      INCLUDE '(EVAPAR)'
-      INCLUDE '(FRBKCM)'
-
-      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/
-
-* --- Added by Chiara
-      
-      CHARACTER*100  ALIROOT  
-      CHARACTER*100 FILNAM
-      INTEGER*4 LNROOT
-      LOGICAL EXISTS
-      ALIROOT=' '
-
-*---------------------------------------------------------------------
-* 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 FL48UT (ISRM48,ISEED1,ISEED2)
-            CALL FL48IN (54217137,ISEED1,ISEED2)
-
-         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
-C      READ(LINP,'(A78)',END=9999) CLINE
-* ###   Read control card from specified file 
-* ### Changed by Chiara (original version LINP=5)
-*      OPEN(UNIT=7,
-*     + FILE='/home/oppedisa/AliRoot/new/DPMJET/inp/PbPbLHC.inp',
-*     + STATUS='OLD')
-
-      CALL GETENVF('ALICE_ROOT',ALIROOT)
-      LNROOT = LNBLNK(ALIROOT)
-
-      FILNAM=ALIROOT(1:LNROOT)//'/DPMJET/inp/ppLHC.inp'
-      OPEN(UNIT=7,FILE=FILNAM,STATUS='OLD')
-      OPEN(UNIT=14,FILE="nuclear.bin",STATUS='OLD')
-*     OPEN(UNIT=6,FILE="dpm.out",STATUS='UNKNOWN')
-
-      READ(7,'(A78)',END=9999) CLINE
-
-      IF (CLINE(1:1).EQ.'*') THEN
-* comment-line
-C         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
-C      READ(LINP,'(A78)') CTITLE
-* ###   Read control card from specified file 
-* ### Changed by Chiara (original version LINP=5)
-      READ(7,'(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
-
-      IF (WHAT(1).LE.-1.0D0) THEN
-         LEVPRT = .FALSE.
-         LDEEXG = .FALSE.
-         LHEAVY = .FALSE.
-         GOTO 10
-      ENDIF
-      WHTSAV = WHAT (1)
-      IF ( NINT (WHAT (1)) .GE. 10000 ) THEN
-         LLVMOD   = .FALSE.
-         JLVHLP   = NINT (WHAT (1)) / 10000
-         WHAT (1) = WHAT (1) - 10000.D+00 * JLVHLP
-      END IF
-      IF ( NINT (WHAT (1)) .GE. 100 ) THEN
-         JLVMOD   = NINT (WHAT (1)) / 100
-         WHAT (1) = WHAT (1) - 100.D+00 * JLVMOD
-      END IF
-      IF ( NINT (WHAT (1)) .GE. 10  ) THEN
-         IFISS    = 1
-         JLVHLP   = NINT (WHAT (1)) / 10
-         WHAT (1) = WHAT (1) - 10.D+00 * JLVHLP
-      ELSE IF ( NINT (WHTSAV) .NE. 0 ) THEN
-         IFISS    = 0
-      END IF
-      IF ( NINT (WHAT (1)) .GE. 0 ) THEN
-         LEVPRT = .TRUE.
-         ILVMOD = NINT (WHAT(1))
-         IF ( ABS (NINT (WHAT (2))) .GE. 10  ) THEN
-            LFRMBK   = .TRUE.
-            JLVHLP   = NINT (WHAT (2)) / 10
-            WHAT (2) = WHAT (2) - 10.D+00 * JLVHLP
-         ELSE IF ( NINT (WHAT (2)) .NE. 0 ) THEN
-            LFRMBK   = .FALSE.
-         END IF
-         IF ( NINT (WHAT (2)) .GE. 0 ) THEN
-            LDEEXG = .TRUE.
-         ELSE
-            LDEEXG = .FALSE.
-         END IF
-**sr heavies are always put to /FKFHVY/
-C        IF ( NINT (WHAT(3)) .GE. 1 ) THEN
-C           LHEAVY = .TRUE.
-C        ELSE
-C           LHEAVY = .FALSE.
-C        END IF
-         LHEAVY = .TRUE.
-      ELSE
-         LEVPRT = .FALSE.
-         LDEEXG = .FALSE.
-         LHEAVY = .FALSE.
-      END IF
-
-      LOLDEV = .FALSE.
-
-      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
-
-C         CALL PHO_INIT(LINP,IREJ1)
-* ###   Read control card from specified file 
-* ### Changed by Chiara (original version LINP=5)
-         CALL PHO_INIT(7,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='shm.out',STATUS='UNKNOWN')
-C        OPEN(11,FILE='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='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 BERTTP
-         CALL 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
-
-*  initialize evaporation if the code is not used as Fluka event generator
-      IF (ITRSPT.NE.1) THEN
-*         CALL BERTTP
-*         CALL INCINI
-      ENDIF
-      IF (LEVPRT) LHEAVY = .TRUE.
-
-
-* 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
-*
-*===kkinc==============================================================*
-*
-CDECK  ID>, DT_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 = 5 ,
-     &            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
-
-* 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
-*
-*===defaul=============================================================*
-*
-CDECK  ID>, DT_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
-**sr 7.4.98: changed after corrected B-sampling
-C     FERMOD    = 0.55D0
-      FERMOD    = 0.68D0
-      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.1D0
-      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
-*
-*===aaevt==============================================================*
-*
-CDECK  ID>, DT_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 = 5 ,
-     &            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
-*
-*===laevt==============================================================*
-*
-CDECK  ID>, DT_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 = 5 ,
-     &            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)
-*  Introduced by Chiara -> force CMS-system
-*            IFRAME = 2
-*  to 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
-*
-*===dtuini=============================================================*
-*
-CDECK  ID>, DT_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
-*
-*===dtuout=============================================================*
-*
-CDECK  ID>, DT_DTUOUT
-      SUBROUTINE DT_DTUOUT
-
-      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
-      SAVE
-
-      CALL PHO_PHIST(3000,DUM)
-
-      CALL DT_STATIS(2)
-
-      RETURN
-      END
-*
-*===beam===============================================================*
-*
-CDECK  ID>, DT_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 = 5 ,
-     &            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
-*
-*===eventb=============================================================*
-*
-CDECK  ID>, DT_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 = 5 ,
-     &            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
-*
-*===getpje=============================================================*
-*
-CDECK  ID>, DT_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 = 5 ,
-     &            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
-*
-*===phoini=============================================================*
-*
-CDECK  ID>, DT_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: s.r. 21.01.01                                           *
-************************************************************************
-
-      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
-      SAVE
-
-      PARAMETER ( LINP = 5 ,
-     &            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,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
-C *** Commented by Chiara
-C         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)
-C *** Commented by Chiara
-C         IF (NCOMPO.GT.0) THEN
-C            WRITE(LOUT,1002) SCPF,PTF,PT
-C         ELSE
-C            WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT
-C         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)
-C *** Commented by Chiara
-C         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
-
-*
-*===eventd=============================================================*
-*
-CDECK  ID>, DT_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 = 5 ,
-     &            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
-*
-*===kkevnt=============================================================*
-*
-CDECK  ID>, DT_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 = 5 ,
-     &            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)
-* --- Added by Chiara to monit impact parameter generation
-*       PRINT *,' Impact parameter generation : b = ', BIMPAC, 'fm'
-         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
-*
-*===chkcen=============================================================*
-*
-CDECK  ID>, DT_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 = 5 ,
-     &            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
-*
-*===ininuc=============================================================*
-*
-CDECK  ID>, DT_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 = 5 ,
-     &            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
-*
-*===fer4m==============================================================*
-*
-CDECK  ID>, DT_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 = 5 ,
-     &            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
-*
-*===nuc2cm=============================================================*
-*
-CDECK  ID>, DT_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 = 5 ,
-     &            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
-*
-*===splptn=============================================================*
-*
-CDECK  ID>, DT_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 = 5 ,
-     &            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
-*
-*===splfla=============================================================*
-*
-CDECK  ID>, DT_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 = 5 ,
-     &            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
-*
-*===getptn=============================================================*
-*
-CDECK  ID>, DT_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 = 5 ,
-     &            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
-*
-*===chkcsy=============================================================*
-*
-CDECK  ID>, DT_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 = 5 ,
-     &            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
-*
-*===eventa=============================================================*
-*
-CDECK  ID>, DT_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 = 5 ,
-     &            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
-*
-*===getcsy=============================================================*
-*
-CDECK  ID>, DT_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 = 5 ,
-     &            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
-*
-*===chkine=============================================================*
-*
-CDECK  ID>, DT_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 = 5 ,
-     &            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
-*
-*===ch2res=============================================================*
-*
-CDECK  ID>, DT_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 = 5 ,
-     &            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
-*
-*===rjseac=============================================================*
-*
-CDECK  ID>, DT_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 = 5 ,
-     &            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
-*
-*===vv2sch=============================================================*
-*
-CDECK  ID>, DT_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 = 5 ,
-     &            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 - DTEVT1-entries for the other chain
-               IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
-                  K1 = 1
-                  K2 = 3
-                  N1 = NC-2
-                  N2 = NC+1
-               ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
-                  K1 = 3
-                  K2 = 1
-                  N1 = NC+1
-                  N2 = NC-2
-               ELSE
-                  GOTO 10
-               ENDIF
-               DO 4 K=1,4